mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-19 20:57:21 +03:00
Merge branch 'master' into tactic-exclude-coercions
This commit is contained in:
commit
8050b14406
@ -64,14 +64,24 @@ defaults: &defaults
|
||||
no_output_timeout: 120m
|
||||
|
||||
- run:
|
||||
name: Test haskell-language-server
|
||||
name: Test haskell-language-server func-test suite
|
||||
# Tasty by default will run all the tests in parallel. Which should
|
||||
# work ok, but given that these CircleCI runners aren't the beefiest
|
||||
# machine can cause some flakiness. So pass -j1 to Tasty (NOT Stack) to
|
||||
# tell it to go slow and steady.
|
||||
command: stack --stack-yaml=${STACK_FILE} test haskell-language-server --dump-logs --test-arguments="-j1"
|
||||
command: stack --stack-yaml=${STACK_FILE} test haskell-language-server:func-test --dump-logs --test-arguments="-j1 --rerun-update" || stack --stack-yaml=${STACK_FILE} test haskell-language-server:func-test --dump-logs --test-arguments="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true stack --stack-yaml=${STACK_FILE} test haskell-language-server:func-test --dump-logs --test-arguments="-j1 --rerun"
|
||||
no_output_timeout: 120m
|
||||
|
||||
- run:
|
||||
name: Test haskell-language-server wrapper-test suite
|
||||
command: stack --stack-yaml=${STACK_FILE} test haskell-language-server:wrapper-test --dump-logs --test-arguments="-j1" || stack --stack-yaml=${STACK_FILE} test haskell-language-server:wrapper-test --dump-logs --test-arguments="-j1"
|
||||
no_output_timeout: 30m
|
||||
|
||||
- run:
|
||||
name: Test hls-tactics-plugin
|
||||
command: stack --stack-yaml=${STACK_FILE} test hls-tactics-plugin:test:tests --dump-logs --test-arguments="-j1"
|
||||
no_output_timeout: 30m
|
||||
|
||||
- store_test_results:
|
||||
path: test-results
|
||||
|
||||
@ -119,10 +129,10 @@ jobs:
|
||||
- STACK_FILE: "stack-8.10.2.yaml"
|
||||
<<: *defaults
|
||||
|
||||
# ghc-nightly:
|
||||
# environment:
|
||||
# - STACK_FILE: "stack.yaml"
|
||||
# <<: *defaults
|
||||
ghc-nightly:
|
||||
environment:
|
||||
- STACK_FILE: "stack.yaml"
|
||||
<<: *defaults
|
||||
|
||||
cabal:
|
||||
working_directory: ~/build
|
||||
@ -180,7 +190,7 @@ jobs:
|
||||
- cabal-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}
|
||||
- run:
|
||||
name: Build
|
||||
command: nix-shell -j4 --run "cabal new-update && cabal new-build -j1 --enable-tests"
|
||||
command: nix-shell -j4 --run "cabal new-update && (cabal new-build -j1 --enable-tests || cabal new-build -j1 --enable-tests) "
|
||||
no_output_timeout: 30m
|
||||
- save_cache:
|
||||
key: cabal-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}
|
||||
|
38
.github/ISSUE_TEMPLATE.md
vendored
38
.github/ISSUE_TEMPLATE.md
vendored
@ -1,31 +1,31 @@
|
||||
<!--
|
||||
If you encounter a bug or you have a support question, please try to fill out some of the information below.
|
||||
However, if you think your issue does not need any of it, you may omit it.
|
||||
Generally speaking, the information below is meant for helping debugging issues
|
||||
but they are no prerequisite for opening issues.
|
||||
|
||||
### Subject of the issue
|
||||
Describe your issue here.
|
||||
Generally speaking, the information below is meant to help debugging issues but is no prerequisite for opening an issue.
|
||||
-->
|
||||
|
||||
### Your environment
|
||||
* Output of `haskell-language-server --probe-tools` or `haskell-language-server-wrapper --probe-tools`
|
||||
* This command is available since version `>= 0.4.0.0`
|
||||
* Which lsp-client do you use
|
||||
* Neovim, emacs, VS Codium, etc...
|
||||
* Describe your project (alternative: link to the project)
|
||||
* Include `stack.yaml`
|
||||
* Include `package.yaml`
|
||||
* Include `*.cabal` files
|
||||
* Include `cabal.project`
|
||||
* Contents of `hie.yaml`
|
||||
Output of `haskell-language-server --probe-tools` or `haskell-language-server-wrapper --probe-tools`:
|
||||
<!-- This command is available since version `>= 0.4.0.0` -->
|
||||
```sh
|
||||
|
||||
```
|
||||
Which lsp-client do you use:
|
||||
<!-- Neovim, emacs, VS Codium, etc... -->
|
||||
Describe your project (alternative: link to the project):
|
||||
<!-- stack.yaml, package.yaml, *.cabal files, cabal.project -->
|
||||
Contents of `hie.yaml`:
|
||||
```yaml
|
||||
|
||||
```
|
||||
|
||||
### Steps to reproduce
|
||||
Tell us how to reproduce this issue.
|
||||
<!-- Tell us how to reproduce this issue. -->
|
||||
|
||||
### Expected behaviour
|
||||
Tell us what should happen.
|
||||
<!-- Tell us what should happen. -->
|
||||
|
||||
### Actual behaviour
|
||||
Tell us what happens instead.
|
||||
<!-- Tell us what happens instead. -->
|
||||
|
||||
### Include debug information
|
||||
Execute in the root of your project the command `haskell-language-server --debug .` and paste the logs here:
|
||||
|
9
.github/workflows/build.yml
vendored
9
.github/workflows/build.yml
vendored
@ -7,6 +7,7 @@ defaults:
|
||||
on:
|
||||
release:
|
||||
types: [created]
|
||||
|
||||
jobs:
|
||||
|
||||
build:
|
||||
@ -46,13 +47,11 @@ jobs:
|
||||
|
||||
- name: Set some window specific things
|
||||
if: matrix.os == 'windows-latest'
|
||||
run: |
|
||||
echo '::set-env name=EXE_EXT::.exe'
|
||||
run: echo "EXE_EXT=.exe" >> $GITHUB_ENV
|
||||
|
||||
- name: Set some linux specific things
|
||||
if: matrix.os == 'ubuntu-latest'
|
||||
run: |
|
||||
echo '::set-env name=LINUX_CABAL_ARGS::--enable-executable-static --ghc-options=-split-sections'
|
||||
run: echo "LINUX_CABAL_ARGS=--enable-executable-static --ghc-options=-split-sections" >> $GITHUB_ENV
|
||||
|
||||
- name: Build Server
|
||||
# Try building it twice in case of flakey builds on Windows
|
||||
@ -154,7 +153,7 @@ jobs:
|
||||
# decompress them
|
||||
gzip -d bin/*.gz
|
||||
cd bin
|
||||
tar -czf haskell-language-server.tar.gz *
|
||||
tar -czpf haskell-language-server.tar.gz *
|
||||
|
||||
- uses: actions/upload-release-asset@v1.0.2
|
||||
env:
|
||||
|
79
.github/workflows/test.yml
vendored
Normal file
79
.github/workflows/test.yml
vendored
Normal file
@ -0,0 +1,79 @@
|
||||
name: Testing
|
||||
|
||||
on: [push, pull_request]
|
||||
jobs:
|
||||
test:
|
||||
runs-on: ${{ matrix.os }}
|
||||
strategy:
|
||||
fail-fast: false
|
||||
matrix:
|
||||
ghc: ['8.10.2', '8.10.1', '8.8.4', '8.8.3', '8.8.2', '8.6.5', '8.6.4']
|
||||
os: [ubuntu-latest, macOS-latest, windows-latest]
|
||||
exclude:
|
||||
- os: windows-latest
|
||||
ghc: '8.10.2' # broken due to https://gitlab.haskell.org/ghc/ghc/-/issues/18550
|
||||
- os: windows-latest
|
||||
ghc: '8.8.4' # also fails due to segfault :(
|
||||
- os: windows-latest
|
||||
ghc: '8.8.3' # fails due to segfault
|
||||
- os: windows-latest
|
||||
ghc: '8.8.2' # fails due to error with Cabal
|
||||
|
||||
steps:
|
||||
- uses: actions/checkout@v2
|
||||
with:
|
||||
submodules: true
|
||||
- uses: actions/setup-haskell@v1
|
||||
with:
|
||||
ghc-version: ${{ matrix.ghc }}
|
||||
cabal-version: '3.2'
|
||||
enable-stack: true
|
||||
|
||||
- name: Cache Cabal
|
||||
uses: actions/cache@v2
|
||||
env:
|
||||
cache-name: cache-cabal
|
||||
with:
|
||||
path: ~/.cabal/
|
||||
key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}
|
||||
restore-keys: |
|
||||
${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-
|
||||
${{ runner.os }}-${{ matrix.ghc }}-build-
|
||||
${{ runner.os }}-${{ matrix.ghc }}
|
||||
|
||||
- run: cabal update
|
||||
|
||||
# Need this to work around filepath length limits in Windows
|
||||
- name: Shorten binary names
|
||||
shell: bash
|
||||
run: |
|
||||
sed -i.bak -e 's/haskell-language-server/hls/g' \
|
||||
-e 's/haskell_language_server/hls/g' \
|
||||
haskell-language-server.cabal
|
||||
sed -i.bak -e 's/Paths_haskell_language_server/Paths_hls/g' \
|
||||
src/**/*.hs exe/*.hs
|
||||
|
||||
- name: Build
|
||||
shell: bash
|
||||
# Retry it three times to workaround compiler segfaults in windows
|
||||
run: cabal build || cabal build || cabal build
|
||||
|
||||
- name: Test func-test suite
|
||||
shell: bash
|
||||
env:
|
||||
HLS_TEST_EXE: hls
|
||||
HLS_WRAPPER_TEST_EXE: hls-wrapper
|
||||
# run the tests without parallelism, otherwise tasty will attempt to run
|
||||
# all functional test cases simultaneously which causes way too many hls
|
||||
# instances to be spun up for the poor github actions runner to handle
|
||||
run: cabal test func-test --test-options="-j1 --rerun-update" || cabal test func-test --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test func-test --test-options="-j1 --rerun"
|
||||
|
||||
- name: Test wrapper-test suite
|
||||
shell: bash
|
||||
env:
|
||||
HLS_TEST_EXE: hls
|
||||
HLS_WRAPPER_TEST_EXE: hls-wrapper
|
||||
# run the tests without parallelism, otherwise tasty will attempt to run
|
||||
# all functional test cases simultaneously which causes way too many hls
|
||||
# instances to be spun up for the poor github actions runner to handle
|
||||
run: cabal test wrapper-test --test-options="-j1" || cabal test wrapper-test --test-options="-j1" || cabal test wrapper-test --test-options="-j1"
|
2
.gitignore
vendored
2
.gitignore
vendored
@ -6,6 +6,8 @@ cabal.project.local
|
||||
*~
|
||||
*.lock
|
||||
|
||||
.tasty-rerun-log
|
||||
|
||||
# shake build information
|
||||
_build/
|
||||
|
||||
|
357
ChangeLog.md
357
ChangeLog.md
@ -1,26 +1,101 @@
|
||||
# Changelog for haskell-language-server
|
||||
|
||||
## 0.6.0
|
||||
|
||||
0.6.0 includes two brand new plugins!
|
||||
|
||||
* [Hlint Plugin](https://github.com/haskell/haskell-language-server/pull/166): it integrates hlint diagnostics and lets you apply suggestions to fix them.
|
||||
|
||||
![hls-hlint-demo](https://user-images.githubusercontent.com/54035/98731058-6ff38500-239d-11eb-8176-e4f69ef76fc2.gif)
|
||||
|
||||
* [Module Name Plugin](https://github.com/haskell/haskell-language-server/pull/480): it makes easier create new modules and modify them, suggesting the appropiate module name as a code lens.
|
||||
|
||||
![module-name-demo](https://user-images.githubusercontent.com/54035/98731198-a7623180-239d-11eb-8af0-73bd32b9b0b2.gif)
|
||||
|
||||
This release also includes many improvements and bug fixes for the tactic plugin (see pull requests authored by @isovector for more details).
|
||||
|
||||
We have updated two essential tools used by the ide:
|
||||
|
||||
* `implicit-hie`: [to fix a bug](https://github.com/haskell/haskell-language-server/issues/498) present when loading cabal based projects with executables containing `other-modules`
|
||||
|
||||
* `ghcide`: the ide uses [the just released version 0.5](https://github.com/haskell/ghcide/blob/master/CHANGELOG.md#050-2020-10-08) with many bug fixes and improvements, including:
|
||||
* code action to remove *all* redundant imports
|
||||
* improved support for Template Haskell
|
||||
* emit desugarer warnings
|
||||
|
||||
### Pull requests merged
|
||||
|
||||
* Fix tasty rerun
|
||||
([#570)](https://github.com/haskell/haskell-language-server/pull/570) by @jneira
|
||||
* Bump up ghcide submodule to version 0.5.0
|
||||
([#568)](https://github.com/haskell/haskell-language-server/pull/568) by @jneira
|
||||
* Refactor tactics to track hypothesis provenance
|
||||
([#557)](https://github.com/haskell/haskell-language-server/pull/557) by @isovector
|
||||
* Use bash shell to allow its idioms
|
||||
([#552)](https://github.com/haskell/haskell-language-server/pull/552) by @jneira
|
||||
* Ignore flakey tactics test
|
||||
([#546)](https://github.com/haskell/haskell-language-server/pull/546) by @isovector
|
||||
* Better scoring metric for deriving safeHead
|
||||
([#545)](https://github.com/haskell/haskell-language-server/pull/545) by @isovector
|
||||
* Discover skolems in the hypothesis, not just goal
|
||||
([#542)](https://github.com/haskell/haskell-language-server/pull/542) by @isovector
|
||||
* [retrie] Fix code action title
|
||||
([#538)](https://github.com/haskell/haskell-language-server/pull/538) by @pepeiborra
|
||||
* Tactics support for using given constraints
|
||||
([#534)](https://github.com/haskell/haskell-language-server/pull/534) by @isovector
|
||||
* Add missing tactic subpackage in default stack.yaml
|
||||
([#529)](https://github.com/haskell/haskell-language-server/pull/529) by @jneira
|
||||
* Use implicit-hie-0.1.2.0
|
||||
([#528)](https://github.com/haskell/haskell-language-server/pull/528) by @jneira
|
||||
* Wait for diagnostics in tactics tests
|
||||
([#525)](https://github.com/haskell/haskell-language-server/pull/525) by @isovector
|
||||
* Fix a bug in tactics preventing split of split
|
||||
([#520)](https://github.com/haskell/haskell-language-server/pull/520) by @isovector
|
||||
* Use infix notation for destructing and splitting infix data cons
|
||||
([#519)](https://github.com/haskell/haskell-language-server/pull/519) by @isovector
|
||||
* Retry the build three times
|
||||
([#518)](https://github.com/haskell/haskell-language-server/pull/518) by @jneira
|
||||
* Separate tactics into its own package
|
||||
([#516)](https://github.com/haskell/haskell-language-server/pull/516) by @isovector
|
||||
* Add a Troubleshooting section to the README
|
||||
([#507)](https://github.com/haskell/haskell-language-server/pull/507) by @michaelpj
|
||||
* Add GitHub Actions CI for testing
|
||||
([#504)](https://github.com/haskell/haskell-language-server/pull/504) by @bubba
|
||||
* Fix stack build for ghc-8.8.3 failing on some machines
|
||||
([#503)](https://github.com/haskell/haskell-language-server/pull/503) by @luntain
|
||||
* Expand explanation of how to configure HLS
|
||||
([#497)](https://github.com/haskell/haskell-language-server/pull/497) by @michaelpj
|
||||
* Module Name Plugin
|
||||
([#480)](https://github.com/haskell/haskell-language-server/pull/480) by @tittoassini
|
||||
* Allow hole filling to deal with recursion
|
||||
([#472)](https://github.com/haskell/haskell-language-server/pull/472) by @isovector
|
||||
* Restrict editor config to Haskell file, to avoid affecting Makefiles or other tab-based formats
|
||||
([#442)](https://github.com/haskell/haskell-language-server/pull/442) by @tittoassini
|
||||
* Hlint plugin using ghc-lib
|
||||
([#166)](https://github.com/haskell/haskell-language-server/pull/166) by @jneira
|
||||
|
||||
## 0.5.1
|
||||
|
||||
0.5.1 is a minor bug fix release, mainly fixing an issue with the eval plugin
|
||||
as well as upgrading the ormolu and stylish-haskell dependencies.
|
||||
|
||||
### Pull requests merged
|
||||
- Minimal fix for eval regression
|
||||
|
||||
* Minimal fix for eval regression
|
||||
([#488)](https://github.com/haskell/haskell-language-server/pull/488) by @pepeiborra
|
||||
- Bump stylish-haskell to 0.12.2.0
|
||||
* Bump stylish-haskell to 0.12.2.0
|
||||
([#482)](https://github.com/haskell/haskell-language-server/pull/482) by @maksbotan
|
||||
- Improve the emacs instructions a little
|
||||
* Improve the emacs instructions a little
|
||||
([#479)](https://github.com/haskell/haskell-language-server/pull/479) by @michaelpj
|
||||
- Update README: HLS is no longer in *very* early stage
|
||||
* Update README: HLS is no longer in *very* early stage
|
||||
([#475)](https://github.com/haskell/haskell-language-server/pull/475) by @Anrock
|
||||
- Tactic plugin: Excludes Dictionary arguments in GADTs in Destruct Tactic
|
||||
* Tactic plugin: Excludes Dictionary arguments in GADTs in Destruct Tactic
|
||||
([#474)](https://github.com/haskell/haskell-language-server/pull/474) by @konn
|
||||
- Update doom emacs install instructions in README
|
||||
* Update doom emacs install instructions in README
|
||||
([#470)](https://github.com/haskell/haskell-language-server/pull/470) by @iyefrat
|
||||
- Add ghc-8.10.2 to circleci
|
||||
* Add ghc-8.10.2 to circleci
|
||||
([#464)](https://github.com/haskell/haskell-language-server/pull/464) by @jneira
|
||||
- Bump ormolu to 0.1.3.0
|
||||
* Bump ormolu to 0.1.3.0
|
||||
([#422)](https://github.com/haskell/haskell-language-server/pull/422) by @AlistairB
|
||||
|
||||
## 0.5.0
|
||||
@ -47,67 +122,67 @@ There's also plenty of bug fixes, improvements and updates to the underlying too
|
||||
|
||||
If you're eager to try all this out, haskell-language-server is now also installable via [ghcup](https://www.haskell.org/ghcup/):
|
||||
|
||||
```
|
||||
```shell
|
||||
$ ghcup install hls
|
||||
```
|
||||
|
||||
|
||||
### Pull requests merged
|
||||
- Update GHC version 8.12 to 9.0 in README
|
||||
|
||||
* Update GHC version 8.12 to 9.0 in README
|
||||
([#460)](https://github.com/haskell/haskell-language-server/pull/460) by @maralorn
|
||||
- Update Fourmolu to 0.2
|
||||
* Update Fourmolu to 0.2
|
||||
([#455)](https://github.com/haskell/haskell-language-server/pull/455) by @georgefst
|
||||
- Generate .gz tars of all the binaries for macOS and Linux in GitHub Actions
|
||||
* Generate .gz tars of all the binaries for macOS and Linux in GitHub Actions
|
||||
([#454)](https://github.com/haskell/haskell-language-server/pull/454) by @bubba
|
||||
- install: create hls hardlinks instead of copies except on Windows
|
||||
* install: create hls hardlinks instead of copies except on Windows
|
||||
([#451)](https://github.com/haskell/haskell-language-server/pull/451) by @juhp
|
||||
- wrapper: cd to --cwd earlier
|
||||
* wrapper: cd to --cwd earlier
|
||||
([#448)](https://github.com/haskell/haskell-language-server/pull/448) by @ocharles
|
||||
- Update README.md
|
||||
* Update README.md
|
||||
([#446)](https://github.com/haskell/haskell-language-server/pull/446) by @moodmosaic
|
||||
- Upate Emacs setup notes
|
||||
* Upate Emacs setup notes
|
||||
([#440)](https://github.com/haskell/haskell-language-server/pull/440) by @gdevanla
|
||||
- Use ghcide master and prepare hls-plugin-api-0.4.1.0
|
||||
* Use ghcide master and prepare hls-plugin-api-0.4.1.0
|
||||
([#439)](https://github.com/haskell/haskell-language-server/pull/439) by @jneira
|
||||
- Add a code action to make all imports explicit
|
||||
* Add a code action to make all imports explicit
|
||||
([#436)](https://github.com/haskell/haskell-language-server/pull/436) by @pepeiborra
|
||||
- Add docs on how to choose a formatter
|
||||
* Add docs on how to choose a formatter
|
||||
([#432)](https://github.com/haskell/haskell-language-server/pull/432) by @googleson78
|
||||
- Implement 'Attempt to fill hole' code action
|
||||
* Implement 'Attempt to fill hole' code action
|
||||
([#431)](https://github.com/haskell/haskell-language-server/pull/431) by @TOTBWF
|
||||
- Clarify that eval is a lens
|
||||
* Clarify that eval is a lens
|
||||
([#428)](https://github.com/haskell/haskell-language-server/pull/428) by @Anrock
|
||||
- Use implicit-hie-cradle-0.2.0.1
|
||||
* Use implicit-hie-cradle-0.2.0.1
|
||||
([#427)](https://github.com/haskell/haskell-language-server/pull/427) by @jneira
|
||||
- [retrie] Fix uris in workspace edit
|
||||
* [retrie] Fix uris in workspace edit
|
||||
([#424)](https://github.com/haskell/haskell-language-server/pull/424) by @pepeiborra
|
||||
- Separate paragraphs
|
||||
* Separate paragraphs
|
||||
([#423)](https://github.com/haskell/haskell-language-server/pull/423) by @jneira
|
||||
- Include .editorconfig in the contributing section
|
||||
* Include .editorconfig in the contributing section
|
||||
([#420)](https://github.com/haskell/haskell-language-server/pull/420) by @jneira
|
||||
- Mention the copy of executables wit ghc version
|
||||
* Mention the copy of executables wit ghc version
|
||||
([#419)](https://github.com/haskell/haskell-language-server/pull/419) by @jneira
|
||||
- Eval plugin: proper multilined results handling and command-name abbreviations
|
||||
* Eval plugin: proper multilined results handling and command-name abbreviations
|
||||
([#413)](https://github.com/haskell/haskell-language-server/pull/413) by @konn
|
||||
- Retrie - calculate imports in the command handler
|
||||
* Retrie - calculate imports in the command handler
|
||||
([#408)](https://github.com/haskell/haskell-language-server/pull/408) by @pepeiborra
|
||||
- Progress reporting for Eval plugin
|
||||
* Progress reporting for Eval plugin
|
||||
([#398)](https://github.com/haskell/haskell-language-server/pull/398) by @pepeiborra
|
||||
- bump ghcide submodule
|
||||
* bump ghcide submodule
|
||||
([#396)](https://github.com/haskell/haskell-language-server/pull/396) by @wz1000
|
||||
- Fix cradles
|
||||
* Fix cradles
|
||||
([#393)](https://github.com/haskell/haskell-language-server/pull/393) by @pepeiborra
|
||||
- Case splitting and lambda introduction
|
||||
* Case splitting and lambda introduction
|
||||
([#391)](https://github.com/haskell/haskell-language-server/pull/391) by @isovector
|
||||
- Use stale data in explicit imports lens
|
||||
* Use stale data in explicit imports lens
|
||||
([#383)](https://github.com/haskell/haskell-language-server/pull/383) by @pepeiborra
|
||||
- Create hls-plugin-api and move plugins to exe
|
||||
* Create hls-plugin-api and move plugins to exe
|
||||
([#379)](https://github.com/haskell/haskell-language-server/pull/379) by @jneira
|
||||
- Rebase on ghcide HEAD
|
||||
* Rebase on ghcide HEAD
|
||||
([#378)](https://github.com/haskell/haskell-language-server/pull/378) by @pepeiborra
|
||||
- README clarify how exactly to use code evaluation
|
||||
* README clarify how exactly to use code evaluation
|
||||
([#377)](https://github.com/haskell/haskell-language-server/pull/377) by @DunetsNM
|
||||
- Revise README.md
|
||||
* Revise README.md
|
||||
([#374)](https://github.com/haskell/haskell-language-server/pull/374) by @gihyeonsung
|
||||
|
||||
## 0.4.0
|
||||
@ -144,7 +219,7 @@ foo = show
|
||||
|
||||
There is now also support for GHC 8.10.2, and a new `haskell-language-server --probe-tools` command to help debug what version of each tool HLS is using.
|
||||
|
||||
```
|
||||
```shell
|
||||
$ haskell-language-server --probe-tools
|
||||
haskell-language-server version: 0.3.0.0 (GHC: 8.10.1) (PATH: /Users/luke/.cabal/store/ghc-8.10.1/hskll-lngg-srvr-0.3.0.0-7c6d48c3/bin/haskell-language-server)
|
||||
Tool versions found on the $PATH
|
||||
@ -155,57 +230,57 @@ ghc: 8.10.2
|
||||
|
||||
### Pull requests merged
|
||||
|
||||
- Bring over https://github.com/pepeiborra/hls-tutorial
|
||||
* Bring over https://github.com/pepeiborra/hls-tutorial
|
||||
([#372](https://github.com/haskell/haskell-language-server/pull/372) by @bubba)
|
||||
- Update the ghcide upstream to be in haskell/ghcide
|
||||
* Update the ghcide upstream to be in haskell/ghcide
|
||||
([#370](https://github.com/haskell/haskell-language-server/pull/370) by @alanz)
|
||||
- Add ISSUE_TEMPLATE for github
|
||||
* Add ISSUE_TEMPLATE for github
|
||||
([#305](https://github.com/haskell/haskell-language-server/pull/305) by @fendor)
|
||||
- Add use-package to the list of emacs packages
|
||||
* Add use-package to the list of emacs packages
|
||||
([#343](https://github.com/haskell/haskell-language-server/pull/343) by @rgleichman)
|
||||
- Implements `:type [+v/+d]` in Eval Plugin
|
||||
* Implements `:type [+v/+d]` in Eval Plugin
|
||||
([#361](https://github.com/haskell/haskell-language-server/pull/361) by @konn)
|
||||
- Bump bounds of hie-bios to 0.7.0
|
||||
* Bump bounds of hie-bios to 0.7.0
|
||||
([#357](https://github.com/haskell/haskell-language-server/pull/357) by @maralorn)
|
||||
- Fix ImportLens plugin to work with GHC 8.10
|
||||
* Fix ImportLens plugin to work with GHC 8.10
|
||||
([#356](https://github.com/haskell/haskell-language-server/pull/356) by @Ailrun)
|
||||
- Add single file rewrites and ignore unknown files
|
||||
* Add single file rewrites and ignore unknown files
|
||||
([#321](https://github.com/haskell/haskell-language-server/pull/321) by @pepeiborra)
|
||||
- Do not suggest explicit import lists for qualified imports
|
||||
* Do not suggest explicit import lists for qualified imports
|
||||
([#354](https://github.com/haskell/haskell-language-server/pull/354) by @expipiplus1)
|
||||
- Explicit imports lens (as seen on Twitter)
|
||||
* Explicit imports lens (as seen on Twitter)
|
||||
([#310](https://github.com/haskell/haskell-language-server/pull/310) by @pepeiborra)
|
||||
- Adds `:kind` and `:kind!` commands to Eval Plugin
|
||||
* Adds `:kind` and `:kind!` commands to Eval Plugin
|
||||
([#345](https://github.com/haskell/haskell-language-server/pull/345) by @konn)
|
||||
- tech(nix): update niv and remove allowbroken
|
||||
* tech(nix): update niv and remove allowbroken
|
||||
([#350](https://github.com/haskell/haskell-language-server/pull/350) by @willbush)
|
||||
- Update VS Code Haskell URL/repo
|
||||
* Update VS Code Haskell URL/repo
|
||||
([#338](https://github.com/haskell/haskell-language-server/pull/338) by @Sir4ur0n)
|
||||
- doc(hack): Add explanation to hack and test HLS
|
||||
* doc(hack): Add explanation to hack and test HLS
|
||||
([#329](https://github.com/haskell/haskell-language-server/pull/329) by @Sir4ur0n)
|
||||
- Apply the module pragmas for evaluation
|
||||
* Apply the module pragmas for evaluation
|
||||
([#322](https://github.com/haskell/haskell-language-server/pull/322) by @pepeiborra)
|
||||
- Copy working stack-8.6.5.yaml to stack.yaml
|
||||
* Copy working stack-8.6.5.yaml to stack.yaml
|
||||
([#332](https://github.com/haskell/haskell-language-server/pull/332) by @jneira)
|
||||
- tech(nix): Allow broken as retrie is marked as broken
|
||||
* tech(nix): Allow broken as retrie is marked as broken
|
||||
([#331](https://github.com/haskell/haskell-language-server/pull/331) by @Sir4ur0n)
|
||||
- feat(git): Add install/hie.yaml to gitignore
|
||||
* feat(git): Add install/hie.yaml to gitignore
|
||||
([#328](https://github.com/haskell/haskell-language-server/pull/328) by @Sir4ur0n)
|
||||
- Replace wrong occurrences of "engine" by "server"
|
||||
* Replace wrong occurrences of "engine" by "server"
|
||||
([#319](https://github.com/haskell/haskell-language-server/pull/319) by @tchoutri)
|
||||
- Simplify coc.nvim instructions
|
||||
* Simplify coc.nvim instructions
|
||||
([#315](https://github.com/haskell/haskell-language-server/pull/315) by @oblitum)
|
||||
- Coc config file requires a {} nesting everything
|
||||
* Coc config file requires a {} nesting everything
|
||||
([#317](https://github.com/haskell/haskell-language-server/pull/317) by @hyiltiz)
|
||||
- Restrict opentelemetry version for stack builds
|
||||
* Restrict opentelemetry version for stack builds
|
||||
([#312](https://github.com/haskell/haskell-language-server/pull/312) by @jneira)
|
||||
- Add support for ghc-8.10.2
|
||||
* Add support for ghc-8.10.2
|
||||
([#308](https://github.com/haskell/haskell-language-server/pull/308) by @jneira)
|
||||
- Return nothing if tool is not on the PATH
|
||||
* Return nothing if tool is not on the PATH
|
||||
([#309](https://github.com/haskell/haskell-language-server/pull/309) by @fendor)
|
||||
- Probe tools cli
|
||||
* Probe tools cli
|
||||
([#306](https://github.com/haskell/haskell-language-server/pull/306) by @fendor)
|
||||
- Add fourmolu plugin (attempt 2) and add Brittany for ghc-8.10.1
|
||||
* Add fourmolu plugin (attempt 2) and add Brittany for ghc-8.10.1
|
||||
([#264](https://github.com/haskell/haskell-language-server/pull/264) by @georgefst)
|
||||
|
||||
## 0.3.0
|
||||
@ -231,41 +306,41 @@ The Brittany formatter is now also available on GHC 8.10.1.
|
||||
|
||||
### Pull requests merged
|
||||
|
||||
- Fix haddock parse error in install.hs
|
||||
* Fix haddock parse error in install.hs
|
||||
([#255](https://github.com/haskell/haskell-language-server/pull/255) by @georgefst)
|
||||
- Ormolu flags
|
||||
* Ormolu flags
|
||||
([#246](https://github.com/haskell/haskell-language-server/pull/246) by @pepeiborra)
|
||||
- Ormolu fix
|
||||
* Ormolu fix
|
||||
([#257](https://github.com/haskell/haskell-language-server/pull/257) by @sureyeaah)
|
||||
- Remove redundant CircleCI steps
|
||||
* Remove redundant CircleCI steps
|
||||
([#259](https://github.com/haskell/haskell-language-server/pull/259) by @bubba)
|
||||
- Slow down Tasty by limiting it to -j1
|
||||
* Slow down Tasty by limiting it to -j1
|
||||
([#261](https://github.com/haskell/haskell-language-server/pull/261) by @bubba)
|
||||
- Remove hspec-expectations
|
||||
* Remove hspec-expectations
|
||||
([#260](https://github.com/haskell/haskell-language-server/pull/260) by @bubba)
|
||||
- Remove a redundant caching step
|
||||
* Remove a redundant caching step
|
||||
([#262](https://github.com/haskell/haskell-language-server/pull/262) by @Ailrun)
|
||||
- add hie.yaml to coc configuration
|
||||
* add hie.yaml to coc configuration
|
||||
([#267](https://github.com/haskell/haskell-language-server/pull/267) by @sureyeaah)
|
||||
- Initial Retrie plugin
|
||||
* Initial Retrie plugin
|
||||
([#266](https://github.com/haskell/haskell-language-server/pull/266) by @pepeiborra)
|
||||
- Add exe extension to win executables
|
||||
* Add exe extension to win executables
|
||||
([#284](https://github.com/haskell/haskell-language-server/pull/284) by @jneira)
|
||||
- Use wz1000/hls-3 ghcide branch
|
||||
* Use wz1000/hls-3 ghcide branch
|
||||
([#275](https://github.com/haskell/haskell-language-server/pull/275) by @alanz)
|
||||
- Fix rename capability being declared
|
||||
* Fix rename capability being declared
|
||||
([#285](https://github.com/haskell/haskell-language-server/pull/285) by @bubba)
|
||||
- Add CI job for 8.8.4
|
||||
* Add CI job for 8.8.4
|
||||
([#287](https://github.com/haskell/haskell-language-server/pull/287) by @bubba)
|
||||
- Make the AGPL flag manual in cabal
|
||||
* Make the AGPL flag manual in cabal
|
||||
([#250](https://github.com/haskell/haskell-language-server/pull/250) by @fendor)
|
||||
- Bring in doc URL fix for Windows
|
||||
* Bring in doc URL fix for Windows
|
||||
([#289](https://github.com/haskell/haskell-language-server/pull/289) by @bubba)
|
||||
- Bring in fix for libm on Linux static binaries
|
||||
* Bring in fix for libm on Linux static binaries
|
||||
([#293](https://github.com/haskell/haskell-language-server/pull/293) by @bubba)
|
||||
- Add fourmolu plugin (attempt 2) and add Brittany for ghc-8.10.1
|
||||
* Add fourmolu plugin (attempt 2) and add Brittany for ghc-8.10.1
|
||||
([#264](https://github.com/haskell/haskell-language-server/pull/264) by @georgefst)
|
||||
- Trying new hls-3 branch
|
||||
* Trying new hls-3 branch
|
||||
([#300](https://github.com/haskell/haskell-language-server/pull/300) by @alanz)
|
||||
|
||||
## 0.2.2
|
||||
@ -295,25 +370,25 @@ to
|
||||
|
||||
### Pull requests merged
|
||||
|
||||
- Mention docs on hover feature in README
|
||||
* Mention docs on hover feature in README
|
||||
([#209](https://github.com/haskell/haskell-language-server/pull/209) by @georgefst)
|
||||
- Add static binaries for ghc-8.8.4
|
||||
* Add static binaries for ghc-8.8.4
|
||||
([#224](https://github.com/haskell/haskell-language-server/pull/224) by @bubba)
|
||||
- Rename the configuration section from languageServerHaskell => haskell
|
||||
* Rename the configuration section from languageServerHaskell => haskell
|
||||
([#227](https://github.com/haskell/haskell-language-server/pull/227) by @bubba)
|
||||
- Use -haddock for cabal and stack
|
||||
* Use -haddock for cabal and stack
|
||||
([#214](https://github.com/haskell/haskell-language-server/pull/214) by @jneira)
|
||||
- slightly better shell.nix for local development
|
||||
* slightly better shell.nix for local development
|
||||
([#235](https://github.com/haskell/haskell-language-server/pull/235) by @pepeiborra)
|
||||
- Shell nix further steps
|
||||
* Shell nix further steps
|
||||
([#240](https://github.com/haskell/haskell-language-server/pull/240) by @pepeiborra)
|
||||
- Add numeric-version option for wrapper and server
|
||||
* Add numeric-version option for wrapper and server
|
||||
([#241](https://github.com/haskell/haskell-language-server/pull/241) by @fendor)
|
||||
- Accept the legacy "languageServerHaskell" config name
|
||||
* Accept the legacy "languageServerHaskell" config name
|
||||
([#243](https://github.com/haskell/haskell-language-server/pull/243) by @bubba)
|
||||
- Fix for Eval plugin: Error from tests not reported
|
||||
* Fix for Eval plugin: Error from tests not reported
|
||||
([#244](https://github.com/haskell/haskell-language-server/pull/244) by @tittoassini)
|
||||
- Rename binaries before uploading
|
||||
* Rename binaries before uploading
|
||||
([#248](https://github.com/haskell/haskell-language-server/pull/248) by @bubba)
|
||||
|
||||
## 0.2.1
|
||||
@ -340,144 +415,144 @@ you find any issues with this, please let us know!
|
||||
|
||||
### Pull requests merged
|
||||
|
||||
- Bump ormolu to 0.1.2.0
|
||||
* Bump ormolu to 0.1.2.0
|
||||
([#189](https://github.com/haskell/haskell-language-server/pull/189) by @AlistairB)
|
||||
- Remove dependency on Cabal
|
||||
* Remove dependency on Cabal
|
||||
([#195](https://github.com/haskell/haskell-language-server/pull/195) by @bubba)
|
||||
- Fix extraneous extra-dep in stack-8.6.4.yaml
|
||||
* Fix extraneous extra-dep in stack-8.6.4.yaml
|
||||
([#199](https://github.com/haskell/haskell-language-server/pull/199) by @bubba)
|
||||
- Fix install script stack targets
|
||||
* Fix install script stack targets
|
||||
([#203](https://github.com/haskell/haskell-language-server/pull/203) by @jneira)
|
||||
- Add support for ghc-8.8.4
|
||||
* Add support for ghc-8.8.4
|
||||
([#206](https://github.com/haskell/haskell-language-server/pull/206) by @jneira)
|
||||
- Simple Eval plugin
|
||||
* Simple Eval plugin
|
||||
([#191](https://github.com/haskell/haskell-language-server/pull/191) by @pepeiborra)
|
||||
- Distributable binaries
|
||||
* Distributable binaries
|
||||
([#165](https://github.com/haskell/haskell-language-server/pull/165) by @bubba)
|
||||
|
||||
## 0.2
|
||||
|
||||
- Use cabal-plan from Hackage
|
||||
* Use cabal-plan from Hackage
|
||||
([#185](https://github.com/haskell/haskell-language-server/pull/185) by @georgefst)
|
||||
|
||||
- Bump ghcide to wz1000 hls-2 branch
|
||||
* Bump ghcide to wz1000 hls-2 branch
|
||||
([#184](https://github.com/haskell/haskell-language-server/pull/184) by @alanz)
|
||||
|
||||
- doc(preprocessor): Document the preprocessor limitation
|
||||
* doc(preprocessor): Document the preprocessor limitation
|
||||
([#177](https://github.com/haskell/haskell-language-server/pull/177) by @Sir4ur0n)
|
||||
|
||||
- Use shell.nix from Haskell-IDE-Engine
|
||||
* Use shell.nix from Haskell-IDE-Engine
|
||||
([#169](https://github.com/haskell/haskell-language-server/pull/169) by @fendor)
|
||||
|
||||
- Remove last occurrences of shake.yaml
|
||||
* Remove last occurrences of shake.yaml
|
||||
([#163](https://github.com/haskell/haskell-language-server/pull/163) by @fendor)
|
||||
|
||||
- Use an unique install/stack.yaml
|
||||
* Use an unique install/stack.yaml
|
||||
([#154](https://github.com/haskell/haskell-language-server/pull/154) by @jneira)
|
||||
|
||||
- Introduce golden testing
|
||||
* Introduce golden testing
|
||||
([#152](https://github.com/haskell/haskell-language-server/pull/152) by @Ailrun)
|
||||
|
||||
- Revert "Use bullet as separator instead of HR"
|
||||
* Revert "Use bullet as separator instead of HR"
|
||||
([#150](https://github.com/haskell/haskell-language-server/pull/150) by @alanz)
|
||||
|
||||
- feat(hie-bios): Multi-cradle, ignore directories
|
||||
* feat(hie-bios): Multi-cradle, ignore directories
|
||||
([#147](https://github.com/haskell/haskell-language-server/pull/147) by @Sir4ur0n)
|
||||
|
||||
- [Plugin] stylish-haskell formatter
|
||||
* [Plugin] stylish-haskell formatter
|
||||
([#146](https://github.com/haskell/haskell-language-server/pull/146) by @Ailrun)
|
||||
|
||||
- Separate ghcide tests and disable them for now
|
||||
* Separate ghcide tests and disable them for now
|
||||
([#137](https://github.com/haskell/haskell-language-server/pull/137) by @jneira)
|
||||
|
||||
- Convert private lib in common stanza
|
||||
* Convert private lib in common stanza
|
||||
([#136](https://github.com/haskell/haskell-language-server/pull/136) by @jneira)
|
||||
|
||||
- Add zlibc to readme
|
||||
* Add zlibc to readme
|
||||
([#134](https://github.com/haskell/haskell-language-server/pull/134) by @Sir4ur0n)
|
||||
|
||||
- Complete editor integrations
|
||||
* Complete editor integrations
|
||||
([#132](https://github.com/haskell/haskell-language-server/pull/132) by @jneira)
|
||||
|
||||
- Remove inexistent component from hie.yaml.stack
|
||||
* Remove inexistent component from hie.yaml.stack
|
||||
([#131](https://github.com/haskell/haskell-language-server/pull/131) by @jneira)
|
||||
|
||||
- Bump to new mpickering/ghcide
|
||||
* Bump to new mpickering/ghcide
|
||||
([#130](https://github.com/haskell/haskell-language-server/pull/130) by @alanz)
|
||||
|
||||
- Update ghc-lib-parser version
|
||||
* Update ghc-lib-parser version
|
||||
([#129](https://github.com/haskell/haskell-language-server/pull/129) by @jneira)
|
||||
|
||||
- Remove redundant import
|
||||
* Remove redundant import
|
||||
([#128](https://github.com/haskell/haskell-language-server/pull/128) by @bubba)
|
||||
|
||||
- Default the number of Shake threads to 0 (automatic)
|
||||
* Default the number of Shake threads to 0 (automatic)
|
||||
([#127](https://github.com/haskell/haskell-language-server/pull/127) by @bubba)
|
||||
|
||||
- Added kakoune integration instructions
|
||||
* Added kakoune integration instructions
|
||||
([#125](https://github.com/haskell/haskell-language-server/pull/125) by @414owen)
|
||||
|
||||
- Fix install script dev target
|
||||
* Fix install script dev target
|
||||
([#124](https://github.com/haskell/haskell-language-server/pull/124) by @jneira)
|
||||
|
||||
- Add plugin support for Rename providers
|
||||
* Add plugin support for Rename providers
|
||||
([#123](https://github.com/haskell/haskell-language-server/pull/123) by @pepeiborra)
|
||||
|
||||
- Add jobs for stack and cabal using ghc-8.10.1
|
||||
* Add jobs for stack and cabal using ghc-8.10.1
|
||||
([#120](https://github.com/haskell/haskell-language-server/pull/120) by @jneira)
|
||||
|
||||
- Add lower bound to tasty-ant-xml
|
||||
* Add lower bound to tasty-ant-xml
|
||||
([#119](https://github.com/haskell/haskell-language-server/pull/119) by @jneira)
|
||||
|
||||
- Fix build using brittany revision
|
||||
* Fix build using brittany revision
|
||||
([#117](https://github.com/haskell/haskell-language-server/pull/117) by @jneira)
|
||||
|
||||
- Use floskell released version 0.10.3
|
||||
* Use floskell released version 0.10.3
|
||||
([#116](https://github.com/haskell/haskell-language-server/pull/116) by @jneira)
|
||||
|
||||
- Add emacs/doom-emacs integration sub-section
|
||||
* Add emacs/doom-emacs integration sub-section
|
||||
([#115](https://github.com/haskell/haskell-language-server/pull/115) by @yuanw)
|
||||
|
||||
- Port hie README partially
|
||||
* Port hie README partially
|
||||
([#112](https://github.com/haskell/haskell-language-server/pull/112) by @jneira)
|
||||
|
||||
- Use cabal-helper-1.1, add stack-8.10.1.yaml and unify cabal.project's
|
||||
* Use cabal-helper-1.1, add stack-8.10.1.yaml and unify cabal.project's
|
||||
([#108](https://github.com/haskell/haskell-language-server/pull/108) by @jneira)
|
||||
|
||||
- [#87] Fix completion via ghcide's `getCompletionsLSP`
|
||||
* [#87] Fix completion via ghcide's `getCompletionsLSP`
|
||||
([#107](https://github.com/haskell/haskell-language-server/pull/107) by @korayal)
|
||||
|
||||
- Create specific project file for ghc-8.10.
|
||||
* Create specific project file for ghc-8.10.
|
||||
([#106](https://github.com/haskell/haskell-language-server/pull/106) by @jneira)
|
||||
|
||||
- Issue 5 - Move HIE Tests and convert to Tasty
|
||||
* Issue 5 - Move HIE Tests and convert to Tasty
|
||||
([#105](https://github.com/haskell/haskell-language-server/pull/105) by @jeffwindsor)
|
||||
|
||||
- Hls update latest hie bios
|
||||
* Hls update latest hie bios
|
||||
([#100](https://github.com/haskell/haskell-language-server/pull/100) by @fendor)
|
||||
|
||||
- Update extra-deps to use latest fork version of shake
|
||||
* Update extra-deps to use latest fork version of shake
|
||||
([#98](https://github.com/haskell/haskell-language-server/pull/98) by @fendor)
|
||||
|
||||
- Activate typechecking in non-lsp mode
|
||||
* Activate typechecking in non-lsp mode
|
||||
([#95](https://github.com/haskell/haskell-language-server/pull/95) by @jneira)
|
||||
|
||||
- Fix haddock parsing errors
|
||||
* Fix haddock parsing errors
|
||||
([#92](https://github.com/haskell/haskell-language-server/pull/92) by @jneira)
|
||||
|
||||
- Update for haskell-lsp 0.22
|
||||
* Update for haskell-lsp 0.22
|
||||
([#89](https://github.com/haskell/haskell-language-server/pull/89) by @alanz)
|
||||
|
||||
- Get building with ghc-8.10
|
||||
* Get building with ghc-8.10
|
||||
([#83](https://github.com/haskell/haskell-language-server/pull/83) by @bubba)
|
||||
|
||||
## 0.1
|
||||
|
||||
### In this version
|
||||
|
||||
- cabal to 2020-05-02T10:11:15Z
|
||||
- stack-8.8.3 to lts-15.10
|
||||
- stack to nightly-2020-05-01
|
||||
* cabal to 2020-05-02T10:11:15Z
|
||||
* stack-8.8.3 to lts-15.10
|
||||
* stack to nightly-2020-05-01
|
||||
|
||||
### Changes
|
||||
|
||||
|
44
README.md
44
README.md
@ -38,6 +38,7 @@ background](https://neilmitchell.blogspot.com/2020/01/one-haskell-ide-to-rule-th
|
||||
- [Kakoune](#using-haskell-language-server-with-kakoune)
|
||||
- [Known limitations](#known-limitations)
|
||||
- [Preprocessor](#preprocessor)
|
||||
- [Troubleshooting](#troubleshooting)
|
||||
- [Contributing](#contributing)
|
||||
- [Building haskell-language-server](#building-haskell-language-server)
|
||||
- [Using Cabal](#using-cabal)
|
||||
@ -291,7 +292,7 @@ Here is a list of the additional settings currently supported by `haskell-langua
|
||||
- Diagnostics on change (`haskell.diagnosticsOnChange`, default true): (currently unused)
|
||||
- Completion snippets (`haskell.completionSnippetsOn`, default true): whether to support completion snippets (currently unused until we have snippets to provide)
|
||||
- Liquid Haskell (`haskell.liquidOn`, default false): whether to enable Liquid Haskell support (currently unused until the Liquid Haskell support is functional again)
|
||||
- Hlint (`haskell.hlintOn`, default true): whether to enable Hlint support (currently unused until the Hlint support is functional again)
|
||||
- Hlint (`haskell.hlintOn`, default true): whether to enable Hlint support
|
||||
|
||||
Settings like this are typically provided by the language-specific LSP client support for your editor, for example in Emacs by `lsp-haskell`.
|
||||
|
||||
@ -561,7 +562,7 @@ are included below.
|
||||
Make sure to check the READMEs of each of these packages, which explain how to configure the
|
||||
various parts of the Emacs integration.
|
||||
In particular, `lsp-haskell` provides customization options for the `haskell-language-server`-specific parts,
|
||||
such as the path to the server binary.
|
||||
such as the path to the server executable.
|
||||
|
||||
#### Using haskell-language-server with [doom-emacs](https://github.com/hlissner/doom-emacs/tree/develop/modules/lang/haskell#module-flags)
|
||||
|
||||
@ -619,6 +620,45 @@ Example with `tasty-discover`:
|
||||
```
|
||||
This returns an error in HLS if 'tasty-discover' is not in the path: `could not execute: tasty-discover`.
|
||||
|
||||
## Troubleshooting
|
||||
|
||||
### Common issues
|
||||
|
||||
#### Difficulties with Stack and `Paths_` modules
|
||||
|
||||
These are known to be somewhat buggy at the moment: https://github.com/haskell/haskell-language-server/issues/478.
|
||||
This issue should be fixed in Stack versions >= 2.5.
|
||||
|
||||
### Troubleshooting the server
|
||||
|
||||
#### Diagnostic mode
|
||||
|
||||
The `haskell-language-server` executable can be run in diagnostic mode, where it will just try to load modules from your project, printing all of its output to stdout.
|
||||
This makes it much easier to see what's going on and to diagnose build-related problems.
|
||||
|
||||
To do this, simply run the executable directly from your shell in the project root.
|
||||
You can either run it without an argument, in which case it will load random modules, or with a path, in which case it will load modules in that file or directory.
|
||||
|
||||
#### Examining the log
|
||||
|
||||
Most clients will launch `haskell-language-server` with `--logfile` to make it write a log file.
|
||||
Please consult the documentation for your client to find out where this is (or how to set it).
|
||||
|
||||
The log will contain all the messages that are sent to the server and its responses.
|
||||
This is helpful for low-level debugging: if you expect a certain action to happen, you can look in the log to see if the corresponding messages are
|
||||
sent, or if there are any errors.
|
||||
|
||||
To get a more verbose, also pass `--debug` to the executable.
|
||||
|
||||
### Troubleshooting the client
|
||||
|
||||
Many clients provide diagnostic information about a LSP session.
|
||||
In particular, look for a way to get the status of the server, the server stderr, or a log of the messages that the client has sent to the server.
|
||||
For example, `lsp-mode` provides all of these (see its [troubleshooting page](https://emacs-lsp.github.io/lsp-mode/page/troubleshooting/) for details).
|
||||
|
||||
The most common client-related problem is the client simply not finding the server executable, so make sure that you have the right `PATH` and you have configured
|
||||
it to look for the right executable.
|
||||
|
||||
## Contributing
|
||||
|
||||
:heart: The Haskell tooling dream is near, we need your help! :heart:
|
||||
|
@ -1,7 +1,10 @@
|
||||
packages:
|
||||
./
|
||||
ghcide
|
||||
hls-plugin-api
|
||||
./ghcide/hie-compat
|
||||
./ghcide
|
||||
./hls-plugin-api
|
||||
./plugins/tactics
|
||||
./plugins/hls-hlint-plugin
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
@ -20,6 +23,11 @@ package ghcide
|
||||
|
||||
write-ghc-environment-files: never
|
||||
|
||||
index-state: 2020-10-08T12:51:21Z
|
||||
index-state: 2020-11-12T03:53:09Z
|
||||
|
||||
allow-newer: data-tree-print:base
|
||||
|
||||
-- To ensure the build get the version with the fix for #498
|
||||
-- Remove when the constraint is included upstream
|
||||
constraints: implicit-hie >= 0.1.2.3
|
||||
constraints: implicit-hie-cradle >= 0.3.0.0
|
||||
|
@ -11,6 +11,7 @@ import Ide.Main (defaultMain)
|
||||
import Ide.Types (IdePlugins)
|
||||
|
||||
-- haskell-language-server plugins
|
||||
|
||||
import Ide.Plugin.Eval as Eval
|
||||
import Ide.Plugin.Example as Example
|
||||
import Ide.Plugin.Example2 as Example2
|
||||
@ -22,6 +23,7 @@ import Ide.Plugin.Ormolu as Ormolu
|
||||
import Ide.Plugin.Retrie as Retrie
|
||||
import Ide.Plugin.StylishHaskell as StylishHaskell
|
||||
import Ide.Plugin.Tactic as Tactic
|
||||
import Ide.Plugin.Hlint as Hlint
|
||||
#if AGPL
|
||||
import Ide.Plugin.Brittany as Brittany
|
||||
#endif
|
||||
@ -60,6 +62,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
|
||||
, Eval.descriptor "eval"
|
||||
, ImportLens.descriptor "importLens"
|
||||
, ModuleName.descriptor "moduleName"
|
||||
, Hlint.descriptor "hlint"
|
||||
]
|
||||
examplePlugins =
|
||||
[Example.descriptor "eg"
|
||||
|
2
ghcide
2
ghcide
@ -1 +1 @@
|
||||
Subproject commit c1678223bbe9ec73628888ef466e0e471258040c
|
||||
Subproject commit 9b8aaf9b06846571cc0b5d46680e686e4f9153a3
|
@ -1,7 +1,7 @@
|
||||
cabal-version: 2.2
|
||||
category: Development
|
||||
name: haskell-language-server
|
||||
version: 0.5.1.0
|
||||
version: 0.6.0.0
|
||||
synopsis: LSP server for GHC
|
||||
description:
|
||||
Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>
|
||||
@ -59,11 +59,11 @@ library
|
||||
, containers
|
||||
, data-default
|
||||
, ghc
|
||||
, ghcide
|
||||
, ghcide >=0.5
|
||||
, gitrev
|
||||
, haskell-lsp ^>=0.22
|
||||
, hie-bios >=0.6.1 && <0.8
|
||||
, hls-plugin-api
|
||||
, hls-plugin-api >=0.5
|
||||
, hslogger
|
||||
, optparse-applicative
|
||||
, optparse-simple
|
||||
@ -77,10 +77,11 @@ library
|
||||
|
||||
default-language: Haskell2010
|
||||
|
||||
|
||||
executable haskell-language-server
|
||||
import: agpl, common-deps
|
||||
main-is: Main.hs
|
||||
hs-source-dirs: exe plugins/default/src plugins/tactics/src
|
||||
hs-source-dirs: exe plugins/default/src
|
||||
other-modules:
|
||||
Ide.Plugin.Eval
|
||||
Ide.Plugin.Example
|
||||
@ -93,19 +94,6 @@ executable haskell-language-server
|
||||
Ide.Plugin.Pragmas
|
||||
Ide.Plugin.Retrie
|
||||
Ide.Plugin.StylishHaskell
|
||||
Ide.Plugin.Tactic
|
||||
Ide.Plugin.Tactic.CodeGen
|
||||
Ide.Plugin.Tactic.Context
|
||||
Ide.Plugin.Tactic.Debug
|
||||
Ide.Plugin.Tactic.GHC
|
||||
Ide.Plugin.Tactic.Judgements
|
||||
Ide.Plugin.Tactic.Machinery
|
||||
Ide.Plugin.Tactic.Naming
|
||||
Ide.Plugin.Tactic.Range
|
||||
Ide.Plugin.Tactic.Tactics
|
||||
Ide.Plugin.Tactic.Types
|
||||
Ide.Plugin.Tactic.TestTypes
|
||||
Ide.TreeTransform
|
||||
|
||||
ghc-options:
|
||||
-threaded -Wall -Wno-name-shadowing -Wredundant-constraints
|
||||
@ -128,11 +116,13 @@ executable haskell-language-server
|
||||
, fourmolu ^>=0.2
|
||||
, ghc
|
||||
, ghc-boot-th
|
||||
, ghcide >=0.1
|
||||
, ghcide
|
||||
, hashable
|
||||
, haskell-language-server
|
||||
, haskell-lsp ^>=0.22
|
||||
, hls-hlint-plugin
|
||||
, hls-plugin-api
|
||||
, hls-tactics-plugin
|
||||
, lens
|
||||
, ormolu ^>=0.1.2
|
||||
, regex-tdfa
|
||||
@ -151,14 +141,9 @@ executable haskell-language-server
|
||||
, stylish-haskell ^>=0.12
|
||||
, temporary
|
||||
, text
|
||||
, syb
|
||||
, time
|
||||
, transformers
|
||||
, unordered-containers
|
||||
, ghc-source-gen
|
||||
, refinery ^>=0.2
|
||||
, ghc-exactprint
|
||||
, fingertree
|
||||
|
||||
if flag(agpl)
|
||||
build-depends: brittany
|
||||
@ -214,7 +199,7 @@ common hls-test-utils
|
||||
, hslogger
|
||||
, hspec
|
||||
, hspec-core
|
||||
, lsp-test >=0.11.0.4
|
||||
, lsp-test >=0.11.0.6
|
||||
, stm
|
||||
, tasty-hunit
|
||||
, temporary
|
||||
@ -291,6 +276,7 @@ test-suite wrapper-test
|
||||
, process
|
||||
, tasty
|
||||
, tasty-ant-xml >=1.1.6
|
||||
, tasty-rerun
|
||||
|
||||
hs-source-dirs: test/wrapper
|
||||
main-is: Main.hs
|
||||
|
@ -26,7 +26,7 @@ cradle:
|
||||
component: "haskell-language-server:exe:haskell-language-server"
|
||||
|
||||
- path: "./plugins/tactics/src"
|
||||
component: "haskell-language-server:exe:haskell-language-server"
|
||||
component: "lib:hls-tactics-plugin"
|
||||
|
||||
- path: "./exe/Wrapper.hs"
|
||||
component: "haskell-language-server:exe:haskell-language-server-wrapper"
|
||||
@ -34,7 +34,7 @@ cradle:
|
||||
- path: "./src"
|
||||
component: "lib:haskell-language-server"
|
||||
|
||||
- path: "./.stack-work/"
|
||||
- path: "./dist-newstyle/"
|
||||
component: "lib:haskell-language-server"
|
||||
|
||||
- path: "./ghcide/src"
|
||||
@ -45,3 +45,6 @@ cradle:
|
||||
|
||||
- path: "./hls-plugin-api/src"
|
||||
component: "hls-plugin-api:lib:hls-plugin-api"
|
||||
|
||||
- path: "./plugins/hls-hlint-plugin/src"
|
||||
component: "lib:hls-hlint-plugin"
|
||||
|
@ -21,8 +21,12 @@ cradle:
|
||||
|
||||
- path: "./plugins/default/src"
|
||||
component: "haskell-language-server:exe:haskell-language-server"
|
||||
|
||||
- path: "./plugins/tactics/src"
|
||||
component: "haskell-language-server:exe:haskell-language-server"
|
||||
component: "hls-tactics-plugin:lib:hls-tactics-plugin"
|
||||
|
||||
- path: "./plugins/tactics/test"
|
||||
component: "hls-tactics-plugin:test:tests"
|
||||
|
||||
- path: "./exe/Arguments.hs"
|
||||
component: "haskell-language-server:exe:haskell-language-server"
|
||||
@ -44,3 +48,6 @@ cradle:
|
||||
|
||||
- path: "./hls-plugin-api/src"
|
||||
component: "hls-plugin-api:lib:hls-plugin-api"
|
||||
|
||||
- path: "./plugins/hls-hlint-plugin/src"
|
||||
component: "hls-hlint-plugin:lib:hls-hlint-plugin"
|
||||
|
@ -1,6 +1,6 @@
|
||||
cabal-version: 2.2
|
||||
name: hls-plugin-api
|
||||
version: 0.4.1.0
|
||||
version: 0.5.0.0
|
||||
synopsis: Haskell Language Server API for plugin communication
|
||||
description:
|
||||
Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>
|
||||
@ -42,8 +42,9 @@ library
|
||||
, Diff
|
||||
, ghc
|
||||
, ghc-boot-th
|
||||
, ghcide >=0.4
|
||||
, ghcide >=0.5
|
||||
, haskell-lsp ^>=0.22
|
||||
, hashable
|
||||
, hslogger
|
||||
, lens
|
||||
, process
|
||||
|
@ -17,6 +17,8 @@ module Ide.Plugin
|
||||
, allLspCmdIds'
|
||||
, getPid
|
||||
, responseError
|
||||
, getClientConfig
|
||||
, getClientConfigAction
|
||||
) where
|
||||
|
||||
import Control.Exception(SomeException, catch)
|
||||
@ -25,6 +27,7 @@ import Control.Monad
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Default
|
||||
import Data.Either
|
||||
import Data.Hashable (unhashed)
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe
|
||||
@ -32,6 +35,7 @@ import qualified Data.Text as T
|
||||
import Development.IDE hiding (pluginRules)
|
||||
import Development.IDE.LSP.Server
|
||||
import GHC.Generics
|
||||
import Ide.Logger
|
||||
import Ide.Plugin.Config
|
||||
import Ide.Plugin.Formatter
|
||||
import Ide.Types
|
||||
@ -588,4 +592,13 @@ getPrefixAtPos lf uri pos = do
|
||||
getClientConfig :: LSP.LspFuncs Config -> IO Config
|
||||
getClientConfig lf = fromMaybe Data.Default.def <$> LSP.config lf
|
||||
|
||||
-- | Returns the client configurarion stored in the IdeState.
|
||||
-- You can use this function to access it from shake Rules
|
||||
getClientConfigAction :: Action Config
|
||||
getClientConfigAction = do
|
||||
mbVal <- unhashed <$> useNoFile_ GetClientSettings
|
||||
logm $ "getClientConfigAction:clientSettings:" ++ show mbVal
|
||||
case J.fromJSON <$> mbVal of
|
||||
Just (J.Success c) -> return c
|
||||
_ -> return Data.Default.def
|
||||
-- ---------------------------------------------------------------------
|
||||
|
@ -62,7 +62,19 @@ doFormatting lf providers ideState ft uri params = do
|
||||
provider lf ideState ft contents fp params
|
||||
Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri
|
||||
Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri
|
||||
Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: no formatter found for:[" ++ T.unpack mf ++ "]"
|
||||
Nothing -> return $ Left $ responseError $ mconcat
|
||||
[ "Formatter plugin: no formatter found for:["
|
||||
, mf
|
||||
, "]"
|
||||
, if mf == "brittany"
|
||||
then T.unlines
|
||||
[ "\nThe haskell-language-server must be compiled with the agpl flag to provide Brittany."
|
||||
, "Stack users add 'agpl: true' in the flags section of the 'stack.yaml' file."
|
||||
, "The 'haskell-language-server.cabal' file already has this flag enabled by default."
|
||||
, "For more information see: https://github.com/haskell/haskell-language-server/issues/269"
|
||||
]
|
||||
else ""
|
||||
]
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
|
@ -172,11 +172,11 @@ runEvalCmd lsp state EvalParams {..} = withIndefiniteProgress lsp "Eval" Cancell
|
||||
session <-
|
||||
liftIO $
|
||||
runAction "runEvalCmd.ghcSession" state $
|
||||
use_ GhcSessionDeps $
|
||||
use_ GhcSession $
|
||||
toNormalizedFilePath' $
|
||||
fp
|
||||
|
||||
ms <-
|
||||
(ms, _) <-
|
||||
liftIO $
|
||||
runAction "runEvalCmd.getModSummary" state $
|
||||
use_ GetModSummary $
|
||||
|
@ -192,11 +192,11 @@ extractMinimalImports ::
|
||||
Maybe (HscEnvEq) ->
|
||||
Maybe (TcModuleResult) ->
|
||||
IO ([LImportDecl GhcRn], Maybe [LImportDecl GhcRn])
|
||||
extractMinimalImports (Just (hsc)) (Just (tmrModule -> TypecheckedModule {..})) = do
|
||||
extractMinimalImports (Just (hsc)) (Just (TcModuleResult {..})) = do
|
||||
-- extract the original imports and the typechecking environment
|
||||
let (tcEnv, _) = tm_internals_
|
||||
Just (_, imports, _, _) = tm_renamed_source
|
||||
ParsedModule {pm_parsed_source = L loc _} = tm_parsed_module
|
||||
let tcEnv = tmrTypechecked
|
||||
(_, imports, _, _) = tmrRenamed
|
||||
ParsedModule {pm_parsed_source = L loc _} = tmrParsed
|
||||
span = fromMaybe (error "expected real") $ realSpan loc
|
||||
|
||||
-- GHC is secretly full of mutable state
|
||||
|
@ -94,7 +94,6 @@ import Development.IDE.Core.Shake
|
||||
import Data.Text ( pack )
|
||||
import System.Directory ( canonicalizePath )
|
||||
import Data.List
|
||||
import Ide.Plugin.Tactic.Debug ( unsafeRender )
|
||||
-- |Plugin descriptor
|
||||
descriptor :: PluginId -> PluginDescriptor
|
||||
descriptor plId = (defaultPluginDescriptor plId)
|
||||
|
@ -53,15 +53,14 @@ import Development.IDE.GHC.Compat (GenLocated (L), GhcRn,
|
||||
RuleDecls (HsRules),
|
||||
SrcSpan (..),
|
||||
TyClDecl (SynDecl),
|
||||
TyClGroup (..),
|
||||
TypecheckedModule (..), fun_id,
|
||||
TyClGroup (..), fun_id,
|
||||
mi_fixities, moduleNameString,
|
||||
parseModule, rds_rules,
|
||||
srcSpanFile)
|
||||
import GHC.Generics (Generic)
|
||||
import GhcPlugins (Outputable,
|
||||
SourceText (NoSourceText),
|
||||
isQual, isQual_maybe,
|
||||
hm_iface, isQual, isQual_maybe,
|
||||
nameModule_maybe, nameRdrName,
|
||||
occNameFS, occNameString,
|
||||
rdrNameOcc, unpackFS)
|
||||
@ -213,7 +212,7 @@ getBinds nfp = runMaybeT $ do
|
||||
-- we use the typechecked source instead of the parsed source
|
||||
-- to be able to extract module names from the Ids,
|
||||
-- so that we can include adding the required imports in the retrie command
|
||||
let TypecheckedModule {tm_renamed_source = Just rn} = tmrModule tm
|
||||
let rn = tmrRenamed tm
|
||||
( HsGroup
|
||||
{ hs_valds =
|
||||
XValBindsLR
|
||||
@ -313,7 +312,8 @@ suggestRuleRewrites originatingFile pos ms_mod (L _ (HsRules {rds_rules})) =
|
||||
)
|
||||
backwardsRewrite ruleName restrictToOriginatingFile =
|
||||
let rewrites = [RuleBackward (qualify ms_mod ruleName)]
|
||||
description = "Apply rule " <> T.pack ruleName <> " backwards"
|
||||
description = "Apply rule " <> T.pack ruleName <> " backwards" <>
|
||||
describeRestriction restrictToOriginatingFile
|
||||
in ( description,
|
||||
CodeActionRefactor,
|
||||
RunRetrieParams {..}
|
||||
@ -360,7 +360,7 @@ callRetrie state session rewrites origin restrictToOriginatingFile = do
|
||||
getCPPmodule t = do
|
||||
nt <- toNormalizedFilePath' <$> makeAbsolute t
|
||||
let getParsedModule f contents = do
|
||||
modSummary <-
|
||||
(modSummary, _) <-
|
||||
useOrFail "GetModSummary" (CallRetrieInternalError "file not found") GetModSummary nt
|
||||
let ms' =
|
||||
modSummary
|
||||
@ -368,8 +368,8 @@ callRetrie state session rewrites origin restrictToOriginatingFile = do
|
||||
Just (stringToStringBuffer contents)
|
||||
}
|
||||
logPriority (ideLogger state) Info $ T.pack $ "Parsing module: " <> t
|
||||
(_, parsed) <-
|
||||
runGhcEnv session (parseModule ms')
|
||||
parsed <-
|
||||
evalGhcEnv session (parseModule ms')
|
||||
`catch` \e -> throwIO (GHCParseError nt (show @SomeException e))
|
||||
(fixities, parsed) <- fixFixities f (fixAnns parsed)
|
||||
return (fixities, parsed)
|
||||
@ -453,9 +453,9 @@ callRetrie state session rewrites origin restrictToOriginatingFile = do
|
||||
let fs = occNameFS n
|
||||
]
|
||||
fixFixities f pm = do
|
||||
HiFileResult {hirModIface} <-
|
||||
HiFileResult {hirHomeMod} <-
|
||||
useOrFail "GetModIface" NoTypeCheck GetModIface f
|
||||
let fixities = fixityEnvFromModIface hirModIface
|
||||
let fixities = fixityEnvFromModIface $ hm_iface hirHomeMod
|
||||
res <- transformA pm (fix fixities)
|
||||
return (fixities, res)
|
||||
fixAnns ParsedModule {..} =
|
||||
|
201
plugins/hls-hlint-plugin/LICENSE
Normal file
201
plugins/hls-hlint-plugin/LICENSE
Normal file
@ -0,0 +1,201 @@
|
||||
Apache License
|
||||
Version 2.0, January 2004
|
||||
http://www.apache.org/licenses/
|
||||
|
||||
TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
|
||||
|
||||
1. Definitions.
|
||||
|
||||
"License" shall mean the terms and conditions for use, reproduction,
|
||||
and distribution as defined by Sections 1 through 9 of this document.
|
||||
|
||||
"Licensor" shall mean the copyright owner or entity authorized by
|
||||
the copyright owner that is granting the License.
|
||||
|
||||
"Legal Entity" shall mean the union of the acting entity and all
|
||||
other entities that control, are controlled by, or are under common
|
||||
control with that entity. For the purposes of this definition,
|
||||
"control" means (i) the power, direct or indirect, to cause the
|
||||
direction or management of such entity, whether by contract or
|
||||
otherwise, or (ii) ownership of fifty percent (50%) or more of the
|
||||
outstanding shares, or (iii) beneficial ownership of such entity.
|
||||
|
||||
"You" (or "Your") shall mean an individual or Legal Entity
|
||||
exercising permissions granted by this License.
|
||||
|
||||
"Source" form shall mean the preferred form for making modifications,
|
||||
including but not limited to software source code, documentation
|
||||
source, and configuration files.
|
||||
|
||||
"Object" form shall mean any form resulting from mechanical
|
||||
transformation or translation of a Source form, including but
|
||||
not limited to compiled object code, generated documentation,
|
||||
and conversions to other media types.
|
||||
|
||||
"Work" shall mean the work of authorship, whether in Source or
|
||||
Object form, made available under the License, as indicated by a
|
||||
copyright notice that is included in or attached to the work
|
||||
(an example is provided in the Appendix below).
|
||||
|
||||
"Derivative Works" shall mean any work, whether in Source or Object
|
||||
form, that is based on (or derived from) the Work and for which the
|
||||
editorial revisions, annotations, elaborations, or other modifications
|
||||
represent, as a whole, an original work of authorship. For the purposes
|
||||
of this License, Derivative Works shall not include works that remain
|
||||
separable from, or merely link (or bind by name) to the interfaces of,
|
||||
the Work and Derivative Works thereof.
|
||||
|
||||
"Contribution" shall mean any work of authorship, including
|
||||
the original version of the Work and any modifications or additions
|
||||
to that Work or Derivative Works thereof, that is intentionally
|
||||
submitted to Licensor for inclusion in the Work by the copyright owner
|
||||
or by an individual or Legal Entity authorized to submit on behalf of
|
||||
the copyright owner. For the purposes of this definition, "submitted"
|
||||
means any form of electronic, verbal, or written communication sent
|
||||
to the Licensor or its representatives, including but not limited to
|
||||
communication on electronic mailing lists, source code control systems,
|
||||
and issue tracking systems that are managed by, or on behalf of, the
|
||||
Licensor for the purpose of discussing and improving the Work, but
|
||||
excluding communication that is conspicuously marked or otherwise
|
||||
designated in writing by the copyright owner as "Not a Contribution."
|
||||
|
||||
"Contributor" shall mean Licensor and any individual or Legal Entity
|
||||
on behalf of whom a Contribution has been received by Licensor and
|
||||
subsequently incorporated within the Work.
|
||||
|
||||
2. Grant of Copyright License. Subject to the terms and conditions of
|
||||
this License, each Contributor hereby grants to You a perpetual,
|
||||
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
|
||||
copyright license to reproduce, prepare Derivative Works of,
|
||||
publicly display, publicly perform, sublicense, and distribute the
|
||||
Work and such Derivative Works in Source or Object form.
|
||||
|
||||
3. Grant of Patent License. Subject to the terms and conditions of
|
||||
this License, each Contributor hereby grants to You a perpetual,
|
||||
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
|
||||
(except as stated in this section) patent license to make, have made,
|
||||
use, offer to sell, sell, import, and otherwise transfer the Work,
|
||||
where such license applies only to those patent claims licensable
|
||||
by such Contributor that are necessarily infringed by their
|
||||
Contribution(s) alone or by combination of their Contribution(s)
|
||||
with the Work to which such Contribution(s) was submitted. If You
|
||||
institute patent litigation against any entity (including a
|
||||
cross-claim or counterclaim in a lawsuit) alleging that the Work
|
||||
or a Contribution incorporated within the Work constitutes direct
|
||||
or contributory patent infringement, then any patent licenses
|
||||
granted to You under this License for that Work shall terminate
|
||||
as of the date such litigation is filed.
|
||||
|
||||
4. Redistribution. You may reproduce and distribute copies of the
|
||||
Work or Derivative Works thereof in any medium, with or without
|
||||
modifications, and in Source or Object form, provided that You
|
||||
meet the following conditions:
|
||||
|
||||
(a) You must give any other recipients of the Work or
|
||||
Derivative Works a copy of this License; and
|
||||
|
||||
(b) You must cause any modified files to carry prominent notices
|
||||
stating that You changed the files; and
|
||||
|
||||
(c) You must retain, in the Source form of any Derivative Works
|
||||
that You distribute, all copyright, patent, trademark, and
|
||||
attribution notices from the Source form of the Work,
|
||||
excluding those notices that do not pertain to any part of
|
||||
the Derivative Works; and
|
||||
|
||||
(d) If the Work includes a "NOTICE" text file as part of its
|
||||
distribution, then any Derivative Works that You distribute must
|
||||
include a readable copy of the attribution notices contained
|
||||
within such NOTICE file, excluding those notices that do not
|
||||
pertain to any part of the Derivative Works, in at least one
|
||||
of the following places: within a NOTICE text file distributed
|
||||
as part of the Derivative Works; within the Source form or
|
||||
documentation, if provided along with the Derivative Works; or,
|
||||
within a display generated by the Derivative Works, if and
|
||||
wherever such third-party notices normally appear. The contents
|
||||
of the NOTICE file are for informational purposes only and
|
||||
do not modify the License. You may add Your own attribution
|
||||
notices within Derivative Works that You distribute, alongside
|
||||
or as an addendum to the NOTICE text from the Work, provided
|
||||
that such additional attribution notices cannot be construed
|
||||
as modifying the License.
|
||||
|
||||
You may add Your own copyright statement to Your modifications and
|
||||
may provide additional or different license terms and conditions
|
||||
for use, reproduction, or distribution of Your modifications, or
|
||||
for any such Derivative Works as a whole, provided Your use,
|
||||
reproduction, and distribution of the Work otherwise complies with
|
||||
the conditions stated in this License.
|
||||
|
||||
5. Submission of Contributions. Unless You explicitly state otherwise,
|
||||
any Contribution intentionally submitted for inclusion in the Work
|
||||
by You to the Licensor shall be under the terms and conditions of
|
||||
this License, without any additional terms or conditions.
|
||||
Notwithstanding the above, nothing herein shall supersede or modify
|
||||
the terms of any separate license agreement you may have executed
|
||||
with Licensor regarding such Contributions.
|
||||
|
||||
6. Trademarks. This License does not grant permission to use the trade
|
||||
names, trademarks, service marks, or product names of the Licensor,
|
||||
except as required for reasonable and customary use in describing the
|
||||
origin of the Work and reproducing the content of the NOTICE file.
|
||||
|
||||
7. Disclaimer of Warranty. Unless required by applicable law or
|
||||
agreed to in writing, Licensor provides the Work (and each
|
||||
Contributor provides its Contributions) on an "AS IS" BASIS,
|
||||
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
|
||||
implied, including, without limitation, any warranties or conditions
|
||||
of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. You are solely responsible for determining the
|
||||
appropriateness of using or redistributing the Work and assume any
|
||||
risks associated with Your exercise of permissions under this License.
|
||||
|
||||
8. Limitation of Liability. In no event and under no legal theory,
|
||||
whether in tort (including negligence), contract, or otherwise,
|
||||
unless required by applicable law (such as deliberate and grossly
|
||||
negligent acts) or agreed to in writing, shall any Contributor be
|
||||
liable to You for damages, including any direct, indirect, special,
|
||||
incidental, or consequential damages of any character arising as a
|
||||
result of this License or out of the use or inability to use the
|
||||
Work (including but not limited to damages for loss of goodwill,
|
||||
work stoppage, computer failure or malfunction, or any and all
|
||||
other commercial damages or losses), even if such Contributor
|
||||
has been advised of the possibility of such damages.
|
||||
|
||||
9. Accepting Warranty or Additional Liability. While redistributing
|
||||
the Work or Derivative Works thereof, You may choose to offer,
|
||||
and charge a fee for, acceptance of support, warranty, indemnity,
|
||||
or other liability obligations and/or rights consistent with this
|
||||
License. However, in accepting such obligations, You may act only
|
||||
on Your own behalf and on Your sole responsibility, not on behalf
|
||||
of any other Contributor, and only if You agree to indemnify,
|
||||
defend, and hold each Contributor harmless for any liability
|
||||
incurred by, or claims asserted against, such Contributor by reason
|
||||
of your accepting any such warranty or additional liability.
|
||||
|
||||
END OF TERMS AND CONDITIONS
|
||||
|
||||
APPENDIX: How to apply the Apache License to your work.
|
||||
|
||||
To apply the Apache License to your work, attach the following
|
||||
boilerplate notice, with the fields enclosed by brackets "[]"
|
||||
replaced with your own identifying information. (Don't include
|
||||
the brackets!) The text should be enclosed in the appropriate
|
||||
comment syntax for the file format. We also recommend that a
|
||||
file or class name and description of purpose be included on the
|
||||
same "printed page" as the copyright notice for easier
|
||||
identification within third-party archives.
|
||||
|
||||
Copyright [yyyy] [name of copyright owner]
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License");
|
||||
you may not use this file except in compliance with the License.
|
||||
You may obtain a copy of the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software
|
||||
distributed under the License is distributed on an "AS IS" BASIS,
|
||||
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
See the License for the specific language governing permissions and
|
||||
limitations under the License.
|
71
plugins/hls-hlint-plugin/hls-hlint-plugin.cabal
Normal file
71
plugins/hls-hlint-plugin/hls-hlint-plugin.cabal
Normal file
@ -0,0 +1,71 @@
|
||||
cabal-version: 2.2
|
||||
name: hls-hlint-plugin
|
||||
version: 0.1.0.0
|
||||
synopsis: Hlint integration plugin with Haskell Language Server
|
||||
description: Please see README.md
|
||||
license: Apache-2.0
|
||||
license-file: LICENSE
|
||||
author: Many,TBD when we release
|
||||
maintainer: alan.zimm@gmail.com (for now)
|
||||
copyright: Alan Zimmerman
|
||||
category: Web
|
||||
build-type: Simple
|
||||
|
||||
flag pedantic
|
||||
description: Enable -Werror
|
||||
default: False
|
||||
manual: True
|
||||
|
||||
flag ghc-lib
|
||||
default: False
|
||||
manual: True
|
||||
description:
|
||||
Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported
|
||||
|
||||
library
|
||||
exposed-modules: Ide.Plugin.Hlint
|
||||
hs-source-dirs: src
|
||||
build-depends:
|
||||
, aeson
|
||||
, apply-refact
|
||||
, base
|
||||
, binary
|
||||
, bytestring
|
||||
, containers
|
||||
, data-default
|
||||
, deepseq
|
||||
, Diff
|
||||
, directory
|
||||
, extra
|
||||
, filepath
|
||||
, ghcide
|
||||
, hashable
|
||||
, haskell-lsp
|
||||
, hlint >=3.2
|
||||
, hls-plugin-api
|
||||
, hslogger
|
||||
, lens
|
||||
, regex-tdfa
|
||||
, shake
|
||||
, temporary
|
||||
, text
|
||||
, transformers
|
||||
, unordered-containers
|
||||
|
||||
if ((!flag(ghc-lib) && impl(ghc >=8.10.1)) && impl(ghc <8.11.0))
|
||||
build-depends: ghc ^>= 8.10
|
||||
|
||||
else
|
||||
build-depends:
|
||||
, ghc
|
||||
, ghc-lib ^>= 8.10.2.20200916
|
||||
, ghc-lib-parser-ex ^>= 8.10
|
||||
|
||||
cpp-options: -DGHC_LIB
|
||||
|
||||
ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing
|
||||
|
||||
if flag(pedantic)
|
||||
ghc-options: -Werror
|
||||
|
||||
default-language: Haskell2010
|
404
plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs
Normal file
404
plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs
Normal file
@ -0,0 +1,404 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Ide.Plugin.Hlint
|
||||
(
|
||||
descriptor
|
||||
--, provider
|
||||
) where
|
||||
import Refact.Apply
|
||||
import Control.Arrow ((&&&))
|
||||
import Control.DeepSeq
|
||||
import Control.Exception
|
||||
import Control.Lens ((^.))
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Aeson.Types (ToJSON(..), FromJSON(..), Value(..))
|
||||
import Data.Binary
|
||||
import Data.Hashable
|
||||
import qualified Data.HashMap.Strict as Map
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import Data.Typeable
|
||||
import Development.IDE
|
||||
import Development.IDE.Core.Rules (defineNoFile)
|
||||
import Development.IDE.Core.Shake (getDiagnostics)
|
||||
|
||||
#ifdef GHC_LIB
|
||||
import Data.List (nub)
|
||||
import "ghc-lib" GHC hiding (DynFlags(..))
|
||||
import "ghc" GHC as RealGHC (DynFlags(..))
|
||||
import "ghc" HscTypes as RealGHC.HscTypes (hsc_dflags)
|
||||
import qualified "ghc" EnumSet as EnumSet
|
||||
import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension)
|
||||
#else
|
||||
import Development.IDE.GHC.Compat hiding (DynFlags(..))
|
||||
#endif
|
||||
|
||||
import Ide.Logger
|
||||
import Ide.Types
|
||||
import Ide.Plugin
|
||||
import Ide.Plugin.Config
|
||||
import Ide.PluginUtils
|
||||
import Language.Haskell.HLint as Hlint
|
||||
import Language.Haskell.LSP.Core
|
||||
import Language.Haskell.LSP.Types
|
||||
import qualified Language.Haskell.LSP.Types as LSP
|
||||
import qualified Language.Haskell.LSP.Types.Lens as LSP
|
||||
import System.FilePath (takeFileName)
|
||||
import System.IO (hPutStr, noNewlineTranslation, hSetNewlineMode, utf8, hSetEncoding, IOMode(WriteMode), withFile, hClose)
|
||||
import System.IO.Temp
|
||||
import Text.Regex.TDFA.Text()
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
descriptor :: PluginId -> PluginDescriptor
|
||||
descriptor plId = (defaultPluginDescriptor plId)
|
||||
{ pluginRules = rules
|
||||
, pluginCommands =
|
||||
[ PluginCommand "applyOne" "Apply a single hint" applyOneCmd
|
||||
, PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd
|
||||
]
|
||||
, pluginCodeActionProvider = Just codeActionProvider
|
||||
}
|
||||
|
||||
-- This rule only exists for generating file diagnostics
|
||||
-- so the RuleResult is empty
|
||||
data GetHlintDiagnostics = GetHlintDiagnostics
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
instance Hashable GetHlintDiagnostics
|
||||
instance NFData GetHlintDiagnostics
|
||||
instance Binary GetHlintDiagnostics
|
||||
|
||||
type instance RuleResult GetHlintDiagnostics = ()
|
||||
|
||||
-- | Hlint rules to generate file diagnostics based on hlint hints
|
||||
-- | This rule is recomputed when:
|
||||
-- | - The files of interest have changed via `getFilesOfInterest`
|
||||
-- | - One of those files has been edited via
|
||||
-- | - `getIdeas` -> `getParsedModule` in any case
|
||||
-- | - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc
|
||||
-- | - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction`
|
||||
-- | - The hlint specific settings have changed, via `getHlintSettingsRule`
|
||||
rules :: Rules ()
|
||||
rules = do
|
||||
define $ \GetHlintDiagnostics file -> do
|
||||
hlintOn' <- hlintOn <$> getClientConfigAction
|
||||
ideas <- if hlintOn' then getIdeas file else return (Right [])
|
||||
return (diagnostics file ideas, Just ())
|
||||
|
||||
getHlintSettingsRule (HlintEnabled [])
|
||||
|
||||
action $ do
|
||||
files <- getFilesOfInterest
|
||||
void $ uses GetHlintDiagnostics $ Map.keys files
|
||||
|
||||
where
|
||||
|
||||
diagnostics :: NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic]
|
||||
diagnostics file (Right ideas) =
|
||||
[(file, ShowDiag, ideaToDiagnostic i) | i <- ideas, ideaSeverity i /= Ignore]
|
||||
diagnostics file (Left parseErr) =
|
||||
[(file, ShowDiag, parseErrorToDiagnostic parseErr)]
|
||||
|
||||
ideaToDiagnostic :: Idea -> Diagnostic
|
||||
ideaToDiagnostic idea =
|
||||
LSP.Diagnostic {
|
||||
_range = srcSpanToRange $ ideaSpan idea
|
||||
, _severity = Just LSP.DsInfo
|
||||
-- we are encoding the fact that idea has refactorings in diagnostic code
|
||||
, _code = Just (LSP.StringValue $ T.pack $ codePre ++ ideaHint idea)
|
||||
, _source = Just "hlint"
|
||||
, _message = idea2Message idea
|
||||
, _relatedInformation = Nothing
|
||||
, _tags = Nothing
|
||||
}
|
||||
where codePre = if null $ ideaRefactoring idea then "" else "refact:"
|
||||
|
||||
idea2Message :: Idea -> T.Text
|
||||
idea2Message idea = T.unlines $ [T.pack $ ideaHint idea, "Found:", " " <> T.pack (ideaFrom idea)]
|
||||
<> toIdea <> map (T.pack . show) (ideaNote idea)
|
||||
where
|
||||
toIdea :: [T.Text]
|
||||
toIdea = case ideaTo idea of
|
||||
Nothing -> []
|
||||
Just i -> [T.pack "Why not:", T.pack $ " " ++ i]
|
||||
|
||||
|
||||
parseErrorToDiagnostic :: ParseError -> Diagnostic
|
||||
parseErrorToDiagnostic (Hlint.ParseError l msg contents) =
|
||||
LSP.Diagnostic {
|
||||
_range = srcSpanToRange l
|
||||
, _severity = Just LSP.DsInfo
|
||||
, _code = Just (LSP.StringValue "parser")
|
||||
, _source = Just "hlint"
|
||||
, _message = T.unlines [T.pack msg,T.pack contents]
|
||||
, _relatedInformation = Nothing
|
||||
, _tags = Nothing
|
||||
}
|
||||
|
||||
-- This one is defined in Development.IDE.GHC.Error but here
|
||||
-- the types could come from ghc-lib or ghc
|
||||
srcSpanToRange :: SrcSpan -> LSP.Range
|
||||
srcSpanToRange (RealSrcSpan span) = Range {
|
||||
_start = LSP.Position {
|
||||
_line = srcSpanStartLine span - 1
|
||||
, _character = srcSpanStartCol span - 1}
|
||||
, _end = LSP.Position {
|
||||
_line = srcSpanEndLine span - 1
|
||||
, _character = srcSpanEndCol span - 1}
|
||||
}
|
||||
srcSpanToRange (UnhelpfulSpan _) = noRange
|
||||
|
||||
getIdeas :: NormalizedFilePath -> Action (Either ParseError [Idea])
|
||||
getIdeas nfp = do
|
||||
logm $ "hlint:getIdeas:file:" ++ show nfp
|
||||
(flags, classify, hint) <- useNoFile_ GetHlintSettings
|
||||
|
||||
let applyHints' (Just (Right modEx)) = Right $ applyHints classify hint [modEx]
|
||||
applyHints' (Just (Left err)) = Left err
|
||||
applyHints' Nothing = Right []
|
||||
|
||||
fmap applyHints' (moduleEx flags)
|
||||
|
||||
where moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx))
|
||||
#ifdef GHC_LIB
|
||||
moduleEx flags = do
|
||||
mbpm <- getParsedModule nfp
|
||||
-- If ghc was not able to parse the module, we disable hlint diagnostics
|
||||
if isNothing mbpm
|
||||
then return Nothing
|
||||
else do
|
||||
flags' <- setExtensions flags
|
||||
(_, contents) <- getFileContents nfp
|
||||
let fp = fromNormalizedFilePath nfp
|
||||
let contents' = T.unpack <$> contents
|
||||
Just <$> (liftIO $ parseModuleEx flags' fp contents')
|
||||
|
||||
setExtensions flags = do
|
||||
hsc <- hscEnv <$> use_ GhcSession nfp
|
||||
let dflags = hsc_dflags hsc
|
||||
let hscExts = EnumSet.toList (extensionFlags dflags)
|
||||
let hscExts' = mapMaybe (GhclibParserEx.readExtension . show) hscExts
|
||||
let hlintExts = nub $ enabledExtensions flags ++ hscExts'
|
||||
logm $ "hlint:getIdeas:setExtensions:" ++ show hlintExts
|
||||
return $ flags { enabledExtensions = hlintExts }
|
||||
#else
|
||||
moduleEx _flags = do
|
||||
mbpm <- getParsedModule nfp
|
||||
return $ createModule <$> mbpm
|
||||
where createModule pm = Right (createModuleEx anns modu)
|
||||
where anns = pm_annotations pm
|
||||
modu = pm_parsed_source pm
|
||||
#endif
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
data HlintUsage
|
||||
= HlintEnabled { cmdArgs :: [String] }
|
||||
| HlintDisabled
|
||||
deriving Show
|
||||
|
||||
data GetHlintSettings = GetHlintSettings
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
instance Hashable GetHlintSettings
|
||||
instance NFData GetHlintSettings
|
||||
instance NFData Hint where rnf = rwhnf
|
||||
instance NFData Classify where rnf = rwhnf
|
||||
instance NFData ParseFlags where rnf = rwhnf
|
||||
instance Show Hint where show = const "<hint>"
|
||||
instance Show ParseFlags where show = const "<parseFlags>"
|
||||
instance Binary GetHlintSettings
|
||||
|
||||
type instance RuleResult GetHlintSettings = (ParseFlags, [Classify], Hint)
|
||||
|
||||
getHlintSettingsRule :: HlintUsage -> Rules ()
|
||||
getHlintSettingsRule usage =
|
||||
defineNoFile $ \GetHlintSettings ->
|
||||
liftIO $ case usage of
|
||||
HlintEnabled cmdArgs -> argsSettings cmdArgs
|
||||
HlintDisabled -> fail "hlint configuration unspecified"
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
codeActionProvider :: CodeActionProvider
|
||||
codeActionProvider _lf ideState plId docId _ context = Right . LSP.List . map CACodeAction <$> getCodeActions
|
||||
where
|
||||
|
||||
getCodeActions = do
|
||||
applyOne <- applyOneActions
|
||||
diags <- getDiagnostics ideState
|
||||
let docNfp = toNormalizedFilePath' <$> uriToFilePath' (docId ^. LSP.uri)
|
||||
numHintsInDoc = length
|
||||
[d | (nfp, _, d) <- diags
|
||||
, validCommand d
|
||||
, Just nfp == docNfp
|
||||
]
|
||||
-- We only want to show the applyAll code action if there is more than 1
|
||||
-- hint in the current document
|
||||
if numHintsInDoc > 1 then do
|
||||
applyAll <- applyAllAction
|
||||
pure $ applyAll:applyOne
|
||||
else
|
||||
pure applyOne
|
||||
|
||||
applyAllAction = do
|
||||
let args = Just [toJSON (docId ^. LSP.uri)]
|
||||
cmd <- mkLspCommand plId "applyAll" "Apply all hints" args
|
||||
pure $ LSP.CodeAction "Apply all hints" (Just LSP.CodeActionQuickFix) Nothing Nothing (Just cmd)
|
||||
|
||||
applyOneActions :: IO [LSP.CodeAction]
|
||||
applyOneActions = catMaybes <$> mapM mkHlintAction (filter validCommand diags)
|
||||
|
||||
-- |Some hints do not have an associated refactoring
|
||||
validCommand (LSP.Diagnostic _ _ (Just (LSP.StringValue code)) (Just "hlint") _ _ _) =
|
||||
"refact:" `T.isPrefixOf` code
|
||||
validCommand _ =
|
||||
False
|
||||
|
||||
LSP.List diags = context ^. LSP.diagnostics
|
||||
|
||||
mkHlintAction :: LSP.Diagnostic -> IO (Maybe LSP.CodeAction)
|
||||
mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (LSP.StringValue code)) (Just "hlint") _ _ _) =
|
||||
Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args)
|
||||
where
|
||||
codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing (Just cmd)
|
||||
-- we have to recover the original ideaHint removing the prefix
|
||||
ideaHint = T.replace "refact:" "" code
|
||||
title = "Apply hint: " <> ideaHint
|
||||
-- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location)
|
||||
args = [toJSON (AOP (docId ^. LSP.uri) start ideaHint)]
|
||||
mkHlintAction (LSP.Diagnostic _r _s _c _source _m _ _) = return Nothing
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
applyAllCmd :: CommandFunction Uri
|
||||
applyAllCmd lf ide uri = do
|
||||
let file = maybe (error $ show uri ++ " is not a file.")
|
||||
toNormalizedFilePath'
|
||||
(uriToFilePath' uri)
|
||||
withIndefiniteProgress lf "Applying all hints" Cancellable $ do
|
||||
logm $ "hlint:applyAllCmd:file=" ++ show file
|
||||
res <- applyHint ide file Nothing
|
||||
logm $ "hlint:applyAllCmd:res=" ++ show res
|
||||
return $
|
||||
case res of
|
||||
Left err -> (Left (responseError (T.pack $ "hlint:applyAll: " ++ show err)), Nothing)
|
||||
Right fs -> (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams fs))
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
data ApplyOneParams = AOP
|
||||
{ file :: Uri
|
||||
, start_pos :: Position
|
||||
-- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them.
|
||||
, hintTitle :: HintTitle
|
||||
} deriving (Eq,Show,Generic,FromJSON,ToJSON)
|
||||
|
||||
type HintTitle = T.Text
|
||||
|
||||
data OneHint = OneHint
|
||||
{ oneHintPos :: Position
|
||||
, oneHintTitle :: HintTitle
|
||||
} deriving (Eq, Show)
|
||||
|
||||
applyOneCmd :: CommandFunction ApplyOneParams
|
||||
applyOneCmd lf ide (AOP uri pos title) = do
|
||||
let oneHint = OneHint pos title
|
||||
let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath'
|
||||
(uriToFilePath' uri)
|
||||
let progTitle = "Applying hint: " <> title
|
||||
withIndefiniteProgress lf progTitle Cancellable $ do
|
||||
logm $ "hlint:applyOneCmd:file=" ++ show file
|
||||
res <- applyHint ide file (Just oneHint)
|
||||
logm $ "hlint:applyOneCmd:res=" ++ show res
|
||||
return $
|
||||
case res of
|
||||
Left err -> (Left (responseError (T.pack $ "hlint:applyOne: " ++ show err)), Nothing)
|
||||
Right fs -> (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams fs))
|
||||
|
||||
applyHint :: IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit)
|
||||
applyHint ide nfp mhint =
|
||||
runExceptT $ do
|
||||
ideas <- bimapExceptT showParseError id $ ExceptT $ liftIO $ runAction "applyHint" ide $ getIdeas nfp
|
||||
let ideas' = maybe ideas (`filterIdeas` ideas) mhint
|
||||
let commands = map (show &&& ideaRefactoring) ideas'
|
||||
liftIO $ logm $ "applyHint:apply=" ++ show commands
|
||||
-- set Nothing as "position" for "applyRefactorings" because
|
||||
-- applyRefactorings expects the provided position to be _within_ the scope
|
||||
-- of each refactoring it will apply.
|
||||
-- But "Idea"s returned by HLint point to starting position of the expressions
|
||||
-- that contain refactorings, so they are often outside the refactorings' boundaries.
|
||||
-- Example:
|
||||
-- Given an expression "hlintTest = reid $ (myid ())"
|
||||
-- Hlint returns an idea at the position (1,13)
|
||||
-- That contains "Redundant brackets" refactoring at position (1,20):
|
||||
--
|
||||
-- [("src/App/Test.hs:5:13: Warning: Redundant bracket\nFound:\n reid $ (myid ())\nWhy not:\n reid $ myid ()\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 5, startCol = 20, endLine = 5, endCol = 29}, subts = [("x",SrcSpan {startLine = 5, startCol = 21, endLine = 5, endCol = 28})], orig = "x"}])]
|
||||
--
|
||||
-- If we provide "applyRefactorings" with "Just (1,13)" then
|
||||
-- the "Redundant bracket" hint will never be executed
|
||||
-- because SrcSpan (1,20,??,??) doesn't contain position (1,13).
|
||||
let fp = fromNormalizedFilePath nfp
|
||||
(_, mbOldContent) <- liftIO $ runAction "hlint" ide $ getFileContents nfp
|
||||
oldContent <- maybe (liftIO $ T.readFile fp) return mbOldContent
|
||||
-- We need to save a file with last edited contents cause `apply-refact`
|
||||
-- doesn't expose a function taking directly contents instead a file path.
|
||||
-- Ideally we should try to expose that function upstream and remove this.
|
||||
res <- liftIO $ withSystemTempFile (takeFileName fp) $ \temp h -> do
|
||||
hClose h
|
||||
writeFileUTF8NoNewLineTranslation temp oldContent
|
||||
(Right <$> applyRefactorings Nothing commands temp) `catches`
|
||||
[ Handler $ \e -> return (Left (show (e :: IOException)))
|
||||
, Handler $ \e -> return (Left (show (e :: ErrorCall)))
|
||||
]
|
||||
case res of
|
||||
Right appliedFile -> do
|
||||
let uri = fromNormalizedUri (filePathToUri' nfp)
|
||||
let wsEdit = diffText' True (uri, oldContent) (T.pack appliedFile) IncludeDeletions
|
||||
liftIO $ logm $ "hlint:applyHint:diff=" ++ show wsEdit
|
||||
ExceptT $ return (Right wsEdit)
|
||||
Left err ->
|
||||
throwE (show err)
|
||||
where
|
||||
-- | If we are only interested in applying a particular hint then
|
||||
-- let's filter out all the irrelevant ideas
|
||||
filterIdeas :: OneHint -> [Idea] -> [Idea]
|
||||
filterIdeas (OneHint (Position l c) title) ideas =
|
||||
let title' = T.unpack title
|
||||
ideaPos = (srcSpanStartLine &&& srcSpanStartCol) . toRealSrcSpan . ideaSpan
|
||||
in filter (\i -> ideaHint i == title' && ideaPos i == (l+1, c+1)) ideas
|
||||
|
||||
toRealSrcSpan (RealSrcSpan real) = real
|
||||
toRealSrcSpan (UnhelpfulSpan x) = error $ "No real source span: " ++ show x
|
||||
|
||||
showParseError :: Hlint.ParseError -> String
|
||||
showParseError (Hlint.ParseError location message content) =
|
||||
unlines [show location, message, content]
|
||||
|
||||
-- | Map over both failure and success.
|
||||
bimapExceptT :: Functor m => (e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b
|
||||
bimapExceptT f g (ExceptT m) = ExceptT (fmap h m) where
|
||||
h (Left e) = Left (f e)
|
||||
h (Right a) = Right (g a)
|
||||
{-# INLINE bimapExceptT #-}
|
||||
|
||||
writeFileUTF8NoNewLineTranslation :: FilePath -> T.Text -> IO()
|
||||
writeFileUTF8NoNewLineTranslation file txt =
|
||||
withFile file WriteMode $ \h -> do
|
||||
hSetEncoding h utf8
|
||||
hSetNewlineMode h noNewlineTranslation
|
||||
hPutStr h (T.unpack txt)
|
103
plugins/tactics/hls-tactics-plugin.cabal
Normal file
103
plugins/tactics/hls-tactics-plugin.cabal
Normal file
@ -0,0 +1,103 @@
|
||||
cabal-version: 2.2
|
||||
category: Development
|
||||
name: hls-tactics-plugin
|
||||
version: 0.5.1.0
|
||||
synopsis: LSP server for GHC
|
||||
description:
|
||||
Please see the README on GitHub at <https://github.com/isovector/hls-tactics-plugin#readme>
|
||||
|
||||
homepage: https://github.com/isovector/hls-tactics-plugin#readme
|
||||
bug-reports: https://github.com/isovector/hls-tactics-plugin/issues
|
||||
author: Sandy Maguire, Reed Mullanix
|
||||
maintainer: sandy@sandymaguire.me
|
||||
copyright: Sandy Maguire, Reed Mullanix
|
||||
-- license: Apache-2.0
|
||||
-- license-file: LICENSE
|
||||
build-type: Simple
|
||||
-- extra-source-files:
|
||||
-- README.md
|
||||
-- ChangeLog.md
|
||||
|
||||
flag pedantic
|
||||
description: Enable -Werror
|
||||
default: False
|
||||
manual: True
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/isovector/hls-tactics-plugin
|
||||
|
||||
library
|
||||
hs-source-dirs: src
|
||||
exposed-modules:
|
||||
Ide.Plugin.Tactic
|
||||
Ide.Plugin.Tactic.Auto
|
||||
Ide.Plugin.Tactic.CodeGen
|
||||
Ide.Plugin.Tactic.Context
|
||||
Ide.Plugin.Tactic.Debug
|
||||
Ide.Plugin.Tactic.GHC
|
||||
Ide.Plugin.Tactic.Judgements
|
||||
Ide.Plugin.Tactic.KnownStrategies
|
||||
Ide.Plugin.Tactic.Machinery
|
||||
Ide.Plugin.Tactic.Naming
|
||||
Ide.Plugin.Tactic.Range
|
||||
Ide.Plugin.Tactic.Tactics
|
||||
Ide.Plugin.Tactic.Types
|
||||
Ide.Plugin.Tactic.TestTypes
|
||||
Ide.TreeTransform
|
||||
|
||||
ghc-options:
|
||||
-Wno-name-shadowing -Wredundant-constraints
|
||||
if flag(pedantic)
|
||||
ghc-options: -Werror
|
||||
|
||||
build-depends:
|
||||
, aeson
|
||||
, base >=4.12 && <5
|
||||
, containers
|
||||
, directory
|
||||
, extra
|
||||
, filepath
|
||||
, fingertree
|
||||
, generic-lens
|
||||
, ghc
|
||||
, ghc-boot-th
|
||||
, ghc-exactprint
|
||||
, ghc-source-gen
|
||||
, ghcide >=0.1
|
||||
, haskell-lsp ^>=0.22
|
||||
, hls-plugin-api
|
||||
, lens
|
||||
, mtl
|
||||
, refinery ^>=0.3
|
||||
, retrie >=0.1.1.0
|
||||
, shake >=0.17.5
|
||||
, syb
|
||||
, text
|
||||
, transformers
|
||||
, deepseq
|
||||
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite tests
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
AutoTupleSpec
|
||||
UnificationSpec
|
||||
hs-source-dirs:
|
||||
test
|
||||
ghc-options: -Wall -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
QuickCheck
|
||||
, base
|
||||
, checkers
|
||||
, hspec
|
||||
, mtl
|
||||
, hls-tactics-plugin
|
||||
, hls-plugin-api
|
||||
, hie-bios
|
||||
, ghc
|
||||
, containers
|
||||
default-language: Haskell2010
|
||||
|
@ -1,7 +1,9 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NumDecimals #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
@ -20,8 +22,14 @@ import Control.Monad.Trans
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.Aeson
|
||||
import Data.Coerce
|
||||
import Data.Functor ((<&>))
|
||||
import Data.Generics.Aliases (mkQ)
|
||||
import Data.Generics.Schemes (everything)
|
||||
import Data.List
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import Data.Monoid
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Text as T
|
||||
import Data.Traversable
|
||||
@ -38,6 +46,7 @@ import qualified FastString
|
||||
import GHC.Generics (Generic)
|
||||
import GHC.LanguageExtensions.Type (Extension (LambdaCase))
|
||||
import Ide.Plugin (mkLspCommand)
|
||||
import Ide.Plugin.Tactic.Auto
|
||||
import Ide.Plugin.Tactic.Context
|
||||
import Ide.Plugin.Tactic.GHC
|
||||
import Ide.Plugin.Tactic.Judgements
|
||||
@ -50,6 +59,9 @@ import Ide.Types
|
||||
import Language.Haskell.LSP.Core (clientCapabilities)
|
||||
import Language.Haskell.LSP.Types
|
||||
import OccName
|
||||
import SrcLoc (containsSpan)
|
||||
import System.Timeout
|
||||
import TcRnTypes (tcg_binds)
|
||||
|
||||
|
||||
descriptor :: PluginId -> PluginDescriptor
|
||||
@ -205,7 +217,7 @@ filterBindingType
|
||||
filterBindingType p tp dflags plId uri range jdg =
|
||||
let hy = jHypothesis jdg
|
||||
g = jGoal jdg
|
||||
in fmap join $ for (M.toList hy) $ \(occ, CType ty) ->
|
||||
in fmap join $ for (M.toList hy) $ \(occ, hi_type -> CType ty) ->
|
||||
case p (unCType g) ty of
|
||||
True -> tp occ ty dflags plId uri range jdg
|
||||
False -> pure []
|
||||
@ -235,7 +247,7 @@ judgementForHole state nfp range = do
|
||||
|
||||
-- Ok to use the stale 'ModIface', since all we need is its 'DynFlags'
|
||||
-- which don't change very often.
|
||||
(modsum, _) <- MaybeT $ runIde state $ useWithStale GetModSummaryWithoutTimestamps nfp
|
||||
((modsum,_), _) <- MaybeT $ runIde state $ useWithStale GetModSummaryWithoutTimestamps nfp
|
||||
let dflags = ms_hspp_opts modsum
|
||||
|
||||
(rss, goal) <- liftMaybe $ join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts $ hieAst asts) $ \fs ast ->
|
||||
@ -249,15 +261,34 @@ judgementForHole state nfp range = do
|
||||
|
||||
resulting_range <- liftMaybe $ toCurrentRange amapping $ realSrcSpanToRange rss
|
||||
(tcmod, _) <- MaybeT $ runIde state $ useWithStale TypeCheck nfp
|
||||
let tcg = fst $ tm_internals_ $ tmrModule tcmod
|
||||
let tcg = tmrTypechecked tcmod
|
||||
tcs = tcg_binds tcg
|
||||
ctx = mkContext
|
||||
(mapMaybe (sequenceA . (occName *** coerce))
|
||||
$ getDefiningBindings binds rss)
|
||||
tcg
|
||||
hyps = hypothesisFromBindings rss binds
|
||||
pure (resulting_range, mkFirstJudgement hyps goal, ctx, dflags)
|
||||
top_provs = getRhsPosVals rss tcs
|
||||
local_hy = spliceProvenance top_provs
|
||||
$ hypothesisFromBindings rss binds
|
||||
cls_hy = contextMethodHypothesis ctx
|
||||
pure ( resulting_range
|
||||
, mkFirstJudgement
|
||||
(local_hy <> cls_hy)
|
||||
(isRhsHole rss tcs)
|
||||
goal
|
||||
, ctx
|
||||
, dflags
|
||||
)
|
||||
|
||||
|
||||
spliceProvenance
|
||||
:: Map OccName Provenance
|
||||
-> Map OccName (HyInfo a)
|
||||
-> Map OccName (HyInfo a)
|
||||
spliceProvenance provs =
|
||||
M.mapWithKey $ \name hi ->
|
||||
overProvenance (maybe id const $ M.lookup name provs) hi
|
||||
|
||||
|
||||
tacticCmd :: (OccName -> TacticsM ()) -> CommandFunction TacticParams
|
||||
tacticCmd tac lf state (TacticParams uri range var_name)
|
||||
@ -266,6 +297,7 @@ tacticCmd tac lf state (TacticParams uri range var_name)
|
||||
(range', jdg, ctx, dflags) <- judgementForHole state nfp range
|
||||
let span = rangeToRealSrcSpan (fromNormalizedFilePath nfp) range'
|
||||
pm <- MaybeT $ useAnnotatedSource "tacticsCmd" state nfp
|
||||
x <- lift $ timeout 2e8 $
|
||||
case runTactic ctx jdg
|
||||
$ tac
|
||||
$ mkVarOcc
|
||||
@ -274,12 +306,18 @@ tacticCmd tac lf state (TacticParams uri range var_name)
|
||||
pure $ (, Nothing)
|
||||
$ Left
|
||||
$ ResponseError InvalidRequest (T.pack $ show err) Nothing
|
||||
Right res -> do
|
||||
let g = graft (RealSrcSpan span) res
|
||||
Right rtr -> do
|
||||
traceMX "solns" $ rtr_other_solns rtr
|
||||
let g = graft (RealSrcSpan span) $ rtr_extract rtr
|
||||
response = transform dflags (clientCapabilities lf) uri g pm
|
||||
pure $ case response of
|
||||
Right res -> (Right Null , Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res))
|
||||
Left err -> (Left $ ResponseError InternalError (T.pack err) Nothing, Nothing)
|
||||
pure $ case x of
|
||||
Just y -> y
|
||||
Nothing -> (, Nothing)
|
||||
$ Left
|
||||
$ ResponseError InvalidRequest "timed out" Nothing
|
||||
tacticCmd _ _ _ _ =
|
||||
pure ( Left $ ResponseError InvalidRequest (T.pack "Bad URI") Nothing
|
||||
, Nothing
|
||||
@ -292,3 +330,39 @@ fromMaybeT def = fmap (fromMaybe def) . runMaybeT
|
||||
liftMaybe :: Monad m => Maybe a -> MaybeT m a
|
||||
liftMaybe a = MaybeT $ pure a
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Is this hole immediately to the right of an equals sign?
|
||||
isRhsHole :: RealSrcSpan -> TypecheckedSource -> Bool
|
||||
isRhsHole rss tcs = everything (||) (mkQ False $ \case
|
||||
TopLevelRHS _ _ (L (RealSrcSpan span) _) -> containsSpan rss span
|
||||
_ -> False
|
||||
) tcs
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Compute top-level position vals of a function
|
||||
getRhsPosVals :: RealSrcSpan -> TypecheckedSource -> Map OccName Provenance
|
||||
getRhsPosVals rss tcs
|
||||
= M.fromList
|
||||
$ join
|
||||
$ maybeToList
|
||||
$ getFirst
|
||||
$ everything (<>) (mkQ mempty $ \case
|
||||
TopLevelRHS name ps
|
||||
(L (RealSrcSpan span) -- body with no guards and a single defn
|
||||
(HsVar _ (L _ hole)))
|
||||
| containsSpan rss span -- which contains our span
|
||||
, isHole $ occName hole -- and the span is a hole
|
||||
-> First $ do
|
||||
patnames <- traverse getPatName ps
|
||||
pure $ zip patnames $ [0..] <&> TopLevelArgPrv name
|
||||
_ -> mempty
|
||||
) tcs
|
||||
|
||||
|
||||
|
||||
-- TODO(sandy): Make this more robust
|
||||
isHole :: OccName -> Bool
|
||||
isHole = isPrefixOf "_" . occNameString
|
||||
|
||||
|
28
plugins/tactics/src/Ide/Plugin/Tactic/Auto.hs
Normal file
28
plugins/tactics/src/Ide/Plugin/Tactic/Auto.hs
Normal file
@ -0,0 +1,28 @@
|
||||
module Ide.Plugin.Tactic.Auto where
|
||||
|
||||
import Control.Monad.State (gets)
|
||||
import Ide.Plugin.Tactic.Context
|
||||
import Ide.Plugin.Tactic.Judgements
|
||||
import Ide.Plugin.Tactic.KnownStrategies
|
||||
import Ide.Plugin.Tactic.Machinery (tracing)
|
||||
import Ide.Plugin.Tactic.Tactics
|
||||
import Ide.Plugin.Tactic.Types
|
||||
import Refinery.Tactic
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Automatically solve a goal.
|
||||
auto :: TacticsM ()
|
||||
auto = do
|
||||
jdg <- goal
|
||||
skolems <- gets ts_skolems
|
||||
current <- getCurrentDefinitions
|
||||
traceMX "goal" jdg
|
||||
traceMX "ctx" current
|
||||
traceMX "skolems" skolems
|
||||
commit knownStrategies
|
||||
. tracing "auto"
|
||||
. localTactic (auto' 4)
|
||||
. disallowing RecursiveCall
|
||||
$ fmap fst current
|
||||
|
@ -1,12 +1,24 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Ide.Plugin.Tactic.CodeGen where
|
||||
|
||||
import Control.Lens ((+~), (%~), (<>~))
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.State (MonadState)
|
||||
import Control.Monad.State.Class (modify)
|
||||
import Data.Generics.Product (field)
|
||||
import Data.List
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
import Data.Traversable
|
||||
import DataCon
|
||||
import Development.IDE.GHC.Compat
|
||||
import GHC.Exts
|
||||
import GHC.SourceGen (RdrNameStr)
|
||||
import GHC.SourceGen.Binds
|
||||
import GHC.SourceGen.Expr
|
||||
import GHC.SourceGen.Overloaded
|
||||
@ -19,17 +31,40 @@ import Name
|
||||
import Type hiding (Var)
|
||||
|
||||
|
||||
useOccName :: MonadState TacticState m => Judgement -> OccName -> m ()
|
||||
useOccName jdg name =
|
||||
-- Only score points if this is in the local hypothesis
|
||||
case M.lookup name $ jLocalHypothesis jdg of
|
||||
Just{} -> modify
|
||||
$ (withUsedVals $ S.insert name)
|
||||
. (field @"ts_unused_top_vals" %~ S.delete name)
|
||||
Nothing -> pure ()
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Doing recursion incurs a small penalty in the score.
|
||||
countRecursiveCall :: TacticState -> TacticState
|
||||
countRecursiveCall = field @"ts_recursion_count" +~ 1
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Insert some values into the unused top values field. These are
|
||||
-- subsequently removed via 'useOccName'.
|
||||
addUnusedTopVals :: MonadState TacticState m => S.Set OccName -> m ()
|
||||
addUnusedTopVals vals = modify $ field @"ts_unused_top_vals" <>~ vals
|
||||
|
||||
|
||||
destructMatches
|
||||
:: (DataCon -> Judgement -> Rule)
|
||||
-- ^ How to construct each match
|
||||
-> (Judgement -> Judgement)
|
||||
-- ^ How to derive each match judgement
|
||||
-> Maybe OccName
|
||||
-- ^ Scrutinee
|
||||
-> CType
|
||||
-- ^ Type being destructed
|
||||
-> Judgement
|
||||
-> RuleM [RawMatch]
|
||||
destructMatches f f2 t jdg = do
|
||||
let hy = jHypothesis jdg
|
||||
-> RuleM (Trace, [RawMatch])
|
||||
destructMatches f scrut t jdg = do
|
||||
let hy = jEntireHypothesis jdg
|
||||
g = jGoal jdg
|
||||
case splitTyConApp_maybe $ unCType t of
|
||||
Nothing -> throwError $ GoalMismatch "destruct" g
|
||||
@ -37,18 +72,51 @@ destructMatches f f2 t jdg = do
|
||||
let dcs = tyConDataCons tc
|
||||
case dcs of
|
||||
[] -> throwError $ GoalMismatch "destruct" g
|
||||
_ -> for dcs $ \dc -> do
|
||||
_ -> fmap unzipTrace $ for dcs $ \dc -> do
|
||||
let args = dataConInstOrigArgTys' dc apps
|
||||
names <- mkManyGoodNames hy args
|
||||
|
||||
let pat :: Pat GhcPs
|
||||
pat = conP (fromString $ occNameString $ nameOccName $ dataConName dc)
|
||||
$ fmap bvar' names
|
||||
j = f2
|
||||
$ introducingPat (zip names $ coerce args)
|
||||
let hy' = zip names $ coerce args
|
||||
j = introducingPat scrut dc hy'
|
||||
$ withNewGoal g jdg
|
||||
sg <- f dc j
|
||||
pure $ match [pat] $ unLoc sg
|
||||
(tr, sg) <- f dc j
|
||||
modify $ withIntroducedVals $ mappend $ S.fromList names
|
||||
pure ( rose ("match " <> show dc <> " {" <>
|
||||
intercalate ", " (fmap show names) <> "}")
|
||||
$ pure tr
|
||||
, match [mkDestructPat dc names] $ unLoc sg
|
||||
)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Produces a pattern for a data con and the names of its fields.
|
||||
mkDestructPat :: DataCon -> [OccName] -> Pat GhcPs
|
||||
mkDestructPat dcon names
|
||||
| isTupleDataCon dcon =
|
||||
tuple pat_args
|
||||
| otherwise =
|
||||
infixifyPatIfNecessary dcon $
|
||||
conP
|
||||
(coerceName $ dataConName dcon)
|
||||
pat_args
|
||||
where
|
||||
pat_args = fmap bvar' names
|
||||
|
||||
|
||||
infixifyPatIfNecessary :: DataCon -> Pat GhcPs -> Pat GhcPs
|
||||
infixifyPatIfNecessary dcon x
|
||||
| dataConIsInfix dcon =
|
||||
case x of
|
||||
ConPatIn op (PrefixCon [lhs, rhs]) ->
|
||||
ConPatIn op $ InfixCon lhs rhs
|
||||
y -> y
|
||||
| otherwise = x
|
||||
|
||||
|
||||
|
||||
unzipTrace :: [(Trace, a)] -> (Trace, [a])
|
||||
unzipTrace l =
|
||||
let (trs, as) = unzip l
|
||||
in (rose mempty trs, as)
|
||||
|
||||
|
||||
-- | Essentially same as 'dataConInstOrigArgTys' in GHC,
|
||||
@ -66,12 +134,21 @@ dataConInstOrigArgTys' con ty =
|
||||
|
||||
destruct' :: (DataCon -> Judgement -> Rule) -> OccName -> Judgement -> Rule
|
||||
destruct' f term jdg = do
|
||||
when (isDestructBlacklisted jdg) $ throwError NoApplicableTactic
|
||||
let hy = jHypothesis jdg
|
||||
case find ((== term) . fst) $ toList hy of
|
||||
Nothing -> throwError $ UndefinedHypothesis term
|
||||
Just (_, t) ->
|
||||
fmap noLoc $ case' (var' term) <$>
|
||||
destructMatches f (destructing term) t jdg
|
||||
Just (_, hi_type -> t) -> do
|
||||
useOccName jdg term
|
||||
(tr, ms)
|
||||
<- destructMatches
|
||||
f
|
||||
(Just term)
|
||||
t
|
||||
$ disallowing AlreadyDestructed [term] jdg
|
||||
pure ( rose ("destruct " <> show term) $ pure tr
|
||||
, noLoc $ case' (var' term) ms
|
||||
)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -79,11 +156,12 @@ destruct' f term jdg = do
|
||||
-- resulting matches.
|
||||
destructLambdaCase' :: (DataCon -> Judgement -> Rule) -> Judgement -> Rule
|
||||
destructLambdaCase' f jdg = do
|
||||
when (isDestructBlacklisted jdg) $ throwError NoApplicableTactic
|
||||
let g = jGoal jdg
|
||||
case splitFunTy_maybe (unCType g) of
|
||||
Just (arg, _) | isAlgType arg ->
|
||||
fmap noLoc $ lambdaCase <$>
|
||||
destructMatches f id (CType arg) jdg
|
||||
fmap (fmap noLoc $ lambdaCase) <$>
|
||||
destructMatches f Nothing (CType arg) jdg
|
||||
_ -> throwError $ GoalMismatch "destructLambdaCase'" g
|
||||
|
||||
|
||||
@ -93,15 +171,40 @@ buildDataCon
|
||||
:: Judgement
|
||||
-> DataCon -- ^ The data con to build
|
||||
-> [Type] -- ^ Type arguments for the data con
|
||||
-> RuleM (LHsExpr GhcPs)
|
||||
-> RuleM (Trace, LHsExpr GhcPs)
|
||||
buildDataCon jdg dc apps = do
|
||||
let args = dataConInstOrigArgTys' dc apps
|
||||
sgs <- traverse (newSubgoal . flip withNewGoal jdg . CType) args
|
||||
(tr, sgs)
|
||||
<- fmap unzipTrace
|
||||
$ traverse ( \(arg, n) ->
|
||||
newSubgoal
|
||||
. filterSameTypeFromOtherPositions dc n
|
||||
. blacklistingDestruct
|
||||
. flip withNewGoal jdg
|
||||
$ CType arg
|
||||
) $ zip args [0..]
|
||||
pure
|
||||
. noLoc
|
||||
. foldl' (@@)
|
||||
(HsVar noExtField $ noLoc $ Unqual $ nameOccName $ dataConName dc)
|
||||
$ fmap unLoc sgs
|
||||
. (rose (show dc) $ pure tr,)
|
||||
$ mkCon dc sgs
|
||||
|
||||
|
||||
mkCon :: DataCon -> [LHsExpr GhcPs] -> LHsExpr GhcPs
|
||||
mkCon dcon (fmap unLoc -> args)
|
||||
| isTupleDataCon dcon =
|
||||
noLoc $ tuple args
|
||||
| dataConIsInfix dcon
|
||||
, (lhs : rhs : args') <- args =
|
||||
noLoc $ foldl' (@@) (op lhs (coerceName dcon_name) rhs) args'
|
||||
| otherwise =
|
||||
noLoc $ foldl' (@@) (bvar' $ occName $ dcon_name) args
|
||||
where
|
||||
dcon_name = dataConName dcon
|
||||
|
||||
|
||||
|
||||
coerceName :: HasOccName a => a -> RdrNameStr
|
||||
coerceName = fromString . occNameString . occName
|
||||
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -109,7 +212,9 @@ buildDataCon jdg dc apps = do
|
||||
var' :: Var a => OccName -> a
|
||||
var' = var . fromString . occNameString
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Like 'bvar', but works over standard GHC 'OccName's.
|
||||
bvar' :: BVar a => OccName -> a
|
||||
bvar' = bvar . fromString . occNameString
|
||||
|
||||
|
@ -6,20 +6,74 @@ module Ide.Plugin.Tactic.Context where
|
||||
import Bag
|
||||
import Control.Arrow
|
||||
import Control.Monad.Reader
|
||||
import Data.List
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Development.IDE.GHC.Compat
|
||||
import Ide.Plugin.Tactic.GHC (tacticsThetaTy)
|
||||
import Ide.Plugin.Tactic.Machinery (methodHypothesis)
|
||||
import Ide.Plugin.Tactic.Types
|
||||
import OccName
|
||||
import TcRnTypes
|
||||
import TcType (substTy, tcSplitSigmaTy)
|
||||
import Unify (tcUnifyTy)
|
||||
|
||||
|
||||
mkContext :: [(OccName, CType)] -> TcGblEnv -> Context
|
||||
mkContext locals
|
||||
= Context locals
|
||||
. fmap splitId
|
||||
mkContext locals tcg = Context
|
||||
{ ctxDefiningFuncs = locals
|
||||
, ctxModuleFuncs = fmap splitId
|
||||
. (getFunBindId =<<)
|
||||
. fmap unLoc
|
||||
. bagToList
|
||||
. tcg_binds
|
||||
$ tcg_binds tcg
|
||||
}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Find all of the class methods that exist from the givens in the context.
|
||||
contextMethodHypothesis :: Context -> Map OccName (HyInfo CType)
|
||||
contextMethodHypothesis ctx
|
||||
= M.fromList
|
||||
. excludeForbiddenMethods
|
||||
. join
|
||||
. concatMap
|
||||
( mapMaybe methodHypothesis
|
||||
. tacticsThetaTy
|
||||
. unCType
|
||||
)
|
||||
. mapMaybe (definedThetaType ctx)
|
||||
. fmap fst
|
||||
$ ctxDefiningFuncs ctx
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Many operations are defined in typeclasses for performance reasons, rather
|
||||
-- than being a true part of the class. This function filters out those, in
|
||||
-- order to keep our hypothesis space small.
|
||||
excludeForbiddenMethods :: [(OccName, a)] -> [(OccName, a)]
|
||||
excludeForbiddenMethods = filter (not . flip S.member forbiddenMethods . fst)
|
||||
where
|
||||
forbiddenMethods :: Set OccName
|
||||
forbiddenMethods = S.map mkVarOcc $ S.fromList
|
||||
[ -- monadfail
|
||||
"fail"
|
||||
]
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Given the name of a function that exists in 'ctxDefiningFuncs', get its
|
||||
-- theta type.
|
||||
definedThetaType :: Context -> OccName -> Maybe CType
|
||||
definedThetaType ctx name = do
|
||||
(_, CType mono) <- find ((== name) . fst) $ ctxDefiningFuncs ctx
|
||||
(_, CType poly) <- find ((== name) . fst) $ ctxModuleFuncs ctx
|
||||
let (_, _, poly') = tcSplitSigmaTy poly
|
||||
subst <- tcUnifyTy poly' mono
|
||||
pure $ CType $ substTy subst $ snd $ splitForAllTys poly
|
||||
|
||||
|
||||
splitId :: Id -> (OccName, CType)
|
||||
@ -34,8 +88,8 @@ getFunBindId (AbsBinds _ _ _ abes _ _ _)
|
||||
getFunBindId _ = []
|
||||
|
||||
|
||||
getCurrentDefinitions :: MonadReader Context m => m [OccName]
|
||||
getCurrentDefinitions = asks $ fmap fst . ctxDefiningFuncs
|
||||
getCurrentDefinitions :: MonadReader Context m => m [(OccName, CType)]
|
||||
getCurrentDefinitions = asks $ ctxDefiningFuncs
|
||||
|
||||
getModuleHypothesis :: MonadReader Context m => m [(OccName, CType)]
|
||||
getModuleHypothesis = asks ctxModuleFuncs
|
||||
|
@ -1,20 +1,55 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Ide.Plugin.Tactic.Debug
|
||||
( unsafeRender
|
||||
, unsafeRender'
|
||||
, traceM
|
||||
, traceShowId
|
||||
, trace
|
||||
, traceX
|
||||
, traceIdX
|
||||
, traceMX
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Control.Exception
|
||||
import Debug.Trace
|
||||
import DynFlags (unsafeGlobalDynFlags)
|
||||
import Outputable
|
||||
import Outputable hiding ((<>))
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 808
|
||||
import PlainPanic (PlainGhcException)
|
||||
type GHC_EXCEPTION = PlainGhcException
|
||||
#else
|
||||
import Panic (GhcException)
|
||||
type GHC_EXCEPTION = GhcException
|
||||
#endif
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Print something
|
||||
unsafeRender :: Outputable a => a -> String
|
||||
unsafeRender = unsafeRender' . ppr
|
||||
|
||||
unsafeRender' :: SDoc -> String
|
||||
unsafeRender' = showSDoc unsafeGlobalDynFlags
|
||||
|
||||
unsafeRender' :: SDoc -> String
|
||||
unsafeRender' sdoc = unsafePerformIO $ do
|
||||
let z = showSDoc unsafeGlobalDynFlags sdoc
|
||||
-- We might not have unsafeGlobalDynFlags (like during testing), in which
|
||||
-- case GHC panics. Instead of crashing, let's just fail to print.
|
||||
!res <- try @GHC_EXCEPTION $ evaluate $ deepseq z z
|
||||
pure $ either (const "<unsafeRender'>") id res
|
||||
{-# NOINLINE unsafeRender' #-}
|
||||
|
||||
traceMX :: (Monad m, Show a) => String -> a -> m ()
|
||||
traceMX str a = traceM $ mappend ("!!!" <> str <> ": ") $ show a
|
||||
|
||||
traceX :: (Show a) => String -> a -> b -> b
|
||||
traceX str a = trace (mappend ("!!!" <> str <> ": ") $ show a)
|
||||
|
||||
traceIdX :: (Show a) => String -> a -> a
|
||||
traceIdX str a = trace (mappend ("!!!" <> str <> ": ") $ show a) a
|
||||
|
||||
|
@ -1,11 +1,20 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Ide.Plugin.Tactic.GHC where
|
||||
|
||||
import Control.Monad.State
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Traversable
|
||||
import Development.IDE.GHC.Compat
|
||||
import Generics.SYB (mkT, everywhere)
|
||||
import Ide.Plugin.Tactic.Types
|
||||
import OccName
|
||||
import TcType
|
||||
import TyCoRep
|
||||
import TyCon
|
||||
import Type
|
||||
import TysWiredIn (intTyCon, floatTyCon, doubleTyCon, charTyCon)
|
||||
import Unique
|
||||
@ -40,8 +49,44 @@ cloneTyVar t =
|
||||
------------------------------------------------------------------------------
|
||||
-- | Is this a function type?
|
||||
isFunction :: Type -> Bool
|
||||
isFunction (tcSplitFunTys -> ((_:_), _)) = True
|
||||
isFunction _ = False
|
||||
isFunction (tacticsSplitFunTy -> (_, _, [], _)) = False
|
||||
isFunction _ = True
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Split a function, also splitting out its quantified variables and theta
|
||||
-- context.
|
||||
tacticsSplitFunTy :: Type -> ([TyVar], ThetaType, [Type], Type)
|
||||
tacticsSplitFunTy t
|
||||
= let (vars, theta, t') = tcSplitSigmaTy t
|
||||
(args, res) = tcSplitFunTys t'
|
||||
in (vars, theta, args, res)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Rip the theta context out of a regular type.
|
||||
tacticsThetaTy :: Type -> ThetaType
|
||||
tacticsThetaTy (tcSplitSigmaTy -> (_, theta, _)) = theta
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Instantiate all of the quantified type variables in a type with fresh
|
||||
-- skolems.
|
||||
freshTyvars :: MonadState TacticState m => Type -> m Type
|
||||
freshTyvars t = do
|
||||
let (tvs, _, _, _) = tacticsSplitFunTy t
|
||||
reps <- fmap M.fromList
|
||||
$ for tvs $ \tv -> do
|
||||
uniq <- freshUnique
|
||||
pure $ (tv, setTyVarUnique tv uniq)
|
||||
pure $
|
||||
everywhere
|
||||
(mkT $ \tv ->
|
||||
case M.lookup tv reps of
|
||||
Just tv' -> tv'
|
||||
Nothing -> tv
|
||||
) t
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Is this an algebraic type?
|
||||
@ -67,3 +112,39 @@ lambdaCaseable (splitFunTy_maybe -> Just (arg, res))
|
||||
= Just $ isJust $ algebraicTyCon res
|
||||
lambdaCaseable _ = Nothing
|
||||
|
||||
fromPatCompat :: PatCompat GhcTc -> Pat GhcTc
|
||||
#if __GLASGOW_HASKELL__ == 808
|
||||
type PatCompat pass = Pat pass
|
||||
fromPatCompat = id
|
||||
#else
|
||||
type PatCompat pass = LPat pass
|
||||
fromPatCompat = unLoc
|
||||
#endif
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Should make sure it's a fun bind
|
||||
pattern TopLevelRHS :: OccName -> [PatCompat GhcTc] -> LHsExpr GhcTc -> Match GhcTc (LHsExpr GhcTc)
|
||||
pattern TopLevelRHS name ps body <-
|
||||
Match _
|
||||
(FunRhs (L _ (occName -> name)) _ _)
|
||||
ps
|
||||
(GRHSs _
|
||||
[L _ (GRHS _ [] body)] _)
|
||||
|
||||
getPatName :: PatCompat GhcTc -> Maybe OccName
|
||||
getPatName (fromPatCompat -> p0) =
|
||||
case p0 of
|
||||
VarPat _ x -> Just $ occName $ unLoc x
|
||||
LazyPat _ p -> getPatName p
|
||||
AsPat _ x _ -> Just $ occName $ unLoc x
|
||||
ParPat _ p -> getPatName p
|
||||
BangPat _ p -> getPatName p
|
||||
ViewPat _ _ p -> getPatName p
|
||||
#if __GLASGOW_HASKELL__ >= 808
|
||||
SigPat _ p _ -> getPatName p
|
||||
#endif
|
||||
#if __GLASGOW_HASKELL__ == 808
|
||||
XPat p -> getPatName $ unLoc p
|
||||
#endif
|
||||
_ -> Nothing
|
||||
|
||||
|
@ -1,14 +1,47 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Ide.Plugin.Tactic.Judgements where
|
||||
module Ide.Plugin.Tactic.Judgements
|
||||
( blacklistingDestruct
|
||||
, unwhitelistingSplit
|
||||
, introducingLambda
|
||||
, introducingRecursively
|
||||
, introducingPat
|
||||
, jGoal
|
||||
, jHypothesis
|
||||
, jEntireHypothesis
|
||||
, jPatHypothesis
|
||||
, substJdg
|
||||
, unsetIsTopHole
|
||||
, filterSameTypeFromOtherPositions
|
||||
, isDestructBlacklisted
|
||||
, withNewGoal
|
||||
, jLocalHypothesis
|
||||
, isSplitWhitelisted
|
||||
, isPatternMatch
|
||||
, filterPosition
|
||||
, isTopHole
|
||||
, disallowing
|
||||
, mkFirstJudgement
|
||||
, hypothesisFromBindings
|
||||
, isTopLevel
|
||||
) where
|
||||
|
||||
import Control.Lens hiding (Context)
|
||||
import Data.Bool
|
||||
import Data.Char
|
||||
import Data.Coerce
|
||||
import Data.Generics.Product (field)
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import DataCon (DataCon)
|
||||
import Development.IDE.Spans.LocalBindings
|
||||
import Ide.Plugin.Tactic.Types
|
||||
import OccName
|
||||
@ -18,63 +51,273 @@ import Type
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Given a 'SrcSpan' and a 'Bindings', create a hypothesis.
|
||||
hypothesisFromBindings :: RealSrcSpan -> Bindings -> Map OccName CType
|
||||
hypothesisFromBindings :: RealSrcSpan -> Bindings -> Map OccName (HyInfo CType)
|
||||
hypothesisFromBindings span bs = buildHypothesis $ getLocalScope bs span
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Convert a @Set Id@ into a hypothesis.
|
||||
buildHypothesis :: [(Name, Maybe Type)] -> Map OccName CType
|
||||
buildHypothesis :: [(Name, Maybe Type)] -> Map OccName (HyInfo CType)
|
||||
buildHypothesis
|
||||
= M.fromList
|
||||
. mapMaybe go
|
||||
where
|
||||
go (occName -> occ, t)
|
||||
| Just ty <- t
|
||||
, isAlpha . head . occNameString $ occ = Just (occ, CType ty)
|
||||
, isAlpha . head . occNameString $ occ = Just (occ, HyInfo UserPrv $ CType ty)
|
||||
| otherwise = Nothing
|
||||
|
||||
|
||||
hasDestructed :: Judgement -> OccName -> Bool
|
||||
hasDestructed j n = S.member n $ _jDestructed j
|
||||
blacklistingDestruct :: Judgement -> Judgement
|
||||
blacklistingDestruct =
|
||||
field @"_jBlacklistDestruct" .~ True
|
||||
|
||||
|
||||
unwhitelistingSplit :: Judgement -> Judgement
|
||||
unwhitelistingSplit =
|
||||
field @"_jWhitelistSplit" .~ False
|
||||
|
||||
|
||||
isDestructBlacklisted :: Judgement -> Bool
|
||||
isDestructBlacklisted = _jBlacklistDestruct
|
||||
|
||||
|
||||
isSplitWhitelisted :: Judgement -> Bool
|
||||
isSplitWhitelisted = _jWhitelistSplit
|
||||
|
||||
destructing :: OccName -> Judgement -> Judgement
|
||||
destructing n jdg@Judgement{..} = jdg
|
||||
{ _jDestructed = _jDestructed <> S.singleton n
|
||||
}
|
||||
|
||||
withNewGoal :: a -> Judgement' a -> Judgement' a
|
||||
withNewGoal t jdg = jdg
|
||||
{ _jGoal = t
|
||||
}
|
||||
withNewGoal t = field @"_jGoal" .~ t
|
||||
|
||||
introducing :: [(OccName, a)] -> Judgement' a -> Judgement' a
|
||||
introducing ns jdg@Judgement{..} = jdg
|
||||
{ _jHypothesis = M.fromList ns <> _jHypothesis
|
||||
}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Pattern vals are currently tracked in jHypothesis, with an extra piece of data sitting around in jPatternVals.
|
||||
introducingPat :: [(OccName, a)] -> Judgement' a -> Judgement' a
|
||||
introducingPat ns jdg@Judgement{..} = jdg
|
||||
{ _jHypothesis = M.fromList ns <> _jHypothesis
|
||||
, _jPatternVals = S.fromList (fmap fst ns) <> _jPatternVals
|
||||
}
|
||||
-- | Helper function for implementing functions which introduce new hypotheses.
|
||||
introducing
|
||||
:: (Int -> Provenance) -- ^ A function from the position of the arg to its
|
||||
-- provenance.
|
||||
-> [(OccName, a)]
|
||||
-> Judgement' a
|
||||
-> Judgement' a
|
||||
introducing f ns =
|
||||
field @"_jHypothesis" <>~ M.fromList (zip [0..] ns <&>
|
||||
\(pos, (name, ty)) -> (name, HyInfo (f pos) ty))
|
||||
|
||||
|
||||
disallowing :: [OccName] -> Judgement' a -> Judgement' a
|
||||
disallowing ns jdg@Judgement{..} = jdg
|
||||
{ _jHypothesis = M.withoutKeys _jHypothesis $ S.fromList ns
|
||||
}
|
||||
------------------------------------------------------------------------------
|
||||
-- | Introduce bindings in the context of a lamba.
|
||||
introducingLambda
|
||||
:: Maybe OccName -- ^ The name of the top level function. For any other
|
||||
-- function, this should be 'Nothing'.
|
||||
-> [(OccName, a)]
|
||||
-> Judgement' a
|
||||
-> Judgement' a
|
||||
introducingLambda func = introducing $ \pos ->
|
||||
maybe UserPrv (\x -> TopLevelArgPrv x pos) func
|
||||
|
||||
jHypothesis :: Judgement' a -> Map OccName a
|
||||
jHypothesis = _jHypothesis
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Introduce a binding in a recursive context.
|
||||
introducingRecursively :: [(OccName, a)] -> Judgement' a -> Judgement' a
|
||||
introducingRecursively = introducing $ const RecursivePrv
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Check whether any of the given occnames are an ancestor of the term.
|
||||
hasPositionalAncestry
|
||||
:: Foldable t
|
||||
=> t OccName -- ^ Desired ancestors.
|
||||
-> Judgement
|
||||
-> OccName -- ^ Potential child
|
||||
-> Maybe Bool -- ^ Just True if the result is the oldest positional ancestor
|
||||
-- just false if it's a descendent
|
||||
-- otherwise nothing
|
||||
hasPositionalAncestry ancestors jdg name
|
||||
| not $ null ancestors
|
||||
= case any (== name) ancestors of
|
||||
True -> Just True
|
||||
False ->
|
||||
case M.lookup name $ jAncestryMap jdg of
|
||||
Just ancestry ->
|
||||
bool Nothing (Just False) $ any (flip S.member ancestry) ancestors
|
||||
Nothing -> Nothing
|
||||
| otherwise = Nothing
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Helper function for disallowing hypotheses that have the wrong ancestry.
|
||||
filterAncestry
|
||||
:: Foldable t
|
||||
=> t OccName
|
||||
-> DisallowReason
|
||||
-> Judgement
|
||||
-> Judgement
|
||||
filterAncestry ancestry reason jdg =
|
||||
disallowing reason (M.keys $ M.filterWithKey go $ jHypothesis jdg) jdg
|
||||
where
|
||||
go name _
|
||||
= not
|
||||
. isJust
|
||||
$ hasPositionalAncestry ancestry jdg name
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | @filter defn pos@ removes any hypotheses which are bound in @defn@ to
|
||||
-- a position other than @pos@. Any terms whose ancestry doesn't include @defn@
|
||||
-- remain.
|
||||
filterPosition :: OccName -> Int -> Judgement -> Judgement
|
||||
filterPosition defn pos jdg =
|
||||
filterAncestry (findPositionVal jdg defn pos) (WrongBranch pos) jdg
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Helper function for determining the ancestry list for 'filterPosition'.
|
||||
findPositionVal :: Judgement' a -> OccName -> Int -> Maybe OccName
|
||||
findPositionVal jdg defn pos = listToMaybe $ do
|
||||
-- It's important to inspect the entire hypothesis here, as we need to trace
|
||||
-- ancstry through potentially disallowed terms in the hypothesis.
|
||||
(name, hi) <- M.toList $ M.map (overProvenance expandDisallowed) $ jEntireHypothesis jdg
|
||||
case hi_provenance hi of
|
||||
TopLevelArgPrv defn' pos'
|
||||
| defn == defn'
|
||||
, pos == pos' -> pure name
|
||||
PatternMatchPrv pv
|
||||
| pv_scrutinee pv == Just defn
|
||||
, pv_position pv == pos -> pure name
|
||||
_ -> []
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Helper function for determining the ancestry list for
|
||||
-- 'filterSameTypeFromOtherPositions'.
|
||||
findDconPositionVals :: Judgement' a -> DataCon -> Int -> [OccName]
|
||||
findDconPositionVals jdg dcon pos = do
|
||||
(name, hi) <- M.toList $ jHypothesis jdg
|
||||
case hi_provenance hi of
|
||||
PatternMatchPrv pv
|
||||
| pv_datacon pv == Uniquely dcon
|
||||
, pv_position pv == pos -> pure name
|
||||
_ -> []
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Disallow any hypotheses who have the same type as anything bound by the
|
||||
-- given position for the datacon. Used to ensure recursive functions like
|
||||
-- 'fmap' preserve the relative ordering of their arguments by eliminating any
|
||||
-- other term which might match.
|
||||
filterSameTypeFromOtherPositions :: DataCon -> Int -> Judgement -> Judgement
|
||||
filterSameTypeFromOtherPositions dcon pos jdg =
|
||||
let hy = jHypothesis
|
||||
$ filterAncestry
|
||||
(findDconPositionVals jdg dcon pos)
|
||||
(WrongBranch pos)
|
||||
jdg
|
||||
tys = S.fromList $ fmap (hi_type . snd) $ M.toList hy
|
||||
to_remove =
|
||||
M.filter (flip S.member tys . hi_type) (jHypothesis jdg)
|
||||
M.\\ hy
|
||||
in disallowing Shadowed (M.keys to_remove) jdg
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Return the ancestry of a 'PatVal', or 'mempty' otherwise.
|
||||
getAncestry :: Judgement' a -> OccName -> Set OccName
|
||||
getAncestry jdg name =
|
||||
case M.lookup name $ jPatHypothesis jdg of
|
||||
Just pv -> pv_ancestry pv
|
||||
Nothing -> mempty
|
||||
|
||||
|
||||
jAncestryMap :: Judgement' a -> Map OccName (Set OccName)
|
||||
jAncestryMap jdg =
|
||||
flip M.map (jPatHypothesis jdg) pv_ancestry
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- TODO(sandy): THIS THING IS A BIG BIG HACK
|
||||
--
|
||||
-- Why? 'ctxDefiningFuncs' is _all_ of the functions currently beind defined
|
||||
-- (eg, we might be in a where block). The head of this list is not guaranteed
|
||||
-- to be the one we're interested in.
|
||||
extremelyStupid__definingFunction :: Context -> OccName
|
||||
extremelyStupid__definingFunction =
|
||||
fst . head . ctxDefiningFuncs
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Pattern vals are currently tracked in jHypothesis, with an extra piece of
|
||||
-- data sitting around in jPatternVals.
|
||||
introducingPat
|
||||
:: Maybe OccName
|
||||
-> DataCon
|
||||
-> [(OccName, a)]
|
||||
-> Judgement' a
|
||||
-> Judgement' a
|
||||
introducingPat scrutinee dc ns jdg
|
||||
= introducing (\pos ->
|
||||
PatternMatchPrv $
|
||||
PatVal
|
||||
scrutinee
|
||||
(maybe mempty
|
||||
(\scrut -> S.singleton scrut <> getAncestry jdg scrut)
|
||||
scrutinee)
|
||||
(Uniquely dc)
|
||||
pos
|
||||
) ns jdg
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Prevent some occnames from being used in the hypothesis. This will hide
|
||||
-- them from 'jHypothesis', but not from 'jEntireHypothesis'.
|
||||
disallowing :: DisallowReason -> [OccName] -> Judgement' a -> Judgement' a
|
||||
disallowing reason (S.fromList -> ns) =
|
||||
field @"_jHypothesis" %~ (M.mapWithKey $ \name hi ->
|
||||
case S.member name ns of
|
||||
True -> overProvenance (DisallowedPrv reason) hi
|
||||
False -> hi
|
||||
)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | The hypothesis, consisting of local terms and the ambient environment
|
||||
-- (impors and class methods.) Hides disallowed values.
|
||||
jHypothesis :: Judgement' a -> Map OccName (HyInfo a)
|
||||
jHypothesis = M.filter (not . isDisallowed . hi_provenance) . jEntireHypothesis
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | The whole hypothesis, including things disallowed.
|
||||
jEntireHypothesis :: Judgement' a -> Map OccName (HyInfo a)
|
||||
jEntireHypothesis = _jHypothesis
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Just the local hypothesis.
|
||||
jLocalHypothesis :: Judgement' a -> Map OccName (HyInfo a)
|
||||
jLocalHypothesis = M.filter (isLocalHypothesis . hi_provenance) . jHypothesis
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | If we're in a top hole, the name of the defining function.
|
||||
isTopHole :: Context -> Judgement' a -> Maybe OccName
|
||||
isTopHole ctx =
|
||||
bool Nothing (Just $ extremelyStupid__definingFunction ctx) . _jIsTopHole
|
||||
|
||||
|
||||
unsetIsTopHole :: Judgement' a -> Judgement' a
|
||||
unsetIsTopHole = field @"_jIsTopHole" .~ False
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Only the hypothesis members which are pattern vals
|
||||
jPatHypothesis :: Judgement' a -> Map OccName a
|
||||
jPatHypothesis jdg
|
||||
= M.restrictKeys (jHypothesis jdg) $ _jPatternVals jdg
|
||||
jPatHypothesis :: Judgement' a -> Map OccName PatVal
|
||||
jPatHypothesis = M.mapMaybe (getPatVal . hi_provenance) . jHypothesis
|
||||
|
||||
|
||||
getPatVal :: Provenance-> Maybe PatVal
|
||||
getPatVal prov =
|
||||
case prov of
|
||||
PatternMatchPrv pv -> Just pv
|
||||
_ -> Nothing
|
||||
|
||||
|
||||
jGoal :: Judgement' a -> a
|
||||
@ -84,6 +327,54 @@ jGoal = _jGoal
|
||||
substJdg :: TCvSubst -> Judgement -> Judgement
|
||||
substJdg subst = fmap $ coerce . substTy subst . coerce
|
||||
|
||||
mkFirstJudgement :: M.Map OccName CType -> Type -> Judgement' CType
|
||||
mkFirstJudgement hy = Judgement hy mempty mempty . CType
|
||||
|
||||
mkFirstJudgement
|
||||
:: M.Map OccName (HyInfo CType)
|
||||
-> Bool -- ^ are we in the top level rhs hole?
|
||||
-> Type
|
||||
-> Judgement' CType
|
||||
mkFirstJudgement hy top goal = Judgement
|
||||
{ _jHypothesis = hy
|
||||
, _jBlacklistDestruct = False
|
||||
, _jWhitelistSplit = True
|
||||
, _jIsTopHole = top
|
||||
, _jGoal = CType goal
|
||||
}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Is this a top level function binding?
|
||||
isTopLevel :: Provenance -> Bool
|
||||
isTopLevel TopLevelArgPrv{} = True
|
||||
isTopLevel _ = False
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Is this a local function argument, pattern match or user val?
|
||||
isLocalHypothesis :: Provenance -> Bool
|
||||
isLocalHypothesis UserPrv{} = True
|
||||
isLocalHypothesis PatternMatchPrv{} = True
|
||||
isLocalHypothesis TopLevelArgPrv{} = True
|
||||
isLocalHypothesis _ = False
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Is this a pattern match?
|
||||
isPatternMatch :: Provenance -> Bool
|
||||
isPatternMatch PatternMatchPrv{} = True
|
||||
isPatternMatch _ = False
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Was this term ever disallowed?
|
||||
isDisallowed :: Provenance -> Bool
|
||||
isDisallowed DisallowedPrv{} = True
|
||||
isDisallowed _ = False
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Eliminates 'DisallowedPrv' provenances.
|
||||
expandDisallowed :: Provenance -> Provenance
|
||||
expandDisallowed (DisallowedPrv _ prv) = expandDisallowed prv
|
||||
expandDisallowed prv = prv
|
||||
|
||||
|
37
plugins/tactics/src/Ide/Plugin/Tactic/KnownStrategies.hs
Normal file
37
plugins/tactics/src/Ide/Plugin/Tactic/KnownStrategies.hs
Normal file
@ -0,0 +1,37 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Ide.Plugin.Tactic.KnownStrategies where
|
||||
|
||||
import Control.Monad.Error.Class
|
||||
import Ide.Plugin.Tactic.Context (getCurrentDefinitions)
|
||||
import Ide.Plugin.Tactic.Tactics
|
||||
import Ide.Plugin.Tactic.Types
|
||||
import OccName (mkVarOcc)
|
||||
import Refinery.Tactic
|
||||
import Ide.Plugin.Tactic.Machinery (tracing)
|
||||
|
||||
|
||||
knownStrategies :: TacticsM ()
|
||||
knownStrategies = choice
|
||||
[ deriveFmap
|
||||
]
|
||||
|
||||
|
||||
known :: String -> TacticsM () -> TacticsM ()
|
||||
known name t = do
|
||||
getCurrentDefinitions >>= \case
|
||||
[(def, _)] | def == mkVarOcc name ->
|
||||
tracing ("known " <> name) t
|
||||
_ -> throwError NoApplicableTactic
|
||||
|
||||
|
||||
deriveFmap :: TacticsM ()
|
||||
deriveFmap = known "fmap" $ do
|
||||
try intros
|
||||
overAlgebraicTerms homo
|
||||
choice
|
||||
[ overFunctions apply >> auto' 2
|
||||
, assumption
|
||||
, recursion
|
||||
]
|
||||
|
@ -1,6 +1,8 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
@ -16,18 +18,28 @@ module Ide.Plugin.Tactic.Machinery
|
||||
( module Ide.Plugin.Tactic.Machinery
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad.Except (throwError)
|
||||
import Class (Class(classTyVars))
|
||||
import Control.Arrow
|
||||
import Control.Monad.Error.Class
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State (gets, modify)
|
||||
import Control.Monad.State (MonadState(..))
|
||||
import Control.Monad.State.Class (gets, modify)
|
||||
import Control.Monad.State.Strict (StateT (..))
|
||||
import Data.Bool (bool)
|
||||
import Data.Coerce
|
||||
import Data.Either
|
||||
import Data.List (intercalate, sortBy)
|
||||
import Data.Foldable
|
||||
import Data.Functor ((<&>))
|
||||
import Data.Generics (mkQ, everything, gcount)
|
||||
import Data.List (sortBy)
|
||||
import qualified Data.Map as M
|
||||
import Data.Ord (comparing, Down(..))
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Development.IDE.GHC.Compat
|
||||
import Ide.Plugin.Tactic.Judgements
|
||||
import Ide.Plugin.Tactic.Types
|
||||
import OccName (HasOccName(occName))
|
||||
import Refinery.ProofState
|
||||
import Refinery.Tactic
|
||||
import Refinery.Tactic.Internal
|
||||
@ -45,10 +57,12 @@ substCTy subst = coerce . substTy subst . coerce
|
||||
-- goal.
|
||||
newSubgoal
|
||||
:: Judgement
|
||||
-> RuleM (LHsExpr GhcPs)
|
||||
-> Rule
|
||||
newSubgoal j = do
|
||||
unifier <- gets ts_unifier
|
||||
subgoal $ substJdg unifier j
|
||||
subgoal
|
||||
$ substJdg unifier
|
||||
$ unsetIsTopHole j
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -58,76 +72,139 @@ runTactic
|
||||
:: Context
|
||||
-> Judgement
|
||||
-> TacticsM () -- ^ Tactic to use
|
||||
-> Either [TacticError] (LHsExpr GhcPs)
|
||||
-> Either [TacticError] RunTacticResults
|
||||
runTactic ctx jdg t =
|
||||
let skolems = tyCoVarsOfTypeWellScoped $ unCType $ jGoal jdg
|
||||
tacticState = mempty { ts_skolems = skolems }
|
||||
let skolems = S.fromList
|
||||
$ foldMap (tyCoVarsOfTypeWellScoped . unCType)
|
||||
$ (:) (jGoal jdg)
|
||||
$ fmap hi_type
|
||||
$ toList
|
||||
$ jHypothesis jdg
|
||||
unused_topvals = M.keysSet
|
||||
$ M.filter (isTopLevel . hi_provenance)
|
||||
$ jHypothesis jdg
|
||||
tacticState =
|
||||
defaultTacticState
|
||||
{ ts_skolems = skolems
|
||||
, ts_unused_top_vals = unused_topvals
|
||||
}
|
||||
in case partitionEithers
|
||||
. flip runReader ctx
|
||||
. unExtractM
|
||||
$ runTacticTWithState t jdg tacticState of
|
||||
(errs, []) -> Left $ errs
|
||||
(_, solns) -> do
|
||||
-- TODO(sandy): remove this trace sometime
|
||||
traceM $ intercalate "\n" $ fmap (unsafeRender . fst) $ solns
|
||||
case sortBy (comparing $ Down . uncurry scoreSolution . snd) solns of
|
||||
(res : _) -> Right $ fst res
|
||||
$ runTacticT t jdg tacticState of
|
||||
(errs, []) -> Left $ take 50 $ errs
|
||||
(_, fmap assoc23 -> solns) -> do
|
||||
let sorted =
|
||||
flip sortBy solns $ comparing $ \((_, ext), (jdg, holes)) ->
|
||||
Down $ scoreSolution ext jdg holes
|
||||
case sorted of
|
||||
(((tr, ext), _) : _) ->
|
||||
Right
|
||||
. RunTacticResults tr ext
|
||||
. reverse
|
||||
. fmap fst
|
||||
$ take 5 sorted
|
||||
-- guaranteed to not be empty
|
||||
_ -> Left []
|
||||
|
||||
|
||||
scoreSolution :: TacticState -> [Judgement] -> Int
|
||||
scoreSolution TacticState{..} holes
|
||||
-- TODO(sandy): should this be linear?
|
||||
= S.size ts_used_vals - length holes * 5
|
||||
assoc23 :: (a, b, c) -> (a, (b, c))
|
||||
assoc23 (a, b, c) = (a, (b, c))
|
||||
|
||||
|
||||
runTacticTWithState
|
||||
:: (MonadExtract ext m)
|
||||
=> TacticT jdg ext err s m ()
|
||||
-> jdg
|
||||
-> s
|
||||
-> m [Either err (ext, (s, [jdg]))]
|
||||
runTacticTWithState t j s = proofs' s $ fmap snd $ proofState t j
|
||||
tracePrim :: String -> Trace
|
||||
tracePrim = flip rose []
|
||||
|
||||
|
||||
proofs'
|
||||
:: (MonadExtract ext m)
|
||||
=> s
|
||||
-> ProofStateT ext ext err s m goal
|
||||
-> m [(Either err (ext, (s, [goal])))]
|
||||
proofs' s p = go s [] p
|
||||
where
|
||||
go s goals (Subgoal goal k) = do
|
||||
h <- hole
|
||||
(go s (goals ++ [goal]) $ k h)
|
||||
go s goals (Effect m) = go s goals =<< m
|
||||
go s goals (Stateful f) =
|
||||
let (s', p) = f s
|
||||
in go s' goals p
|
||||
go s goals (Alt p1 p2) = liftA2 (<>) (go s goals p1) (go s goals p2)
|
||||
go s goals (Interleave p1 p2) = liftA2 (interleave) (go s goals p1) (go s goals p2)
|
||||
go _ _ Empty = pure []
|
||||
go _ _ (Failure err) = pure [throwError err]
|
||||
go s goals (Axiom ext) = pure [Right (ext, (s, goals))]
|
||||
tracing
|
||||
:: Functor m
|
||||
=> String
|
||||
-> TacticT jdg (Trace, ext) err s m a
|
||||
-> TacticT jdg (Trace, ext) err s m a
|
||||
tracing s (TacticT m)
|
||||
= TacticT $ StateT $ \jdg ->
|
||||
mapExtract' (first $ rose s . pure) $ runStateT m jdg
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | We need to make sure that we don't try to unify any skolems.
|
||||
-- To see why, consider the case:
|
||||
-- | Recursion is allowed only when we can prove it is on a structurally
|
||||
-- smaller argument. The top of the 'ts_recursion_stack' witnesses the smaller
|
||||
-- pattern val.
|
||||
guardStructurallySmallerRecursion
|
||||
:: TacticState
|
||||
-> Maybe TacticError
|
||||
guardStructurallySmallerRecursion s =
|
||||
case head $ ts_recursion_stack s of
|
||||
Just _ -> Nothing
|
||||
Nothing -> Just NoProgress
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Mark that the current recursive call is structurally smaller, due to
|
||||
-- having been matched on a pattern value.
|
||||
--
|
||||
-- uhh :: (Int -> Int) -> a
|
||||
-- uhh f = _
|
||||
-- Implemented by setting the top of the 'ts_recursion_stack'.
|
||||
markStructuralySmallerRecursion :: MonadState TacticState m => PatVal -> m ()
|
||||
markStructuralySmallerRecursion pv = do
|
||||
modify $ withRecursionStack $ \case
|
||||
(_ : bs) -> Just pv : bs
|
||||
[] -> []
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Given the results of running a tactic, score the solutions by
|
||||
-- desirability.
|
||||
--
|
||||
-- If we were to apply 'f', then we would try to unify 'Int' and 'a'.
|
||||
-- This is fine from the perspective of 'tcUnifyTy', but will cause obvious
|
||||
-- type errors in our use case. Therefore, we need to ensure that our
|
||||
-- 'TCvSubst' doesn't try to unify skolems.
|
||||
checkSkolemUnification :: CType -> CType -> TCvSubst -> RuleM ()
|
||||
checkSkolemUnification t1 t2 subst = do
|
||||
skolems <- gets ts_skolems
|
||||
unless (all (flip notElemTCvSubst subst) skolems) $
|
||||
throwError (UnificationError t1 t2)
|
||||
-- TODO(sandy): This function is completely unprincipled and was just hacked
|
||||
-- together to produce the right test results.
|
||||
scoreSolution
|
||||
:: LHsExpr GhcPs
|
||||
-> TacticState
|
||||
-> [Judgement]
|
||||
-> ( Penalize Int -- number of holes
|
||||
, Reward Bool -- all bindings used
|
||||
, Penalize Int -- unused top-level bindings
|
||||
, Penalize Int -- number of introduced bindings
|
||||
, Reward Int -- number used bindings
|
||||
, Penalize Int -- number of recursive calls
|
||||
, Penalize Int -- size of extract
|
||||
)
|
||||
scoreSolution ext TacticState{..} holes
|
||||
= ( Penalize $ length holes
|
||||
, Reward $ S.null $ ts_intro_vals S.\\ ts_used_vals
|
||||
, Penalize $ S.size ts_unused_top_vals
|
||||
, Penalize $ S.size ts_intro_vals
|
||||
, Reward $ S.size ts_used_vals
|
||||
, Penalize $ ts_recursion_count
|
||||
, Penalize $ solutionSize ext
|
||||
)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Compute the number of 'LHsExpr' nodes; used as a rough metric for code
|
||||
-- size.
|
||||
solutionSize :: LHsExpr GhcPs -> Int
|
||||
solutionSize = everything (+) $ gcount $ mkQ False $ \case
|
||||
(_ :: LHsExpr GhcPs) -> True
|
||||
|
||||
|
||||
newtype Penalize a = Penalize a
|
||||
deriving (Eq, Ord, Show) via (Down a)
|
||||
|
||||
newtype Reward a = Reward a
|
||||
deriving (Eq, Ord, Show) via a
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Like 'tcUnifyTy', but takes a list of skolems to prevent unification of.
|
||||
tryUnifyUnivarsButNotSkolems :: Set TyVar -> CType -> CType -> Maybe TCvSubst
|
||||
tryUnifyUnivarsButNotSkolems skolems goal inst =
|
||||
case tcUnifyTysFG
|
||||
(bool BindMe Skolem . flip S.member skolems)
|
||||
[unCType inst]
|
||||
[unCType goal] of
|
||||
Unifiable subst -> pure subst
|
||||
_ -> Nothing
|
||||
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -135,10 +212,43 @@ checkSkolemUnification t1 t2 subst = do
|
||||
unify :: CType -- ^ The goal type
|
||||
-> CType -- ^ The type we are trying unify the goal type with
|
||||
-> RuleM ()
|
||||
unify goal inst =
|
||||
case tcUnifyTy (unCType inst) (unCType goal) of
|
||||
Just subst -> do
|
||||
checkSkolemUnification inst goal subst
|
||||
unify goal inst = do
|
||||
skolems <- gets ts_skolems
|
||||
case tryUnifyUnivarsButNotSkolems skolems goal inst of
|
||||
Just subst ->
|
||||
modify (\s -> s { ts_unifier = unionTCvSubst subst (ts_unifier s) })
|
||||
Nothing -> throwError (UnificationError inst goal)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Get the class methods of a 'PredType', correctly dealing with
|
||||
-- instantiation of quantified class types.
|
||||
methodHypothesis :: PredType -> Maybe [(OccName, HyInfo CType)]
|
||||
methodHypothesis ty = do
|
||||
(tc, apps) <- splitTyConApp_maybe ty
|
||||
cls <- tyConClass_maybe tc
|
||||
let methods = classMethods cls
|
||||
tvs = classTyVars cls
|
||||
subst = zipTvSubst tvs apps
|
||||
sc_methods <- fmap join
|
||||
$ traverse (methodHypothesis . substTy subst)
|
||||
$ classSCTheta cls
|
||||
pure $ mappend sc_methods $ methods <&> \method ->
|
||||
let (_, _, ty) = tcSplitSigmaTy $ idType method
|
||||
in ( occName method
|
||||
, HyInfo (ClassMethodPrv $ Uniquely cls) $ CType $ substTy subst ty
|
||||
)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run the given tactic iff the current hole contains no univars. Skolems and
|
||||
-- already decided univars are OK though.
|
||||
requireConcreteHole :: TacticsM a -> TacticsM a
|
||||
requireConcreteHole m = do
|
||||
jdg <- goal
|
||||
skolems <- gets ts_skolems
|
||||
let vars = S.fromList $ tyCoVarsOfTypeWellScoped $ unCType $ jGoal jdg
|
||||
case S.size $ vars S.\\ skolems of
|
||||
0 -> m
|
||||
_ -> throwError TooPolymorphic
|
||||
|
||||
|
@ -1,6 +1,10 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
@ -10,15 +14,18 @@ module Ide.Plugin.Tactic.Tactics
|
||||
, runTactic
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.Except (throwError)
|
||||
import Control.Monad.Reader.Class (MonadReader(ask))
|
||||
import Control.Monad.State.Class
|
||||
import Control.Monad.State.Strict (StateT(..), runStateT)
|
||||
import Data.Function
|
||||
import Data.Bool (bool)
|
||||
import Data.Foldable
|
||||
import Data.List
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as S
|
||||
import DataCon
|
||||
import Development.IDE.GHC.Compat
|
||||
import GHC.Exts
|
||||
import GHC.SourceGen.Expr
|
||||
@ -30,23 +37,17 @@ import Ide.Plugin.Tactic.Judgements
|
||||
import Ide.Plugin.Tactic.Machinery
|
||||
import Ide.Plugin.Tactic.Naming
|
||||
import Ide.Plugin.Tactic.Types
|
||||
import Name (occNameString)
|
||||
import Refinery.Tactic
|
||||
import Refinery.Tactic.Internal
|
||||
import TcType
|
||||
import Type hiding (Var)
|
||||
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Use something in the hypothesis to fill the hole.
|
||||
-- TODO(sandy): deprecate this
|
||||
assumption :: TacticsM ()
|
||||
assumption = rule $ \jdg -> do
|
||||
let hy = jHypothesis jdg
|
||||
g = jGoal jdg
|
||||
case find ((== g) . snd) $ toList hy of
|
||||
Just (v, _) -> pure $ noLoc $ var' v
|
||||
Nothing -> throwError $ GoalMismatch "assumption" g
|
||||
assumption = attemptOn allNames assume
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -55,35 +56,22 @@ assume :: OccName -> TacticsM ()
|
||||
assume name = rule $ \jdg -> do
|
||||
let g = jGoal jdg
|
||||
case M.lookup name $ jHypothesis jdg of
|
||||
Just ty ->
|
||||
case ty == jGoal jdg of
|
||||
True -> do
|
||||
Just (hi_type -> ty) -> do
|
||||
unify ty $ jGoal jdg
|
||||
for_ (M.lookup name $ jPatHypothesis jdg) markStructuralySmallerRecursion
|
||||
useOccName jdg name
|
||||
pure $ noLoc $ var' name
|
||||
False -> throwError $ GoalMismatch "assume" g
|
||||
pure $ (tracePrim $ "assume " <> occNameString name, ) $ noLoc $ var' name
|
||||
Nothing -> throwError $ UndefinedHypothesis name
|
||||
|
||||
|
||||
useOccName :: MonadState TacticState m => Judgement -> OccName -> m ()
|
||||
useOccName jdg name =
|
||||
case M.lookup name $ jHypothesis jdg of
|
||||
Just{} -> modify $ withUsedVals $ S.insert name
|
||||
Nothing -> pure ()
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Introduce a lambda.
|
||||
intro :: TacticsM ()
|
||||
intro = rule $ \jdg -> do
|
||||
let hy = jHypothesis jdg
|
||||
g = jGoal jdg
|
||||
case splitFunTy_maybe $ unCType g of
|
||||
Just (a, b) -> do
|
||||
v <- pure $ mkGoodName (getInScope hy) a
|
||||
let jdg' = introducing [(v, CType a)] $ withNewGoal (CType b) jdg
|
||||
sg <- newSubgoal jdg'
|
||||
pure $ noLoc $ lambda [bvar' v] $ unLoc sg
|
||||
_ -> throwError $ GoalMismatch "intro" g
|
||||
recursion :: TacticsM ()
|
||||
recursion = requireConcreteHole $ tracing "recursion" $ do
|
||||
defs <- getCurrentDefinitions
|
||||
attemptOn (const $ fmap fst defs) $ \name -> do
|
||||
modify $ pushRecursionStack . countRecursiveCall
|
||||
ensure guardStructurallySmallerRecursion popRecursionStack $ do
|
||||
(localTactic (apply name) $ introducingRecursively defs)
|
||||
<@> fmap (localTactic assumption . filterPosition name) [0..]
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -92,13 +80,19 @@ intros :: TacticsM ()
|
||||
intros = rule $ \jdg -> do
|
||||
let hy = jHypothesis jdg
|
||||
g = jGoal jdg
|
||||
ctx <- ask
|
||||
case tcSplitFunTys $ unCType g of
|
||||
([], _) -> throwError $ GoalMismatch "intro" g
|
||||
([], _) -> throwError $ GoalMismatch "intros" g
|
||||
(as, b) -> do
|
||||
vs <- mkManyGoodNames hy as
|
||||
let jdg' = introducing (zip vs $ coerce as) $ withNewGoal (CType b) jdg
|
||||
sg <- newSubgoal jdg'
|
||||
vs <- mkManyGoodNames (jEntireHypothesis jdg) as
|
||||
let top_hole = isTopHole ctx jdg
|
||||
jdg' = introducingLambda top_hole (zip vs $ coerce as)
|
||||
$ withNewGoal (CType b) jdg
|
||||
modify $ withIntroducedVals $ mappend $ S.fromList vs
|
||||
when (isJust top_hole) $ addUnusedTopVals $ S.fromList vs
|
||||
(tr, sg) <- newSubgoal jdg'
|
||||
pure
|
||||
. (rose ("intros {" <> intercalate ", " (fmap show vs) <> "}") $ pure tr, )
|
||||
. noLoc
|
||||
. lambda (fmap bvar' vs)
|
||||
$ unLoc sg
|
||||
@ -106,71 +100,140 @@ intros = rule $ \jdg -> do
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Case split, and leave holes in the matches.
|
||||
destruct :: OccName -> TacticsM ()
|
||||
destruct name = do
|
||||
destructAuto :: OccName -> TacticsM ()
|
||||
destructAuto name = requireConcreteHole $ tracing "destruct(auto)" $ do
|
||||
jdg <- goal
|
||||
case hasDestructed jdg name of
|
||||
True -> throwError $ AlreadyDestructed name
|
||||
False -> rule $ \jdg -> destruct' (const subgoal) name jdg
|
||||
case M.lookup name $ jHypothesis jdg of
|
||||
Nothing -> throwError $ NotInScope name
|
||||
Just hi ->
|
||||
let subtactic = rule $ destruct' (const subgoal) name
|
||||
in case isPatternMatch $ hi_provenance hi of
|
||||
True ->
|
||||
pruning subtactic $ \jdgs ->
|
||||
let getHyTypes = S.fromList . fmap (hi_type . snd) . M.toList . jHypothesis
|
||||
new_hy = foldMap getHyTypes jdgs
|
||||
old_hy = getHyTypes jdg
|
||||
in case S.null $ new_hy S.\\ old_hy of
|
||||
True -> Just $ UnhelpfulDestruct name
|
||||
False -> Nothing
|
||||
False -> subtactic
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Case split, and leave holes in the matches.
|
||||
destruct :: OccName -> TacticsM ()
|
||||
destruct name = requireConcreteHole $ tracing "destruct(user)" $
|
||||
rule $ destruct' (const subgoal) name
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Case split, using the same data constructor in the matches.
|
||||
homo :: OccName -> TacticsM ()
|
||||
homo = rule . destruct' (\dc jdg ->
|
||||
homo = requireConcreteHole . tracing "homo" . rule . destruct' (\dc jdg ->
|
||||
buildDataCon jdg dc $ snd $ splitAppTys $ unCType $ jGoal jdg)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | LambdaCase split, and leave holes in the matches.
|
||||
destructLambdaCase :: TacticsM ()
|
||||
destructLambdaCase = rule $ destructLambdaCase' (const subgoal)
|
||||
destructLambdaCase = tracing "destructLambdaCase" $ rule $ destructLambdaCase' (const subgoal)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | LambdaCase split, using the same data constructor in the matches.
|
||||
homoLambdaCase :: TacticsM ()
|
||||
homoLambdaCase = rule $ destructLambdaCase' (\dc jdg ->
|
||||
buildDataCon jdg dc $ snd $ splitAppTys $ unCType $ jGoal jdg)
|
||||
homoLambdaCase =
|
||||
tracing "homoLambdaCase" $
|
||||
rule $ destructLambdaCase' $ \dc jdg ->
|
||||
buildDataCon jdg dc
|
||||
. snd
|
||||
. splitAppTys
|
||||
. unCType
|
||||
$ jGoal jdg
|
||||
|
||||
|
||||
apply' :: OccName -> TacticsM ()
|
||||
apply' func = rule $ \jdg -> do
|
||||
apply :: OccName -> TacticsM ()
|
||||
apply func = requireConcreteHole $ tracing ("apply' " <> show func) $ do
|
||||
jdg <- goal
|
||||
let hy = jHypothesis jdg
|
||||
g = jGoal jdg
|
||||
case M.lookup func hy of
|
||||
Just (CType ty) -> do
|
||||
let (args, ret) = splitFunTys ty
|
||||
Just (hi_type -> CType ty) -> do
|
||||
ty' <- freshTyvars ty
|
||||
let (_, _, args, ret) = tacticsSplitFunTy ty'
|
||||
requireNewHoles $ rule $ \jdg -> do
|
||||
unify g (CType ret)
|
||||
sgs <- traverse (newSubgoal . flip withNewGoal jdg . CType) args
|
||||
pure . noLoc
|
||||
useOccName jdg func
|
||||
(tr, sgs)
|
||||
<- fmap unzipTrace
|
||||
$ traverse ( newSubgoal
|
||||
. blacklistingDestruct
|
||||
. flip withNewGoal jdg
|
||||
. CType
|
||||
) args
|
||||
pure
|
||||
. (tr, )
|
||||
. noLoc
|
||||
. foldl' (@@) (var' func)
|
||||
$ fmap unLoc sgs
|
||||
Nothing -> throwError $ GoalMismatch "apply" g
|
||||
Nothing -> do
|
||||
throwError $ GoalMismatch "apply" g
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Choose between each of the goal's data constructors.
|
||||
split :: TacticsM ()
|
||||
split = do
|
||||
split = tracing "split(user)" $ do
|
||||
jdg <- goal
|
||||
let g = jGoal jdg
|
||||
case splitTyConApp_maybe $ unCType g of
|
||||
Nothing -> throwError $ GoalMismatch "getGoalTyCon" g
|
||||
Nothing -> throwError $ GoalMismatch "split" g
|
||||
Just (tc, _) -> do
|
||||
let dcs = tyConDataCons tc
|
||||
choice $ fmap splitDataCon dcs
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Choose between each of the goal's data constructors. Different than
|
||||
-- 'split' because it won't split a data con if it doesn't result in any new
|
||||
-- goals.
|
||||
splitAuto :: TacticsM ()
|
||||
splitAuto = requireConcreteHole $ tracing "split(auto)" $ do
|
||||
jdg <- goal
|
||||
let g = jGoal jdg
|
||||
case splitTyConApp_maybe $ unCType g of
|
||||
Nothing -> throwError $ GoalMismatch "split" g
|
||||
Just (tc, _) -> do
|
||||
let dcs = tyConDataCons tc
|
||||
case isSplitWhitelisted jdg of
|
||||
True -> choice $ fmap splitDataCon dcs
|
||||
False -> do
|
||||
choice $ flip fmap dcs $ \dc -> requireNewHoles $
|
||||
splitDataCon dc
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Allow the given tactic to proceed if and only if it introduces holes that
|
||||
-- have a different goal than current goal.
|
||||
requireNewHoles :: TacticsM () -> TacticsM ()
|
||||
requireNewHoles m = do
|
||||
jdg <- goal
|
||||
pruning m $ \jdgs ->
|
||||
case null jdgs || any (/= jGoal jdg) (fmap jGoal jdgs) of
|
||||
True -> Nothing
|
||||
False -> Just NoProgress
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Attempt to instantiate the given data constructor to solve the goal.
|
||||
splitDataCon :: DataCon -> TacticsM ()
|
||||
splitDataCon dc = rule $ \jdg -> do
|
||||
splitDataCon dc =
|
||||
requireConcreteHole $ tracing ("splitDataCon:" <> show dc) $ rule $ \jdg -> do
|
||||
let g = jGoal jdg
|
||||
case splitTyConApp_maybe $ unCType g of
|
||||
Just (tc, apps) -> do
|
||||
case elem dc $ tyConDataCons tc of
|
||||
True -> buildDataCon jdg dc apps
|
||||
True -> buildDataCon (unwhitelistingSplit jdg) dc apps
|
||||
False -> throwError $ IncorrectDataCon dc
|
||||
Nothing -> throwError $ GoalMismatch "splitDataCon" g
|
||||
|
||||
@ -186,41 +249,37 @@ attemptOn :: (Judgement -> [a]) -> (a -> TacticsM ()) -> TacticsM ()
|
||||
attemptOn getNames tac = matching (choice . fmap (\s -> tac s) . getNames)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Automatically solve a goal.
|
||||
auto :: TacticsM ()
|
||||
auto = do
|
||||
current <- getCurrentDefinitions
|
||||
localTactic :: TacticsM a -> (Judgement -> Judgement) -> TacticsM a
|
||||
localTactic t f = do
|
||||
TacticT $ StateT $ \jdg ->
|
||||
runStateT (unTacticT $ auto' 5) $ disallowing current jdg
|
||||
runStateT (unTacticT t) $ f jdg
|
||||
|
||||
|
||||
auto' :: Int -> TacticsM ()
|
||||
auto' 0 = throwError NoProgress
|
||||
auto' n = do
|
||||
let loop = auto' (n - 1)
|
||||
intros <|> many_ intro
|
||||
try intros
|
||||
choice
|
||||
[ attemptOn functionNames $ \fname -> do
|
||||
apply' fname
|
||||
[ overFunctions $ \fname -> do
|
||||
apply fname
|
||||
loop
|
||||
, attemptOn algebraicNames $ \aname -> do
|
||||
progress ((==) `on` jGoal) NoProgress (destruct aname)
|
||||
loop
|
||||
, split >> loop
|
||||
, attemptOn allNames $ \name -> do
|
||||
assume name
|
||||
, overAlgebraicTerms $ \aname -> do
|
||||
destructAuto aname
|
||||
loop
|
||||
, splitAuto >> loop
|
||||
, assumption >> loop
|
||||
, recursion
|
||||
]
|
||||
|
||||
overFunctions :: (OccName -> TacticsM ()) -> TacticsM ()
|
||||
overFunctions =
|
||||
attemptOn $ M.keys . M.filter (isFunction . unCType . hi_type) . jHypothesis
|
||||
|
||||
functionNames :: Judgement -> [OccName]
|
||||
functionNames =
|
||||
M.keys . M.filter (isFunction . unCType) . jHypothesis
|
||||
|
||||
|
||||
algebraicNames :: Judgement -> [OccName]
|
||||
algebraicNames =
|
||||
M.keys . M.filter (isJust . algebraicTyCon . unCType) . jHypothesis
|
||||
overAlgebraicTerms :: (OccName -> TacticsM ()) -> TacticsM ()
|
||||
overAlgebraicTerms =
|
||||
attemptOn $
|
||||
M.keys . M.filter (isJust . algebraicTyCon . unCType . hi_type) . jHypothesis
|
||||
|
||||
|
||||
allNames :: Judgement -> [OccName]
|
||||
|
@ -1,3 +1,7 @@
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
@ -5,6 +9,7 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Ide.Plugin.Tactic.Types
|
||||
( module Ide.Plugin.Tactic.Types
|
||||
@ -17,17 +22,26 @@ module Ide.Plugin.Tactic.Types
|
||||
, Range
|
||||
) where
|
||||
|
||||
import Control.Lens hiding (Context)
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
import Data.Coerce
|
||||
import Data.Function
|
||||
import Data.Generics.Product (field)
|
||||
import Data.Map (Map)
|
||||
import Data.Set (Set)
|
||||
import Development.IDE.GHC.Compat
|
||||
import Data.Tree
|
||||
import Development.IDE.GHC.Compat hiding (Node)
|
||||
import Development.IDE.GHC.Orphans ()
|
||||
import Development.IDE.Types.Location
|
||||
import GHC.Generics
|
||||
import Ide.Plugin.Tactic.Debug
|
||||
import OccName
|
||||
import Refinery.Tactic
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import Type
|
||||
import UniqSupply (takeUniqFromSupply, mkSplitUniqSupply, UniqSupply)
|
||||
import Unique (nonDetCmpUnique, Uniquable, getUnique, Unique)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -40,42 +54,194 @@ instance Eq CType where
|
||||
instance Ord CType where
|
||||
compare = nonDetCmpType `on` unCType
|
||||
|
||||
instance Show CType where
|
||||
show = unsafeRender . unCType
|
||||
|
||||
instance Show OccName where
|
||||
show = unsafeRender
|
||||
|
||||
instance Show Var where
|
||||
show = unsafeRender
|
||||
|
||||
instance Show TCvSubst where
|
||||
show = unsafeRender
|
||||
|
||||
instance Show DataCon where
|
||||
show = unsafeRender
|
||||
|
||||
instance Show Class where
|
||||
show = unsafeRender
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
data TacticState = TacticState
|
||||
{ ts_skolems :: !([TyVar])
|
||||
{ ts_skolems :: !(Set TyVar)
|
||||
-- ^ The known skolems.
|
||||
, ts_unifier :: !(TCvSubst)
|
||||
-- ^ The current substitution of univars.
|
||||
, ts_used_vals :: !(Set OccName)
|
||||
-- ^ Set of values used by tactics.
|
||||
, ts_intro_vals :: !(Set OccName)
|
||||
-- ^ Set of values introduced by tactics.
|
||||
, ts_unused_top_vals :: !(Set OccName)
|
||||
-- ^ Set of currently unused arguments to the function being defined.
|
||||
, ts_recursion_stack :: ![Maybe PatVal]
|
||||
-- ^ Stack for tracking whether or not the current recursive call has
|
||||
-- used at least one smaller pat val. Recursive calls for which this
|
||||
-- value is 'False' are guaranteed to loop, and must be pruned.
|
||||
, ts_recursion_count :: !Int
|
||||
-- ^ Number of calls to recursion. We penalize each.
|
||||
, ts_unique_gen :: !UniqSupply
|
||||
} deriving stock (Show, Generic)
|
||||
|
||||
instance Show UniqSupply where
|
||||
show _ = "<uniqsupply>"
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A 'UniqSupply' to use in 'defaultTacticState'
|
||||
unsafeDefaultUniqueSupply :: UniqSupply
|
||||
unsafeDefaultUniqueSupply =
|
||||
unsafePerformIO $ mkSplitUniqSupply '🚒'
|
||||
{-# NOINLINE unsafeDefaultUniqueSupply #-}
|
||||
|
||||
|
||||
defaultTacticState :: TacticState
|
||||
defaultTacticState =
|
||||
TacticState
|
||||
{ ts_skolems = mempty
|
||||
, ts_unifier = emptyTCvSubst
|
||||
, ts_used_vals = mempty
|
||||
, ts_intro_vals = mempty
|
||||
, ts_unused_top_vals = mempty
|
||||
, ts_recursion_stack = mempty
|
||||
, ts_recursion_count = 0
|
||||
, ts_unique_gen = unsafeDefaultUniqueSupply
|
||||
}
|
||||
|
||||
instance Semigroup TacticState where
|
||||
TacticState a1 b1 c1 <> TacticState a2 b2 c2
|
||||
= TacticState
|
||||
(a1 <> a2)
|
||||
(unionTCvSubst b1 b2)
|
||||
(c1 <> c2)
|
||||
|
||||
instance Monoid TacticState where
|
||||
mempty = TacticState mempty emptyTCvSubst mempty
|
||||
------------------------------------------------------------------------------
|
||||
-- | Generate a new 'Unique'
|
||||
freshUnique :: MonadState TacticState m => m Unique
|
||||
freshUnique = do
|
||||
(uniq, supply) <- gets $ takeUniqFromSupply . ts_unique_gen
|
||||
modify' $! field @"ts_unique_gen" .~ supply
|
||||
pure uniq
|
||||
|
||||
|
||||
withRecursionStack
|
||||
:: ([Maybe PatVal] -> [Maybe PatVal]) -> TacticState -> TacticState
|
||||
withRecursionStack f =
|
||||
field @"ts_recursion_stack" %~ f
|
||||
|
||||
pushRecursionStack :: TacticState -> TacticState
|
||||
pushRecursionStack = withRecursionStack (Nothing :)
|
||||
|
||||
popRecursionStack :: TacticState -> TacticState
|
||||
popRecursionStack = withRecursionStack tail
|
||||
|
||||
|
||||
withUsedVals :: (Set OccName -> Set OccName) -> TacticState -> TacticState
|
||||
withUsedVals f ts = ts
|
||||
{ ts_used_vals = f $ ts_used_vals ts
|
||||
withUsedVals f =
|
||||
field @"ts_used_vals" %~ f
|
||||
|
||||
|
||||
withIntroducedVals :: (Set OccName -> Set OccName) -> TacticState -> TacticState
|
||||
withIntroducedVals f =
|
||||
field @"ts_intro_vals" %~ f
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Describes where hypotheses came from. Used extensively to prune stupid
|
||||
-- solutions from the search space.
|
||||
data Provenance
|
||||
= -- | An argument given to the topmost function that contains the current
|
||||
-- hole. Recursive calls are restricted to values whose provenance lines up
|
||||
-- with the same argument.
|
||||
TopLevelArgPrv
|
||||
OccName -- ^ Binding function
|
||||
Int -- ^ Argument Position
|
||||
-- | A binding created in a pattern match.
|
||||
| PatternMatchPrv PatVal
|
||||
-- | A class method from the given context.
|
||||
| ClassMethodPrv
|
||||
(Uniquely Class) -- ^ Class
|
||||
-- | A binding explicitly written by the user.
|
||||
| UserPrv
|
||||
-- | The recursive hypothesis. Present only in the context of the recursion
|
||||
-- tactic.
|
||||
| RecursivePrv
|
||||
-- | A hypothesis which has been disallowed for some reason. It's important
|
||||
-- to keep these in the hypothesis set, rather than filtering it, in order
|
||||
-- to continue tracking downstream provenance.
|
||||
| DisallowedPrv DisallowReason Provenance
|
||||
deriving stock (Eq, Show, Generic, Ord)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Why was a hypothesis disallowed?
|
||||
data DisallowReason
|
||||
= WrongBranch Int
|
||||
| Shadowed
|
||||
| RecursiveCall
|
||||
| AlreadyDestructed
|
||||
deriving stock (Eq, Show, Generic, Ord)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Provenance of a pattern value.
|
||||
data PatVal = PatVal
|
||||
{ pv_scrutinee :: Maybe OccName
|
||||
-- ^ Original scrutinee which created this PatVal. Nothing, for lambda
|
||||
-- case.
|
||||
, pv_ancestry :: Set OccName
|
||||
-- ^ The set of values which had to be destructed to discover this term.
|
||||
-- Always contains the scrutinee.
|
||||
, pv_datacon :: Uniquely DataCon
|
||||
-- ^ The datacon which introduced this term.
|
||||
, pv_position :: Int
|
||||
-- ^ The position of this binding in the datacon's arguments.
|
||||
} deriving stock (Eq, Show, Generic, Ord)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A wrapper which uses a 'Uniquable' constraint for providing 'Eq' and 'Ord'
|
||||
-- instances.
|
||||
newtype Uniquely a = Uniquely { getViaUnique :: a }
|
||||
deriving Show via a
|
||||
|
||||
instance Uniquable a => Eq (Uniquely a) where
|
||||
(==) = (==) `on` getUnique . getViaUnique
|
||||
|
||||
instance Uniquable a => Ord (Uniquely a) where
|
||||
compare = nonDetCmpUnique `on` getUnique . getViaUnique
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | The provenance and type of a hypothesis term.
|
||||
data HyInfo a = HyInfo
|
||||
{ hi_provenance :: Provenance
|
||||
, hi_type :: a
|
||||
}
|
||||
deriving stock (Functor, Eq, Show, Generic, Ord)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Map a function over the provenance.
|
||||
overProvenance :: (Provenance -> Provenance) -> HyInfo a -> HyInfo a
|
||||
overProvenance f (HyInfo prv ty) = HyInfo (f prv) ty
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | The current bindings and goal for a hole to be filled by refinery.
|
||||
data Judgement' a = Judgement
|
||||
{ _jHypothesis :: !(Map OccName a)
|
||||
, _jDestructed :: !(Set OccName)
|
||||
-- ^ These should align with keys of _jHypothesis
|
||||
, _jPatternVals :: !(Set OccName)
|
||||
-- ^ These should align with keys of _jHypothesis
|
||||
{ _jHypothesis :: !(Map OccName (HyInfo a))
|
||||
, _jBlacklistDestruct :: !(Bool)
|
||||
, _jWhitelistSplit :: !(Bool)
|
||||
, _jIsTopHole :: !Bool
|
||||
, _jGoal :: !(a)
|
||||
}
|
||||
deriving stock (Eq, Ord, Generic, Functor)
|
||||
deriving stock (Eq, Generic, Functor, Show)
|
||||
|
||||
type Judgement = Judgement' CType
|
||||
|
||||
@ -85,8 +251,8 @@ newtype ExtractM a = ExtractM { unExtractM :: Reader Context a }
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Orphan instance for producing holes when attempting to solve tactics.
|
||||
instance MonadExtract (LHsExpr GhcPs) ExtractM where
|
||||
hole = pure $ noLoc $ HsVar noExtField $ noLoc $ Unqual $ mkVarOcc "_"
|
||||
instance MonadExtract (Trace, LHsExpr GhcPs) ExtractM where
|
||||
hole = pure (mempty, noLoc $ HsVar noExtField $ noLoc $ Unqual $ mkVarOcc "_")
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -98,8 +264,12 @@ data TacticError
|
||||
| UnificationError CType CType
|
||||
| NoProgress
|
||||
| NoApplicableTactic
|
||||
| AlreadyDestructed OccName
|
||||
| IncorrectDataCon DataCon
|
||||
| RecursionOnWrongParam OccName Int OccName
|
||||
| UnhelpfulDestruct OccName
|
||||
| UnhelpfulSplit OccName
|
||||
| TooPolymorphic
|
||||
| NotInScope OccName
|
||||
deriving stock (Eq)
|
||||
|
||||
instance Show TacticError where
|
||||
@ -125,16 +295,27 @@ instance Show TacticError where
|
||||
"Unable to make progress"
|
||||
show NoApplicableTactic =
|
||||
"No tactic could be applied"
|
||||
show (AlreadyDestructed name) =
|
||||
"Already destructed " <> unsafeRender name
|
||||
show (IncorrectDataCon dcon) =
|
||||
"Data con doesn't align with goal type (" <> unsafeRender dcon <> ")"
|
||||
show (RecursionOnWrongParam call p arg) =
|
||||
"Recursion on wrong param (" <> show call <> ") on arg"
|
||||
<> show p <> ": " <> show arg
|
||||
show (UnhelpfulDestruct n) =
|
||||
"Destructing patval " <> show n <> " leads to no new types"
|
||||
show (UnhelpfulSplit n) =
|
||||
"Splitting constructor " <> show n <> " leads to no new goals"
|
||||
show TooPolymorphic =
|
||||
"The tactic isn't applicable because the goal is too polymorphic"
|
||||
show (NotInScope name) =
|
||||
"Tried to do something with the out of scope name " <> show name
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
type TacticsM = TacticT Judgement (LHsExpr GhcPs) TacticError TacticState ExtractM
|
||||
type RuleM = RuleT Judgement (LHsExpr GhcPs) TacticError TacticState ExtractM
|
||||
type Rule = RuleM (LHsExpr GhcPs)
|
||||
type TacticsM = TacticT Judgement (Trace, LHsExpr GhcPs) TacticError TacticState ExtractM
|
||||
type RuleM = RuleT Judgement (Trace, LHsExpr GhcPs) TacticError TacticState ExtractM
|
||||
type Rule = RuleM (Trace, LHsExpr GhcPs)
|
||||
|
||||
type Trace = Rose String
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -147,3 +328,40 @@ data Context = Context
|
||||
}
|
||||
deriving stock (Eq, Ord)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | An empty context
|
||||
emptyContext :: Context
|
||||
emptyContext = Context mempty mempty
|
||||
|
||||
|
||||
newtype Rose a = Rose (Tree a)
|
||||
deriving stock (Eq, Functor, Generic)
|
||||
|
||||
instance Show (Rose String) where
|
||||
show = unlines . dropEveryOther . lines . drawTree . coerce
|
||||
|
||||
dropEveryOther :: [a] -> [a]
|
||||
dropEveryOther [] = []
|
||||
dropEveryOther [a] = [a]
|
||||
dropEveryOther (a : _ : as) = a : dropEveryOther as
|
||||
|
||||
instance Semigroup a => Semigroup (Rose a) where
|
||||
Rose (Node a as) <> Rose (Node b bs) = Rose $ Node (a <> b) (as <> bs)
|
||||
|
||||
instance Monoid a => Monoid (Rose a) where
|
||||
mempty = Rose $ Node mempty mempty
|
||||
|
||||
rose :: (Eq a, Monoid a) => a -> [Rose a] -> Rose a
|
||||
rose a [Rose (Node a' rs)] | a' == mempty = Rose $ Node a rs
|
||||
rose a rs = Rose $ Node a $ coerce rs
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | The results of 'Ide.Plugin.Tactic.Machinery.runTactic'
|
||||
data RunTacticResults = RunTacticResults
|
||||
{ rtr_trace :: Trace
|
||||
, rtr_extract :: LHsExpr GhcPs
|
||||
, rtr_other_solns :: [(Trace, LHsExpr GhcPs)]
|
||||
} deriving Show
|
||||
|
||||
|
@ -12,7 +12,6 @@ import BasicTypes (appPrec)
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Class
|
||||
import qualified Data.Text as T
|
||||
import Debug.Trace
|
||||
import Development.IDE.Core.RuleTypes
|
||||
import Development.IDE.Core.Rules
|
||||
import Development.IDE.Core.Shake
|
||||
@ -104,7 +103,7 @@ fixAnns ParsedModule {..} =
|
||||
annotate :: DynFlags -> LHsExpr GhcPs -> TransformT (Either String) (Anns, LHsExpr GhcPs)
|
||||
annotate dflags expr = do
|
||||
uniq <- show <$> uniqueSrcSpanT
|
||||
let rendered = traceId $ render dflags expr
|
||||
let rendered = render dflags expr
|
||||
(anns, expr') <- lift $ either (Left . show) Right $ parseExpr dflags uniq rendered
|
||||
let anns' = setPrecedingLines expr' 0 1 anns
|
||||
pure (anns', expr')
|
||||
|
57
plugins/tactics/test/AutoTupleSpec.hs
Normal file
57
plugins/tactics/test/AutoTupleSpec.hs
Normal file
@ -0,0 +1,57 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module AutoTupleSpec where
|
||||
|
||||
import Data.Either (isRight)
|
||||
import qualified Data.Map as M
|
||||
import Ide.Plugin.Tactic.Debug
|
||||
import Ide.Plugin.Tactic.Judgements (mkFirstJudgement)
|
||||
import Ide.Plugin.Tactic.Machinery
|
||||
import Ide.Plugin.Tactic.Tactics (auto')
|
||||
import Ide.Plugin.Tactic.Types
|
||||
import OccName (mkVarOcc)
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
import Type (mkTyVarTy)
|
||||
import TysPrim (alphaTyVars)
|
||||
import TysWiredIn (mkBoxedTupleTy)
|
||||
|
||||
|
||||
instance Show Type where
|
||||
show = unsafeRender
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "auto for tuple" $ do
|
||||
it "should always be able to discover an auto solution" $ do
|
||||
property $ do
|
||||
-- Pick some number of variables
|
||||
n <- choose (1, 7)
|
||||
let vars = fmap mkTyVarTy $ take n alphaTyVars
|
||||
-- Pick a random ordering
|
||||
in_vars <- shuffle vars
|
||||
-- Randomly associate them into tuple types
|
||||
in_type <- mkBoxedTupleTy
|
||||
. fmap mkBoxedTupleTy
|
||||
<$> randomGroups in_vars
|
||||
out_type <- mkBoxedTupleTy
|
||||
. fmap mkBoxedTupleTy
|
||||
<$> randomGroups vars
|
||||
pure $
|
||||
-- We should always be able to find a solution
|
||||
runTactic
|
||||
emptyContext
|
||||
(mkFirstJudgement
|
||||
(M.singleton (mkVarOcc "x") $ HyInfo UserPrv $ CType in_type)
|
||||
True
|
||||
out_type)
|
||||
(auto' $ n * 2) `shouldSatisfy` isRight
|
||||
|
||||
|
||||
randomGroups :: [a] -> Gen [[a]]
|
||||
randomGroups [] = pure []
|
||||
randomGroups as = do
|
||||
n <- choose (1, length as)
|
||||
(:) <$> pure (take n as)
|
||||
<*> randomGroups (drop n as)
|
||||
|
1
plugins/tactics/test/Main.hs
Normal file
1
plugins/tactics/test/Main.hs
Normal file
@ -0,0 +1 @@
|
||||
{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Main #-}
|
65
plugins/tactics/test/UnificationSpec.hs
Normal file
65
plugins/tactics/test/UnificationSpec.hs
Normal file
@ -0,0 +1,65 @@
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module UnificationSpec where
|
||||
|
||||
import Control.Arrow
|
||||
import Data.Bool (bool)
|
||||
import Data.Functor ((<&>))
|
||||
import Data.Maybe (mapMaybe)
|
||||
import qualified Data.Set as S
|
||||
import Data.Traversable
|
||||
import Data.Tuple (swap)
|
||||
import Ide.Plugin.Tactic.Debug
|
||||
import Ide.Plugin.Tactic.Machinery
|
||||
import Ide.Plugin.Tactic.Types
|
||||
import TcType (tcGetTyVar_maybe, substTy)
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
import Type (mkTyVarTy)
|
||||
import TysPrim (alphaTyVars)
|
||||
import TysWiredIn (mkBoxedTupleTy)
|
||||
|
||||
|
||||
instance Show Type where
|
||||
show = unsafeRender
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "unification" $ do
|
||||
it "should be able to unify univars with skolems on either side of the equality" $ do
|
||||
property $ do
|
||||
-- Pick some number of unification vars and skolem
|
||||
n <- choose (1, 1)
|
||||
let (skolems, take n -> univars) = splitAt n $ fmap mkTyVarTy alphaTyVars
|
||||
-- Randomly pair them
|
||||
skolem_uni_pairs <-
|
||||
for (zip skolems univars) randomSwap
|
||||
let (lhs, rhs)
|
||||
= mkBoxedTupleTy *** mkBoxedTupleTy
|
||||
$ unzip skolem_uni_pairs
|
||||
pure $
|
||||
counterexample (show skolems) $
|
||||
counterexample (show lhs) $
|
||||
counterexample (show rhs) $
|
||||
case tryUnifyUnivarsButNotSkolems
|
||||
(S.fromList $ mapMaybe tcGetTyVar_maybe skolems)
|
||||
(CType lhs)
|
||||
(CType rhs) of
|
||||
Just subst ->
|
||||
-- For each pair, running the unification over the univar should
|
||||
-- result in the skolem
|
||||
conjoin $ zip univars skolems <&> \(uni, skolem) ->
|
||||
let substd = substTy subst uni
|
||||
in counterexample (show substd) $
|
||||
counterexample (show skolem) $
|
||||
CType substd === CType skolem
|
||||
Nothing -> True === False
|
||||
|
||||
|
||||
randomSwap :: (a, a) -> Gen (a, a)
|
||||
randomSwap ab = do
|
||||
which <- arbitrary
|
||||
pure $ bool swap id which ab
|
||||
|
||||
|
@ -1,15 +1,17 @@
|
||||
resolver: nightly-2020-08-08
|
||||
resolver: nightly-2020-08-16 # Last 8.10.1
|
||||
|
||||
packages:
|
||||
- .
|
||||
- ./ghcide/hie-compat
|
||||
- ./ghcide/
|
||||
- ./hls-plugin-api
|
||||
- ./plugins/tactics
|
||||
- ./plugins/hls-hlint-plugin
|
||||
|
||||
ghc-options:
|
||||
"$everything": -haddock
|
||||
|
||||
extra-deps:
|
||||
- aeson-1.5.2.0
|
||||
- github: bubba/brittany
|
||||
commit: c59655f10d5ad295c2481537fc8abf0a297d9d1c
|
||||
- Cabal-3.0.2.0
|
||||
@ -17,18 +19,22 @@ extra-deps:
|
||||
- data-tree-print-0.1.0.2
|
||||
- floskell-0.10.4
|
||||
- fourmolu-0.2.0.0
|
||||
- ghc-lib-8.10.2.20200916
|
||||
- ghc-lib-parser-8.10.2.20200916
|
||||
- hie-bios-0.7.1
|
||||
- hlint-3.2
|
||||
- HsYAML-aeson-0.2.0.0@rev:2
|
||||
- implicit-hie-cradle-0.3.0.0
|
||||
- implicit-hie-0.1.2.3
|
||||
- lsp-test-0.11.0.6
|
||||
- monad-dijkstra-0.1.1.2
|
||||
- opentelemetry-0.4.2
|
||||
- ormolu-0.1.3.0
|
||||
- refinery-0.2.0.0
|
||||
- refinery-0.3.0.0
|
||||
- retrie-0.1.1.1
|
||||
- stylish-haskell-0.12.2.0
|
||||
- semigroups-0.18.5
|
||||
- temporary-1.2.1.1
|
||||
- implicit-hie-cradle-0.2.0.1
|
||||
- implicit-hie-0.1.1.0
|
||||
- hie-bios-0.7.1
|
||||
|
||||
flags:
|
||||
haskell-language-server:
|
||||
|
@ -1,15 +1,17 @@
|
||||
resolver: nightly-2020-10-03
|
||||
resolver: nightly-2020-10-19
|
||||
|
||||
packages:
|
||||
- .
|
||||
- ./ghcide/hie-compat
|
||||
- ./ghcide/
|
||||
- ./hls-plugin-api
|
||||
- ./plugins/tactics
|
||||
- ./plugins/hls-hlint-plugin
|
||||
|
||||
ghc-options:
|
||||
"$everything": -haddock
|
||||
|
||||
extra-deps:
|
||||
- aeson-1.5.2.0
|
||||
- github: bubba/brittany
|
||||
commit: c59655f10d5ad295c2481537fc8abf0a297d9d1c
|
||||
- Cabal-3.0.2.0
|
||||
@ -17,16 +19,16 @@ extra-deps:
|
||||
- data-tree-print-0.1.0.2
|
||||
- floskell-0.10.4
|
||||
- fourmolu-0.2.0.0
|
||||
- implicit-hie-cradle-0.3.0.0
|
||||
- implicit-hie-0.1.2.3
|
||||
- lsp-test-0.11.0.6
|
||||
- monad-dijkstra-0.1.1.2
|
||||
- opentelemetry-0.4.2
|
||||
- refinery-0.2.0.0
|
||||
- refinery-0.3.0.0
|
||||
- retrie-0.1.1.1
|
||||
- stylish-haskell-0.12.2.0
|
||||
- semigroups-0.18.5
|
||||
- temporary-1.2.1.1
|
||||
- implicit-hie-cradle-0.2.0.1
|
||||
- implicit-hie-0.1.1.0
|
||||
- hie-bios-0.7.1
|
||||
|
||||
flags:
|
||||
haskell-language-server:
|
||||
|
@ -3,14 +3,18 @@ compiler: ghc-8.6.4
|
||||
|
||||
packages:
|
||||
- .
|
||||
- ./ghcide/hie-compat
|
||||
- ./ghcide/
|
||||
- ./hls-plugin-api
|
||||
- ./plugins/tactics
|
||||
- ./plugins/hls-hlint-plugin
|
||||
|
||||
ghc-options:
|
||||
"$everything": -haddock
|
||||
|
||||
extra-deps:
|
||||
- aeson-1.5.2.0
|
||||
- apply-refact-0.8.2.1
|
||||
- ansi-terminal-0.10.3
|
||||
- base-compat-0.10.5
|
||||
- github: bubba/brittany
|
||||
@ -25,20 +29,24 @@ extra-deps:
|
||||
- fuzzy-0.1.0.0
|
||||
# - ghcide-0.1.0
|
||||
- ghc-check-0.5.0.1
|
||||
- ghc-exactprint-0.6.2
|
||||
- ghc-lib-parser-8.10.1.20200523
|
||||
- ghc-lib-parser-ex-8.10.0.4
|
||||
- ghc-exactprint-0.6.3.2
|
||||
- ghc-lib-8.10.2.20200916
|
||||
- ghc-lib-parser-8.10.2.20200916
|
||||
- ghc-lib-parser-ex-8.10.0.16
|
||||
- ghc-source-gen-0.4.0.0
|
||||
- haddock-api-2.22.0@rev:1
|
||||
- haddock-library-1.8.0
|
||||
- haskell-lsp-0.22.0.0
|
||||
- haskell-lsp-types-0.22.0.0
|
||||
- hie-bios-0.7.1
|
||||
- hlint-3.2
|
||||
- HsYAML-0.2.1.0@rev:1
|
||||
- HsYAML-aeson-0.2.0.0@rev:2
|
||||
- implicit-hie-cradle-0.3.0.0
|
||||
- implicit-hie-0.1.2.3
|
||||
- indexed-profunctors-0.1
|
||||
- lens-4.18
|
||||
- lsp-test-0.11.0.5
|
||||
- lsp-test-0.11.0.6
|
||||
- monad-dijkstra-0.1.1.2
|
||||
- opentelemetry-0.4.2
|
||||
- optics-core-0.2
|
||||
@ -46,7 +54,7 @@ extra-deps:
|
||||
- ormolu-0.1.3.0
|
||||
- parser-combinators-1.2.1
|
||||
- primitive-0.7.1.0
|
||||
- refinery-0.2.0.0
|
||||
- refinery-0.3.0.0
|
||||
- regex-base-0.94.0.0
|
||||
- regex-pcre-builtin-0.95.1.1.8.43
|
||||
- regex-tdfa-1.3.1.0
|
||||
@ -60,8 +68,6 @@ extra-deps:
|
||||
- these-1.1.1.1
|
||||
- type-equality-1
|
||||
- topograph-1
|
||||
- implicit-hie-cradle-0.2.0.1
|
||||
- implicit-hie-0.1.1.0
|
||||
|
||||
flags:
|
||||
haskell-language-server:
|
||||
|
@ -2,14 +2,18 @@ resolver: lts-14.27 # Last 8.6.5
|
||||
|
||||
packages:
|
||||
- .
|
||||
- ./ghcide/hie-compat
|
||||
- ./ghcide/
|
||||
- ./hls-plugin-api
|
||||
- ./plugins/tactics
|
||||
- ./plugins/hls-hlint-plugin
|
||||
|
||||
ghc-options:
|
||||
"$everything": -haddock
|
||||
|
||||
extra-deps:
|
||||
- aeson-1.5.2.0
|
||||
- apply-refact-0.8.2.1
|
||||
- ansi-terminal-0.10.3
|
||||
- base-compat-0.10.5
|
||||
- github: bubba/brittany
|
||||
@ -24,8 +28,9 @@ extra-deps:
|
||||
- fuzzy-0.1.0.0
|
||||
# - ghcide-0.1.0
|
||||
- ghc-check-0.5.0.1
|
||||
- ghc-exactprint-0.6.2
|
||||
- ghc-lib-parser-8.10.2.20200808
|
||||
- ghc-exactprint-0.6.3.2
|
||||
- ghc-lib-8.10.2.20200916
|
||||
- ghc-lib-parser-8.10.2.20200916
|
||||
- ghc-lib-parser-ex-8.10.0.16
|
||||
- ghc-source-gen-0.4.0.0
|
||||
- haddock-api-2.22.0@rev:1
|
||||
@ -33,11 +38,14 @@ extra-deps:
|
||||
- haskell-lsp-0.22.0.0
|
||||
- haskell-lsp-types-0.22.0.0
|
||||
- hie-bios-0.7.1
|
||||
- hlint-3.2
|
||||
- HsYAML-0.2.1.0@rev:1
|
||||
- HsYAML-aeson-0.2.0.0@rev:2
|
||||
- implicit-hie-cradle-0.3.0.0
|
||||
- implicit-hie-0.1.2.3
|
||||
- indexed-profunctors-0.1
|
||||
- lens-4.18
|
||||
- lsp-test-0.11.0.5
|
||||
- lsp-test-0.11.0.6
|
||||
- monad-dijkstra-0.1.1.2
|
||||
- opentelemetry-0.4.2
|
||||
- optics-core-0.2
|
||||
@ -45,7 +53,7 @@ extra-deps:
|
||||
- ormolu-0.1.3.0
|
||||
- parser-combinators-1.2.1
|
||||
- primitive-0.7.1.0
|
||||
- refinery-0.2.0.0
|
||||
- refinery-0.3.0.0
|
||||
- regex-base-0.94.0.0
|
||||
- regex-pcre-builtin-0.95.1.1.8.43
|
||||
- regex-tdfa-1.3.1.0
|
||||
@ -59,8 +67,6 @@ extra-deps:
|
||||
- these-1.1.1.1
|
||||
- type-equality-1
|
||||
- topograph-1
|
||||
- implicit-hie-cradle-0.2.0.1
|
||||
- implicit-hie-0.1.1.0
|
||||
|
||||
flags:
|
||||
haskell-language-server:
|
||||
|
@ -2,15 +2,18 @@ resolver: lts-15.3 # Last 8.8.2
|
||||
|
||||
packages:
|
||||
- .
|
||||
- ./ghcide/hie-compat
|
||||
- ./ghcide/
|
||||
- ./hls-plugin-api
|
||||
- ./plugins/tactics
|
||||
- ./plugins/hls-hlint-plugin
|
||||
|
||||
ghc-options:
|
||||
"$everything": -haddock
|
||||
|
||||
extra-deps:
|
||||
- aeson-1.5.2.0
|
||||
- apply-refact-0.7.0.0
|
||||
- apply-refact-0.8.2.1
|
||||
- github: bubba/brittany
|
||||
commit: c59655f10d5ad295c2481537fc8abf0a297d9d1c
|
||||
- butcher-1.3.3.2
|
||||
@ -22,23 +25,28 @@ extra-deps:
|
||||
- fourmolu-0.2.0.0
|
||||
# - ghcide-0.1.0
|
||||
- ghc-check-0.5.0.1
|
||||
- ghc-lib-parser-8.10.1.20200523
|
||||
- ghc-lib-parser-ex-8.10.0.4
|
||||
- ghc-exactprint-0.6.3.2
|
||||
- ghc-lib-8.10.2.20200916
|
||||
- ghc-lib-parser-8.10.2.20200916
|
||||
- ghc-lib-parser-ex-8.10.0.16
|
||||
- haddock-library-1.8.0
|
||||
- haskell-lsp-0.22.0.0
|
||||
- haskell-lsp-types-0.22.0.0
|
||||
- haskell-src-exts-1.21.1
|
||||
- hlint-2.2.8
|
||||
- hie-bios-0.7.1
|
||||
- hlint-3.2
|
||||
- hoogle-5.0.17.11
|
||||
- hsimport-0.11.0
|
||||
- HsYAML-0.2.1.0@rev:1
|
||||
- HsYAML-aeson-0.2.0.0@rev:2
|
||||
- ilist-0.3.1.0
|
||||
- lsp-test-0.11.0.5
|
||||
- implicit-hie-cradle-0.3.0.0
|
||||
- implicit-hie-0.1.2.3
|
||||
- lsp-test-0.11.0.6
|
||||
- monad-dijkstra-0.1.1.2
|
||||
- opentelemetry-0.4.2
|
||||
- ormolu-0.1.3.0
|
||||
- refinery-0.2.0.0
|
||||
- refinery-0.3.0.0
|
||||
- retrie-0.1.1.1
|
||||
- semigroups-0.18.5
|
||||
# - github: wz1000/shake
|
||||
@ -46,9 +54,6 @@ extra-deps:
|
||||
- stylish-haskell-0.12.2.0
|
||||
- temporary-1.2.1.1
|
||||
- these-1.1.1.1
|
||||
- implicit-hie-cradle-0.2.0.1
|
||||
- implicit-hie-0.1.1.0
|
||||
- hie-bios-0.7.1
|
||||
|
||||
flags:
|
||||
haskell-language-server:
|
||||
|
@ -1,16 +1,19 @@
|
||||
resolver: lts-16.11
|
||||
resolver: lts-16.11 # Last 8.8.3
|
||||
|
||||
packages:
|
||||
- .
|
||||
- ./ghcide/hie-compat
|
||||
- ./ghcide/
|
||||
- ./hls-plugin-api
|
||||
- ./plugins/tactics
|
||||
- ./plugins/hls-hlint-plugin
|
||||
|
||||
ghc-options:
|
||||
"$everything": -haddock
|
||||
|
||||
extra-deps:
|
||||
- aeson-1.5.2.0
|
||||
- apply-refact-0.7.0.0
|
||||
- apply-refact-0.8.2.1
|
||||
- github: bubba/brittany
|
||||
commit: c59655f10d5ad295c2481537fc8abf0a297d9d1c
|
||||
- bytestring-trie-0.2.5.0
|
||||
@ -21,25 +24,28 @@ extra-deps:
|
||||
- floskell-0.10.4
|
||||
- fourmolu-0.2.0.0
|
||||
# - ghcide-0.1.0
|
||||
- ghc-exactprint-0.6.3.2
|
||||
- ghc-lib-8.10.2.20200916
|
||||
- ghc-lib-parser-8.10.2.20200916
|
||||
- haskell-src-exts-1.21.1
|
||||
- hlint-2.2.8
|
||||
- hie-bios-0.7.1
|
||||
- hlint-3.2
|
||||
- HsYAML-aeson-0.2.0.0@rev:2
|
||||
- hoogle-5.0.17.11
|
||||
- hsimport-0.11.0
|
||||
- ilist-0.3.1.0
|
||||
- lsp-test-0.11.0.5
|
||||
- implicit-hie-cradle-0.3.0.0
|
||||
- implicit-hie-0.1.2.3
|
||||
- lsp-test-0.11.0.6
|
||||
- monad-dijkstra-0.1.1.2
|
||||
- ormolu-0.1.3.0
|
||||
- refinery-0.2.0.0
|
||||
- refinery-0.3.0.0
|
||||
- retrie-0.1.1.1
|
||||
- semigroups-0.18.5
|
||||
# - github: wz1000/shake
|
||||
# commit: fb3859dca2e54d1bbb2c873e68ed225fa179fbef
|
||||
- stylish-haskell-0.12.2.0
|
||||
- temporary-1.2.1.1
|
||||
- implicit-hie-cradle-0.2.0.1
|
||||
- implicit-hie-0.1.1.0
|
||||
- hie-bios-0.7.1
|
||||
|
||||
flags:
|
||||
haskell-language-server:
|
||||
|
@ -1,20 +1,22 @@
|
||||
resolver: lts-16.16
|
||||
resolver: lts-16.19
|
||||
|
||||
packages:
|
||||
- .
|
||||
- ./ghcide/hie-compat
|
||||
- ./ghcide/
|
||||
- ./hls-plugin-api
|
||||
- ./plugins/tactics
|
||||
- ./plugins/hls-hlint-plugin
|
||||
|
||||
ghc-options:
|
||||
"$everything": -haddock
|
||||
|
||||
extra-deps:
|
||||
- aeson-1.5.2.0
|
||||
- apply-refact-0.7.0.0
|
||||
- apply-refact-0.8.2.1
|
||||
- github: bubba/brittany
|
||||
commit: c59655f10d5ad295c2481537fc8abf0a297d9d1c
|
||||
- bytestring-trie-0.2.5.0
|
||||
- cabal-helper-1.1.0.0
|
||||
- cabal-plan-0.6.2.0
|
||||
- clock-0.7.2
|
||||
- constrained-dynamic-0.1.0.0
|
||||
@ -22,24 +24,25 @@ extra-deps:
|
||||
- floskell-0.10.4
|
||||
- fourmolu-0.2.0.0
|
||||
# - ghcide-0.1.0
|
||||
- ghc-exactprint-0.6.3.2
|
||||
- haskell-src-exts-1.21.1
|
||||
- hie-bios-0.7.1
|
||||
- hlint-2.2.8
|
||||
- hlint-3.2
|
||||
- HsYAML-aeson-0.2.0.0@rev:2
|
||||
- hoogle-5.0.17.11
|
||||
- hsimport-0.11.0
|
||||
- ilist-0.3.1.0
|
||||
- lsp-test-0.11.0.5
|
||||
- implicit-hie-cradle-0.3.0.0
|
||||
- implicit-hie-0.1.2.3
|
||||
- lsp-test-0.11.0.6
|
||||
- monad-dijkstra-0.1.1.2
|
||||
- refinery-0.2.0.0
|
||||
- refinery-0.3.0.0
|
||||
- retrie-0.1.1.1
|
||||
- semigroups-0.18.5
|
||||
# - github: wz1000/shake
|
||||
# commit: fb3859dca2e54d1bbb2c873e68ed225fa179fbef
|
||||
- stylish-haskell-0.12.2.0
|
||||
- temporary-1.2.1.1
|
||||
- ghc-exactprint-0.6.3.2
|
||||
- implicit-hie-cradle-0.2.0.1
|
||||
- implicit-hie-0.1.1.0
|
||||
|
||||
flags:
|
||||
haskell-language-server:
|
||||
|
18
stack.yaml
18
stack.yaml
@ -2,14 +2,18 @@ resolver: lts-14.27 # Last 8.6.5
|
||||
|
||||
packages:
|
||||
- .
|
||||
- ./ghcide/hie-compat
|
||||
- ./ghcide/
|
||||
- ./hls-plugin-api
|
||||
- ./plugins/tactics
|
||||
- ./plugins/hls-hlint-plugin
|
||||
|
||||
ghc-options:
|
||||
"$everything": -haddock
|
||||
|
||||
extra-deps:
|
||||
- aeson-1.5.2.0
|
||||
- apply-refact-0.8.2.1
|
||||
- ansi-terminal-0.10.3
|
||||
- base-compat-0.10.5
|
||||
- github: bubba/brittany
|
||||
@ -24,8 +28,9 @@ extra-deps:
|
||||
- fuzzy-0.1.0.0
|
||||
# - ghcide-0.1.0
|
||||
- ghc-check-0.5.0.1
|
||||
- ghc-exactprint-0.6.2
|
||||
- ghc-lib-parser-8.10.2.20200808
|
||||
- ghc-exactprint-0.6.3.2
|
||||
- ghc-lib-8.10.2.20200916
|
||||
- ghc-lib-parser-8.10.2.20200916
|
||||
- ghc-lib-parser-ex-8.10.0.16
|
||||
- ghc-source-gen-0.4.0.0
|
||||
- haddock-api-2.22.0@rev:1
|
||||
@ -33,11 +38,14 @@ extra-deps:
|
||||
- haskell-lsp-0.22.0.0
|
||||
- haskell-lsp-types-0.22.0.0
|
||||
- hie-bios-0.7.1
|
||||
- hlint-3.2
|
||||
- HsYAML-0.2.1.0@rev:1
|
||||
- HsYAML-aeson-0.2.0.0@rev:2
|
||||
- implicit-hie-cradle-0.3.0.0
|
||||
- implicit-hie-0.1.2.3
|
||||
- indexed-profunctors-0.1
|
||||
- lens-4.18
|
||||
- lsp-test-0.11.0.5
|
||||
- lsp-test-0.11.0.6
|
||||
- monad-dijkstra-0.1.1.2
|
||||
- opentelemetry-0.4.2
|
||||
- optics-core-0.2
|
||||
@ -45,7 +53,7 @@ extra-deps:
|
||||
- ormolu-0.1.3.0
|
||||
- parser-combinators-1.2.1
|
||||
- primitive-0.7.1.0
|
||||
- refinery-0.2.0.0
|
||||
- refinery-0.3.0.0
|
||||
- regex-base-0.94.0.0
|
||||
- regex-pcre-builtin-0.95.1.1.8.43
|
||||
- regex-tdfa-1.3.1.0
|
||||
@ -59,8 +67,6 @@ extra-deps:
|
||||
- these-1.1.1.1
|
||||
- type-equality-1
|
||||
- topograph-1
|
||||
- implicit-hie-cradle-0.2.0.1
|
||||
- implicit-hie-0.1.1.0
|
||||
|
||||
flags:
|
||||
haskell-language-server:
|
||||
|
@ -18,7 +18,7 @@ import Test.Tasty.ExpectedFailure (ignoreTestBecause)
|
||||
tests :: TestTree
|
||||
tests = testGroup "commands" [
|
||||
testCase "are prefixed" $
|
||||
runSession hieCommand fullCaps "test/testdata/" $ do
|
||||
runSession hlsCommand fullCaps "test/testdata/" $ do
|
||||
ResponseMessage _ _ (Right res) <- initializeResponse
|
||||
let List cmds = res ^. LSP.capabilities . executeCommandProvider . _Just . commands
|
||||
f x = (T.length (T.takeWhile isNumber x) >= 1) && (T.count ":" x >= 2)
|
||||
@ -27,7 +27,7 @@ tests = testGroup "commands" [
|
||||
not (null cmds) @? "Commands aren't empty"
|
||||
, ignoreTestBecause "Broken: Plugin package doesn't exist" $
|
||||
testCase "get de-prefixed" $
|
||||
runSession hieCommand fullCaps "test/testdata/" $ do
|
||||
runSession hlsCommand fullCaps "test/testdata/" $ do
|
||||
ResponseMessage _ _ (Left err) <- request
|
||||
WorkspaceExecuteCommand
|
||||
(ExecuteCommandParams "1234:package:add" (Just (List [])) Nothing) :: Session ExecuteCommandResponse
|
||||
|
@ -18,7 +18,7 @@ import Test.Tasty.HUnit
|
||||
|
||||
tests :: TestTree
|
||||
tests = testGroup "completions" [
|
||||
-- testCase "works" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- testCase "works" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
|
||||
@ -40,7 +40,7 @@ tests = testGroup "completions" [
|
||||
-- resolved ^. insertTextFormat @?= Just Snippet
|
||||
-- resolved ^. insertText @?= Just "putStrLn ${1:String}"
|
||||
|
||||
-- , testCase "completes imports" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- , testCase "completes imports" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
|
||||
@ -54,7 +54,7 @@ tests = testGroup "completions" [
|
||||
-- item ^. detail @?= Just "Data.Maybe"
|
||||
-- item ^. kind @?= Just CiModule
|
||||
|
||||
-- , testCase "completes qualified imports" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- , testCase "completes qualified imports" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
|
||||
@ -68,7 +68,7 @@ tests = testGroup "completions" [
|
||||
-- item ^. detail @?= Just "Data.List"
|
||||
-- item ^. kind @?= Just CiModule
|
||||
|
||||
-- , testCase "completes language extensions" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- , testCase "completes language extensions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
|
||||
@ -81,7 +81,7 @@ tests = testGroup "completions" [
|
||||
-- item ^. label @?= "OverloadedStrings"
|
||||
-- item ^. kind @?= Just CiKeyword
|
||||
|
||||
-- , testCase "completes pragmas" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- , testCase "completes pragmas" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
|
||||
@ -96,7 +96,7 @@ tests = testGroup "completions" [
|
||||
-- item ^. insertTextFormat @?= Just Snippet
|
||||
-- item ^. insertText @?= Just "LANGUAGE ${1:extension} #-}"
|
||||
|
||||
-- , testCase "completes pragmas no close" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- , testCase "completes pragmas no close" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
|
||||
@ -111,7 +111,7 @@ tests = testGroup "completions" [
|
||||
-- item ^. insertTextFormat @?= Just Snippet
|
||||
-- item ^. insertText @?= Just "LANGUAGE ${1:extension}"
|
||||
|
||||
-- , testCase "completes options pragma" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- , testCase "completes options pragma" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
|
||||
@ -128,7 +128,7 @@ tests = testGroup "completions" [
|
||||
|
||||
-- -- -----------------------------------
|
||||
|
||||
-- , testCase "completes ghc options pragma values" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- , testCase "completes ghc options pragma values" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
@ -146,14 +146,14 @@ tests = testGroup "completions" [
|
||||
|
||||
-- -- -----------------------------------
|
||||
|
||||
-- , testCase "completes with no prefix" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- , testCase "completes with no prefix" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
-- compls <- getCompletions doc (Position 5 7)
|
||||
-- liftIO $ filter ((== "!!") . (^. label)) compls `shouldNotSatisfy` null
|
||||
|
||||
-- -- See https://github.com/haskell/haskell-ide-engine/issues/903
|
||||
-- , testCase "strips compiler generated stuff from completions" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- , testCase "strips compiler generated stuff from completions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "DupRecFields.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
|
||||
@ -168,7 +168,7 @@ tests = testGroup "completions" [
|
||||
-- item ^. detail @?= Just "Two -> Int\nDupRecFields"
|
||||
-- item ^. insertText @?= Just "accessor ${1:Two}"
|
||||
|
||||
-- , testCase "have implicit foralls on basic polymorphic types" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- , testCase "have implicit foralls on basic polymorphic types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
-- let te = TextEdit (Range (Position 5 7) (Position 5 9)) "id"
|
||||
@ -180,7 +180,7 @@ tests = testGroup "completions" [
|
||||
-- liftIO $
|
||||
-- resolved ^. detail @?= Just "a -> a\nPrelude"
|
||||
|
||||
-- , testCase "have implicit foralls with multiple type variables" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- , testCase "have implicit foralls with multiple type variables" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
-- let te = TextEdit (Range (Position 5 7) (Position 5 24)) "flip"
|
||||
@ -198,7 +198,7 @@ tests = testGroup "completions" [
|
||||
|
||||
-- snippetTests :: TestTree
|
||||
-- snippetTests = testGroup "snippets" [
|
||||
-- testCase "work for argumentless constructors" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- testCase "work for argumentless constructors" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
|
||||
@ -211,7 +211,7 @@ tests = testGroup "completions" [
|
||||
-- item ^. insertTextFormat @?= Just Snippet
|
||||
-- item ^. insertText @?= Just "Nothing"
|
||||
|
||||
-- , testCase "work for polymorphic types" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- , testCase "work for polymorphic types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
|
||||
@ -228,7 +228,7 @@ tests = testGroup "completions" [
|
||||
-- resolved ^. insertTextFormat @?= Just Snippet
|
||||
-- resolved ^. insertText @?= Just "foldl ${1:b -> a -> b} ${2:b} ${3:t a}"
|
||||
|
||||
-- , testCase "work for complex types" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- , testCase "work for complex types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
|
||||
@ -245,7 +245,7 @@ tests = testGroup "completions" [
|
||||
-- resolved ^. insertTextFormat @?= Just Snippet
|
||||
-- resolved ^. insertText @?= Just "mapM ${1:a -> m b} ${2:t a}"
|
||||
|
||||
-- , testCase "work for infix functions" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- , testCase "work for infix functions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
|
||||
@ -260,7 +260,7 @@ tests = testGroup "completions" [
|
||||
-- item ^. insertTextFormat @?= Just Snippet
|
||||
-- item ^. insertText @?= Just "filter`"
|
||||
|
||||
-- , testCase "work for infix functions in backticks" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- , testCase "work for infix functions in backticks" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
|
||||
@ -275,7 +275,7 @@ tests = testGroup "completions" [
|
||||
-- item ^. insertTextFormat @?= Just Snippet
|
||||
-- item ^. insertText @?= Just "filter"
|
||||
|
||||
-- , testCase "work for qualified infix functions" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- , testCase "work for qualified infix functions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
|
||||
@ -290,7 +290,7 @@ tests = testGroup "completions" [
|
||||
-- item ^. insertTextFormat @?= Just Snippet
|
||||
-- item ^. insertText @?= Just "intersperse`"
|
||||
|
||||
-- , testCase "work for qualified infix functions in backticks" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- , testCase "work for qualified infix functions in backticks" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
|
||||
@ -306,7 +306,7 @@ tests = testGroup "completions" [
|
||||
-- item ^. insertText @?= Just "intersperse"
|
||||
|
||||
-- -- TODO : Fix compile issue in the test "Variable not in scope: object"
|
||||
-- , testCase "respects lsp configuration" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- , testCase "respects lsp configuration" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
|
||||
@ -317,7 +317,7 @@ tests = testGroup "completions" [
|
||||
|
||||
-- checkNoSnippets doc
|
||||
|
||||
-- , testCase "respects client capabilities" $ runSession hieCommand noSnippetsCaps "test/testdata/completion" $ do
|
||||
-- , testCase "respects client capabilities" $ runSession hlsCommand noSnippetsCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Completion.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
|
||||
@ -359,7 +359,7 @@ tests = testGroup "completions" [
|
||||
contextTests :: TestTree
|
||||
contextTests = testGroup "contexts" [
|
||||
ignoreTestBecause "Broken: Timed out waiting to receive a message from the server" $
|
||||
testCase "only provides type suggestions" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
testCase "only provides type suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
doc <- openDoc "Context.hs" "haskell"
|
||||
_ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
compls <- getCompletions doc (Position 2 17)
|
||||
@ -368,7 +368,7 @@ contextTests = testGroup "contexts" [
|
||||
compls `shouldNotContainCompl` "interact"
|
||||
|
||||
, ignoreTestBecause "Broken: Timed out waiting to receive a message from the server" $
|
||||
testCase "only provides type suggestions" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
testCase "only provides type suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
doc <- openDoc "Context.hs" "haskell"
|
||||
_ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
compls <- getCompletions doc (Position 3 9)
|
||||
@ -377,7 +377,7 @@ contextTests = testGroup "contexts" [
|
||||
compls `shouldNotContainCompl` "Applicative"
|
||||
|
||||
-- This currently fails if , testCase takes too long to typecheck the module
|
||||
-- , testCase "completes qualified type suggestions" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
|
||||
-- , testCase "completes qualified type suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
|
||||
-- doc <- openDoc "Context.hs" "haskell"
|
||||
-- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
-- let te = TextEdit (Range (Position 2 17) (Position 2 17)) " -> Conc."
|
||||
|
@ -22,7 +22,7 @@ tests :: TestTree
|
||||
tests = testGroup "deferred responses" [
|
||||
|
||||
--TODO: DOes not compile
|
||||
-- testCase "do not affect hover requests" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
-- testCase "do not affect hover requests" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
-- doc <- openDoc "FuncTest.hs" "haskell"
|
||||
|
||||
-- id1 <- sendRequest TextDocumentHover (TextDocumentPositionParams doc (Position 4 2) Nothing)
|
||||
@ -91,7 +91,7 @@ tests = testGroup "deferred responses" [
|
||||
-- }
|
||||
-- ]
|
||||
|
||||
testCase "instantly respond to failed modules with no cache" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
testCase "instantly respond to failed modules with no cache" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc "FuncTestFail.hs" "haskell"
|
||||
defs <- getDefinitions doc (Position 1 11)
|
||||
liftIO $ defs @?= []
|
||||
@ -99,13 +99,13 @@ tests = testGroup "deferred responses" [
|
||||
-- TODO: the benefits of caching parsed modules is doubted.
|
||||
-- TODO: add issue link
|
||||
-- , testCase "respond to untypecheckable modules with parsed module cache" $
|
||||
-- runSession hieCommand fullCaps "test/testdata" $ do
|
||||
-- runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
-- doc <- openDoc "FuncTestFail.hs" "haskell"
|
||||
-- (Left (sym:_)) <- getDocumentSymbols doc
|
||||
-- liftIO $ sym ^. name @?= "main"
|
||||
|
||||
-- TODO does not compile
|
||||
-- , testCase "returns hints as diagnostics" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
-- , testCase "returns hints as diagnostics" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
-- _ <- openDoc "FuncTest.hs" "haskell"
|
||||
|
||||
-- cwd <- liftIO getCurrentDirectory
|
||||
@ -145,7 +145,7 @@ tests = testGroup "deferred responses" [
|
||||
-- multiServerTests :: TestTree
|
||||
-- multiServerTests = testGroup "multi-server setup" [
|
||||
-- testCase "doesn't have clashing commands on two servers" $ do
|
||||
-- let getCommands = runSession hieCommand fullCaps "test/testdata" $ do
|
||||
-- let getCommands = runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
-- rsp <- initializeResponse
|
||||
-- let uuids = rsp ^? result . _Just . capabilities . executeCommandProvider . _Just . commands
|
||||
-- return $ fromJust uuids
|
||||
@ -158,7 +158,7 @@ multiMainTests :: TestTree
|
||||
multiMainTests = testGroup "multiple main modules" [
|
||||
ignoreTestBecause "Broken: Unexpected ConduitParser.empty" $
|
||||
testCase "Can load one file at a time, when more than one Main module exists"
|
||||
$ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
$ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
_doc <- openDoc "ApplyRefact2.hs" "haskell"
|
||||
_diagsRspHlint <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification
|
||||
diagsRspGhc <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification
|
||||
|
@ -15,7 +15,7 @@ tests :: TestTree
|
||||
tests = testGroup "definitions" [
|
||||
|
||||
ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/References.hs" $
|
||||
testCase "goto's symbols" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
testCase "goto's symbols" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc "References.hs" "haskell"
|
||||
defs <- getDefinitions doc (Position 7 8)
|
||||
let expRange = Range (Position 4 0) (Position 4 3)
|
||||
@ -24,7 +24,7 @@ tests = testGroup "definitions" [
|
||||
-- -----------------------------------
|
||||
|
||||
, ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $
|
||||
testCase "goto's imported modules" $ runSession hieCommand fullCaps "test/testdata/definition" $ do
|
||||
testCase "goto's imported modules" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do
|
||||
doc <- openDoc "Foo.hs" "haskell"
|
||||
defs <- getDefinitions doc (Position 2 8)
|
||||
liftIO $ do
|
||||
@ -32,7 +32,7 @@ tests = testGroup "definitions" [
|
||||
defs @?= [Location (filePathToUri fp) zeroRange]
|
||||
|
||||
, ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $
|
||||
testCase "goto's exported modules" $ runSession hieCommand fullCaps "test/testdata/definition" $ do
|
||||
testCase "goto's exported modules" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do
|
||||
doc <- openDoc "Foo.hs" "haskell"
|
||||
defs <- getDefinitions doc (Position 0 15)
|
||||
liftIO $ do
|
||||
@ -40,7 +40,7 @@ tests = testGroup "definitions" [
|
||||
defs @?= [Location (filePathToUri fp) zeroRange]
|
||||
|
||||
, ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $
|
||||
testCase "goto's imported modules that are loaded" $ runSession hieCommand fullCaps "test/testdata/definition" $ do
|
||||
testCase "goto's imported modules that are loaded" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do
|
||||
doc <- openDoc "Foo.hs" "haskell"
|
||||
_ <- openDoc "Bar.hs" "haskell"
|
||||
defs <- getDefinitions doc (Position 2 8)
|
||||
@ -50,7 +50,7 @@ tests = testGroup "definitions" [
|
||||
|
||||
, ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $
|
||||
testCase "goto's imported modules that are loaded, and then closed" $
|
||||
runSession hieCommand fullCaps "test/testdata/definition" $ do
|
||||
runSession hlsCommand fullCaps "test/testdata/definition" $ do
|
||||
doc <- openDoc "Foo.hs" "haskell"
|
||||
otherDoc <- openDoc "Bar.hs" "haskell"
|
||||
closeDoc otherDoc
|
||||
|
@ -33,7 +33,7 @@ triggerTests :: TestTree
|
||||
triggerTests = testGroup "diagnostics triggers" [
|
||||
ignoreTestBecause "Broken" $
|
||||
ignoreTestBecause "Broken" $ testCase "runs diagnostics on save" $
|
||||
runSession hieCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do
|
||||
runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do
|
||||
logm "starting DiagnosticSpec.runs diagnostic on save"
|
||||
doc <- openDoc "ApplyRefact2.hs" "haskell"
|
||||
|
||||
@ -65,7 +65,7 @@ triggerTests = testGroup "diagnostics triggers" [
|
||||
errorTests :: TestTree
|
||||
errorTests = testGroup "typed hole errors" [
|
||||
ignoreTestBecause "Broken" $ testCase "is deferred" $
|
||||
runSession hieCommand fullCaps "test/testdata" $ do
|
||||
runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
_ <- openDoc "TypedHoles.hs" "haskell"
|
||||
[diag] <- waitForDiagnosticsSource "bios"
|
||||
liftIO $ diag ^. LSP.severity @?= Just DsWarning
|
||||
@ -74,7 +74,7 @@ errorTests = testGroup "typed hole errors" [
|
||||
warningTests :: TestTree
|
||||
warningTests = testGroup "Warnings are warnings" [
|
||||
ignoreTestBecause "Broken" $ testCase "Overrides -Werror" $
|
||||
runSession hieCommand fullCaps "test/testdata/wErrorTest" $ do
|
||||
runSession hlsCommand fullCaps "test/testdata/wErrorTest" $ do
|
||||
_ <- openDoc "src/WError.hs" "haskell"
|
||||
[diag] <- waitForDiagnosticsSource "bios"
|
||||
liftIO $ diag ^. LSP.severity @?= Just DsWarning
|
||||
@ -83,7 +83,7 @@ warningTests = testGroup "Warnings are warnings" [
|
||||
saveTests :: TestTree
|
||||
saveTests = testGroup "only diagnostics on save" [
|
||||
ignoreTestBecause "Broken" $ testCase "Respects diagnosticsOnChange setting" $
|
||||
runSession hieCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do
|
||||
runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do
|
||||
let config = Data.Default.def { diagnosticsOnChange = False } :: Config
|
||||
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
|
||||
doc <- openDoc "Hover.hs" "haskell"
|
||||
|
@ -9,6 +9,7 @@ where
|
||||
|
||||
import Control.Applicative.Combinators (skipManyTill)
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import Language.Haskell.LSP.Test
|
||||
import Language.Haskell.LSP.Types (ApplyWorkspaceEditRequest, CodeLens (CodeLens, _command, _range),
|
||||
@ -24,27 +25,27 @@ tests :: TestTree
|
||||
tests = testGroup
|
||||
"eval"
|
||||
[ testCase "Produces Evaluate code lenses" $ do
|
||||
runSession hieCommand fullCaps evalPath $ do
|
||||
runSession hlsCommand fullCaps evalPath $ do
|
||||
doc <- openDoc "T1.hs" "haskell"
|
||||
lenses <- getCodeLenses doc
|
||||
liftIO $ map (fmap _title . _command) lenses @?= [Just "Evaluate..."]
|
||||
, testCase "Produces Refresh code lenses" $ do
|
||||
runSession hieCommand fullCaps evalPath $ do
|
||||
runSession hlsCommand fullCaps evalPath $ do
|
||||
doc <- openDoc "T2.hs" "haskell"
|
||||
lenses <- getCodeLenses doc
|
||||
liftIO $ map (fmap _title . _command) lenses @?= [Just "Refresh..."]
|
||||
, testCase "Code lenses have ranges" $ do
|
||||
runSession hieCommand fullCaps evalPath $ do
|
||||
runSession hlsCommand fullCaps evalPath $ do
|
||||
doc <- openDoc "T1.hs" "haskell"
|
||||
lenses <- getCodeLenses doc
|
||||
liftIO $ map _range lenses @?= [Range (Position 4 0) (Position 4 15)]
|
||||
, testCase "Multi-line expressions have a multi-line range" $ do
|
||||
runSession hieCommand fullCaps evalPath $ do
|
||||
runSession hlsCommand fullCaps evalPath $ do
|
||||
doc <- openDoc "T3.hs" "haskell"
|
||||
lenses <- getCodeLenses doc
|
||||
liftIO $ map _range lenses @?= [Range (Position 3 0) (Position 4 15)]
|
||||
, testCase "Executed expressions range covers only the expression" $ do
|
||||
runSession hieCommand fullCaps evalPath $ do
|
||||
runSession hlsCommand fullCaps evalPath $ do
|
||||
doc <- openDoc "T2.hs" "haskell"
|
||||
lenses <- getCodeLenses doc
|
||||
liftIO $ map _range lenses @?= [Range (Position 4 0) (Position 4 15)]
|
||||
@ -93,14 +94,21 @@ tests = testGroup
|
||||
]
|
||||
|
||||
goldenTest :: FilePath -> IO ()
|
||||
goldenTest input = runSession hieCommand fullCaps evalPath $ do
|
||||
goldenTest input =
|
||||
runSession hlsCommand fullCaps evalPath $ do
|
||||
doc <- openDoc input "haskell"
|
||||
[CodeLens { _command = Just c }] <- getCodeLenses doc
|
||||
executeCommand c
|
||||
_resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message
|
||||
edited <- documentContents doc
|
||||
expected <- liftIO $ T.readFile $ evalPath </> input <.> "expected"
|
||||
edited <- replaceUnicodeQuotes <$> documentContents doc
|
||||
expected <- fmap replaceUnicodeQuotes $
|
||||
liftIO $ T.readFile $ evalPath </> input <.> "expected"
|
||||
liftIO $ edited @?= expected
|
||||
|
||||
|
||||
replaceUnicodeQuotes :: T.Text -> T.Text
|
||||
replaceUnicodeQuotes = T.replace "‘" "`" . T.replace "’" "'"
|
||||
|
||||
|
||||
evalPath :: FilePath
|
||||
evalPath = "test/testdata/eval"
|
||||
|
@ -18,11 +18,11 @@ import qualified Data.Text.IO as T
|
||||
|
||||
tests :: TestTree
|
||||
tests = testGroup "format document" [
|
||||
goldenVsStringDiff "works" goldenGitDiff "test/testdata/Format.formatted_document.hs" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
goldenVsStringDiff "works" goldenGitDiff "test/testdata/Format.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc "Format.hs" "haskell"
|
||||
formatDoc doc (FormattingOptions 2 True)
|
||||
BS.fromStrict . T.encodeUtf8 <$> documentContents doc
|
||||
, goldenVsStringDiff "works with custom tab size" goldenGitDiff "test/testdata/Format.formatted_document_with_tabsize.hs" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
, goldenVsStringDiff "works with custom tab size" goldenGitDiff "test/testdata/Format.formatted_document_with_tabsize.hs" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc "Format.hs" "haskell"
|
||||
formatDoc doc (FormattingOptions 5 True)
|
||||
BS.fromStrict . T.encodeUtf8 <$> documentContents doc
|
||||
@ -38,11 +38,11 @@ tests = testGroup "format document" [
|
||||
|
||||
rangeTests :: TestTree
|
||||
rangeTests = testGroup "format range" [
|
||||
goldenVsStringDiff "works" goldenGitDiff "test/testdata/Format.formatted_range.hs" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
goldenVsStringDiff "works" goldenGitDiff "test/testdata/Format.formatted_range.hs" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc "Format.hs" "haskell"
|
||||
formatRange doc (FormattingOptions 2 True) (Range (Position 5 0) (Position 7 10))
|
||||
BS.fromStrict . T.encodeUtf8 <$> documentContents doc
|
||||
, goldenVsStringDiff "works with custom tab size" goldenGitDiff "test/testdata/Format.formatted_range_with_tabsize.hs" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
, goldenVsStringDiff "works with custom tab size" goldenGitDiff "test/testdata/Format.formatted_range_with_tabsize.hs" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc "Format.hs" "haskell"
|
||||
formatRange doc (FormattingOptions 5 True) (Range (Position 8 0) (Position 11 19))
|
||||
BS.fromStrict . T.encodeUtf8 <$> documentContents doc
|
||||
@ -50,7 +50,7 @@ rangeTests = testGroup "format range" [
|
||||
|
||||
providerTests :: TestTree
|
||||
providerTests = testGroup "formatting provider" [
|
||||
testCase "respects none" $ runSessionWithConfig (formatConfig "none") hieCommand fullCaps "test/testdata" $ do
|
||||
testCase "respects none" $ runSessionWithConfig (formatConfig "none") hlsCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc "Format.hs" "haskell"
|
||||
orig <- documentContents doc
|
||||
|
||||
@ -61,7 +61,7 @@ providerTests = testGroup "formatting provider" [
|
||||
documentContents doc >>= liftIO . (@?= orig)
|
||||
|
||||
#if AGPL
|
||||
, testCase "can change on the fly" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
, testCase "can change on the fly" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
formattedBrittany <- liftIO $ T.readFile "test/testdata/Format.brittany.formatted.hs"
|
||||
formattedFloskell <- liftIO $ T.readFile "test/testdata/Format.floskell.formatted.hs"
|
||||
formattedBrittanyPostFloskell <- liftIO $ T.readFile "test/testdata/Format.brittany_post_floskell.formatted.hs"
|
||||
@ -79,7 +79,7 @@ providerTests = testGroup "formatting provider" [
|
||||
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany"))
|
||||
formatDoc doc (FormattingOptions 2 True)
|
||||
documentContents doc >>= liftIO . (@?= formattedBrittanyPostFloskell)
|
||||
, testCase "supports both new and old configuration sections" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
, testCase "supports both new and old configuration sections" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
formattedBrittany <- liftIO $ T.readFile "test/testdata/Format.brittany.formatted.hs"
|
||||
formattedFloskell <- liftIO $ T.readFile "test/testdata/Format.floskell.formatted.hs"
|
||||
|
||||
@ -97,12 +97,12 @@ providerTests = testGroup "formatting provider" [
|
||||
|
||||
stylishHaskellTests :: TestTree
|
||||
stylishHaskellTests = testGroup "stylish-haskell" [
|
||||
goldenVsStringDiff "formats a document" goldenGitDiff "test/testdata/StylishHaksell.formatted_document.hs" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
goldenVsStringDiff "formats a document" goldenGitDiff "test/testdata/StylishHaksell.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "stylish-haskell"))
|
||||
doc <- openDoc "StylishHaskell.hs" "haskell"
|
||||
formatDoc doc (FormattingOptions 2 True)
|
||||
BS.fromStrict . T.encodeUtf8 <$> documentContents doc
|
||||
, goldenVsStringDiff "formats a range" goldenGitDiff "test/testdata/StylishHaksell.formatted_range.hs" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
, goldenVsStringDiff "formats a range" goldenGitDiff "test/testdata/StylishHaksell.formatted_range.hs" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "stylish-haskell"))
|
||||
doc <- openDoc "StylishHaskell.hs" "haskell"
|
||||
formatRange doc (FormattingOptions 2 True) (Range (Position 0 0) (Position 2 21))
|
||||
@ -112,26 +112,26 @@ stylishHaskellTests = testGroup "stylish-haskell" [
|
||||
#if AGPL
|
||||
brittanyTests :: TestTree
|
||||
brittanyTests = testGroup "brittany" [
|
||||
goldenVsStringDiff "formats a document with LF endings" goldenGitDiff "test/testdata/BrittanyLF.formatted_document.hs" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
goldenVsStringDiff "formats a document with LF endings" goldenGitDiff "test/testdata/BrittanyLF.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany"))
|
||||
doc <- openDoc "BrittanyLF.hs" "haskell"
|
||||
formatDoc doc (FormattingOptions 4 True)
|
||||
BS.fromStrict . T.encodeUtf8 <$> documentContents doc
|
||||
|
||||
, goldenVsStringDiff "formats a document with CRLF endings" goldenGitDiff "test/testdata/BrittanyCRLF.formatted_document.hs" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
, goldenVsStringDiff "formats a document with CRLF endings" goldenGitDiff "test/testdata/BrittanyCRLF.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany"))
|
||||
doc <- openDoc "BrittanyCRLF.hs" "haskell"
|
||||
formatDoc doc (FormattingOptions 4 True)
|
||||
BS.fromStrict . T.encodeUtf8 <$> documentContents doc
|
||||
|
||||
, goldenVsStringDiff "formats a range with LF endings" goldenGitDiff "test/testdata/BrittanyLF.formatted_range.hs" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
, goldenVsStringDiff "formats a range with LF endings" goldenGitDiff "test/testdata/BrittanyLF.formatted_range.hs" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany"))
|
||||
doc <- openDoc "BrittanyLF.hs" "haskell"
|
||||
let range = Range (Position 1 0) (Position 2 22)
|
||||
formatRange doc (FormattingOptions 4 True) range
|
||||
BS.fromStrict . T.encodeUtf8 <$> documentContents doc
|
||||
|
||||
, goldenVsStringDiff "formats a range with CRLF endings" goldenGitDiff "test/testdata/BrittanyCRLF.formatted_range.hs" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
, goldenVsStringDiff "formats a range with CRLF endings" goldenGitDiff "test/testdata/BrittanyCRLF.formatted_range.hs" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany"))
|
||||
doc <- openDoc "BrittanyCRLF.hs" "haskell"
|
||||
let range = Range (Position 1 0) (Position 2 22)
|
||||
@ -142,12 +142,12 @@ brittanyTests = testGroup "brittany" [
|
||||
|
||||
ormoluTests :: TestTree
|
||||
ormoluTests = testGroup "ormolu"
|
||||
[ goldenVsStringDiff "formats correctly" goldenGitDiff "test/testdata/Format.ormolu.formatted.hs" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
[ goldenVsStringDiff "formats correctly" goldenGitDiff "test/testdata/Format.ormolu.formatted.hs" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu"))
|
||||
doc <- openDoc "Format.hs" "haskell"
|
||||
formatDoc doc (FormattingOptions 2 True)
|
||||
BS.fromStrict . T.encodeUtf8 <$> documentContents doc
|
||||
, goldenVsStringDiff "formats imports correctly" goldenGitDiff "test/testdata/Format2.ormolu.formatted.hs" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
, goldenVsStringDiff "formats imports correctly" goldenGitDiff "test/testdata/Format2.ormolu.formatted.hs" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu"))
|
||||
doc <- openDoc "Format2.hs" "haskell"
|
||||
formatDoc doc (FormattingOptions 2 True)
|
||||
@ -156,12 +156,12 @@ ormoluTests = testGroup "ormolu"
|
||||
|
||||
fourmoluTests :: TestTree
|
||||
fourmoluTests = testGroup "fourmolu"
|
||||
[ goldenVsStringDiff "formats correctly" goldenGitDiff "test/testdata/Format.fourmolu.formatted.hs" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
[ goldenVsStringDiff "formats correctly" goldenGitDiff "test/testdata/Format.fourmolu.formatted.hs" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu"))
|
||||
doc <- openDoc "Format.hs" "haskell"
|
||||
formatDoc doc (FormattingOptions 4 True)
|
||||
BS.fromStrict . T.encodeUtf8 <$> documentContents doc
|
||||
, goldenVsStringDiff "formats imports correctly" goldenGitDiff "test/testdata/Format2.fourmolu.formatted.hs" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
, goldenVsStringDiff "formats imports correctly" goldenGitDiff "test/testdata/Format2.fourmolu.formatted.hs" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu"))
|
||||
doc <- openDoc "Format2.hs" "haskell"
|
||||
formatDoc doc (FormattingOptions 4 True)
|
||||
|
@ -23,8 +23,8 @@ tests = testGroup "behaviour on malformed projects" [
|
||||
]
|
||||
|
||||
-- testCase "deals with cabal file with unsatisfiable dependency" $
|
||||
-- runSession hieCommandExamplePlugin codeActionSupportCaps "test/testdata/badProjects/cabal" $ do
|
||||
-- -- runSessionWithConfig logConfig hieCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do
|
||||
-- runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata/badProjects/cabal" $ do
|
||||
-- -- runSessionWithConfig logConfig hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do
|
||||
-- _doc <- openDoc "Foo.hs" "haskell"
|
||||
|
||||
-- diags@(d:_) <- waitForDiagnosticsSource "bios"
|
||||
|
@ -44,77 +44,90 @@ tests = testGroup "code actions" [
|
||||
|
||||
hlintTests :: TestTree
|
||||
hlintTests = testGroup "hlint suggestions" [
|
||||
ignoreTestBecause "Broken" $ testCase "provides 3.8 code actions" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
testCase "provides 3.8 code actions including apply all" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do
|
||||
doc <- openDoc "ApplyRefact2.hs" "haskell"
|
||||
diags@(reduceDiag:_) <- waitForDiagnostics
|
||||
diags@(reduceDiag:_) <- waitForDiagnosticsSource "hlint"
|
||||
|
||||
liftIO $ do
|
||||
length diags @?= 2
|
||||
length diags @?= 2 -- "Eta Reduce" and "Redundant Id"
|
||||
reduceDiag ^. L.range @?= Range (Position 1 0) (Position 1 12)
|
||||
reduceDiag ^. L.severity @?= Just DsInfo
|
||||
reduceDiag ^. L.code @?= Just (StringValue "Eta reduce")
|
||||
reduceDiag ^. L.code @?= Just (StringValue "refact:Eta reduce")
|
||||
reduceDiag ^. L.source @?= Just "hlint"
|
||||
|
||||
(CACodeAction ca:_) <- getAllCodeActions doc
|
||||
cas <- map fromAction <$> getAllCodeActions doc
|
||||
|
||||
-- Evaluate became redundant id in later hlint versions
|
||||
liftIO $ (ca ^. L.title) `elem` ["Apply hint:Redundant id", "Apply hint:Evaluate"] @? "Title contains evaluate"
|
||||
let applyAll = find (\ca -> "Apply all hints" `T.isSuffixOf` (ca ^. L.title)) cas
|
||||
let redId = find (\ca -> "Redundant id" `T.isSuffixOf` (ca ^. L.title)) cas
|
||||
let redEta = find (\ca -> "Eta reduce" `T.isSuffixOf` (ca ^. L.title)) cas
|
||||
|
||||
executeCodeAction ca
|
||||
liftIO $ isJust applyAll @? "There is 'Apply all hints' code action"
|
||||
liftIO $ isJust redId @? "There is 'Redundant id' code action"
|
||||
liftIO $ isJust redEta @? "There is 'Eta reduce' code action"
|
||||
|
||||
executeCodeAction (fromJust redId)
|
||||
|
||||
contents <- getDocumentEdit doc
|
||||
liftIO $ contents @?= "main = undefined\nfoo x = x\n"
|
||||
|
||||
noDiagnostics
|
||||
|
||||
, ignoreTestBecause "Broken" $ testCase "falls back to pre 3.8 code actions" $ runSession hieCommand noLiteralCaps "test/testdata" $ do
|
||||
, testCase "falls back to pre 3.8 code actions" $ runSession hlsCommand noLiteralCaps "test/testdata/hlint" $ do
|
||||
doc <- openDoc "ApplyRefact2.hs" "haskell"
|
||||
|
||||
_ <- waitForDiagnostics
|
||||
_ <- waitForDiagnosticsSource "hlint"
|
||||
|
||||
(CACommand cmd:_) <- getAllCodeActions doc
|
||||
|
||||
-- Evaluate became redundant id in later hlint versions
|
||||
liftIO $ (cmd ^. L.title) `elem` ["Apply hint:Redundant id", "Apply hint:Evaluate"] @? "Title contains evaluate"
|
||||
|
||||
executeCommand cmd
|
||||
|
||||
contents <- skipManyTill publishDiagnosticsNotification $ getDocumentEdit doc
|
||||
liftIO $ contents @?= "main = undefined\nfoo x = x\n"
|
||||
liftIO $ contents `elem` ["main = undefined\nfoo = id\n", "main = undefined\nfoo x = x\n"] @? "Command is applied"
|
||||
|
||||
noDiagnostics
|
||||
|
||||
, ignoreTestBecause "Broken" $ testCase "runs diagnostics on save" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
let config = def { diagnosticsOnChange = False }
|
||||
, testCase "changing configuration enables or disables hlint diagnostics" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do
|
||||
let config = def { hlintOn = True }
|
||||
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
|
||||
|
||||
_ <- openDoc "ApplyRefact2.hs" "haskell"
|
||||
diags <- waitForDiagnosticsSource "hlint"
|
||||
|
||||
liftIO $ length diags > 0 @? "There are hlint diagnostics"
|
||||
|
||||
let config' = def { hlintOn = False }
|
||||
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config'))
|
||||
|
||||
diags' <- waitForDiagnostics
|
||||
|
||||
liftIO $ Just "hlint" `notElem` map (^. L.source) diags' @? "There are no hlint diagnostics"
|
||||
|
||||
, testCase "changing document contents updates hlint diagnostics" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do
|
||||
doc <- openDoc "ApplyRefact2.hs" "haskell"
|
||||
diags@(reduceDiag:_) <- waitForDiagnostics
|
||||
diags <- waitForDiagnosticsSource "hlint"
|
||||
|
||||
liftIO $ do
|
||||
length diags @?= 2
|
||||
reduceDiag ^. L.range @?= Range (Position 1 0) (Position 1 12)
|
||||
reduceDiag ^. L.severity @?= Just DsInfo
|
||||
reduceDiag ^. L.code @?= Just (StringValue "Eta reduce")
|
||||
reduceDiag ^. L.source @?= Just "hlint"
|
||||
liftIO $ length diags @?= 2 -- "Eta Reduce" and "Redundant Id"
|
||||
|
||||
(CACodeAction ca:_) <- getAllCodeActions doc
|
||||
let change = TextDocumentContentChangeEvent
|
||||
(Just (Range (Position 1 8) (Position 1 12)))
|
||||
Nothing "x"
|
||||
|
||||
-- Evaluate became redundant id in later hlint versions
|
||||
liftIO $ (ca ^. L.title) `elem` ["Apply hint:Redundant id", "Apply hint:Evaluate"] @? "Title contains evaluate"
|
||||
changeDoc doc [change]
|
||||
|
||||
executeCodeAction ca
|
||||
diags' <- waitForDiagnostics
|
||||
|
||||
contents <- getDocumentEdit doc
|
||||
liftIO $ contents @?= "main = undefined\nfoo x = x\n"
|
||||
sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)
|
||||
liftIO $ (not $ Just "hlint" `elem` map (^. L.source) diags') @? "There are no hlint diagnostics"
|
||||
|
||||
noDiagnostics
|
||||
let change' = TextDocumentContentChangeEvent
|
||||
(Just (Range (Position 1 8) (Position 1 12)))
|
||||
Nothing "id x"
|
||||
|
||||
changeDoc doc [change']
|
||||
|
||||
diags'' <- waitForDiagnosticsSource "hlint"
|
||||
|
||||
liftIO $ length diags'' @?= 2
|
||||
]
|
||||
|
||||
renameTests :: TestTree
|
||||
renameTests = testGroup "rename suggestions" [
|
||||
ignoreTestBecause "Broken" $ testCase "works" $ runSession hieCommand noLiteralCaps "test/testdata" $ do
|
||||
ignoreTestBecause "Broken" $ testCase "works" $ runSession hlsCommand noLiteralCaps "test/testdata" $ do
|
||||
doc <- openDoc "CodeActionRename.hs" "haskell"
|
||||
|
||||
_ <- waitForDiagnosticsSource "bios"
|
||||
@ -126,7 +139,7 @@ renameTests = testGroup "rename suggestions" [
|
||||
liftIO $ x @?= "main = putStrLn \"hello\""
|
||||
|
||||
, ignoreTestBecause "Broken" $ testCase "doesn't give both documentChanges and changes"
|
||||
$ runSession hieCommand noLiteralCaps "test/testdata" $ do
|
||||
$ runSession hlsCommand noLiteralCaps "test/testdata" $ do
|
||||
doc <- openDoc "CodeActionRename.hs" "haskell"
|
||||
|
||||
_ <- waitForDiagnosticsSource "bios"
|
||||
@ -146,7 +159,7 @@ renameTests = testGroup "rename suggestions" [
|
||||
|
||||
importTests :: TestTree
|
||||
importTests = testGroup "import suggestions" [
|
||||
ignoreTestBecause "Broken" $ testCase "works with 3.8 code action kinds" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
ignoreTestBecause "Broken" $ testCase "works with 3.8 code action kinds" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc "CodeActionImport.hs" "haskell"
|
||||
-- No Formatting:
|
||||
let config = def { formattingProvider = "none" }
|
||||
@ -181,7 +194,7 @@ packageTests :: TestTree
|
||||
packageTests = testGroup "add package suggestions" [
|
||||
ignoreTestBecause "Broken" $ testCase "adds to .cabal files" $ do
|
||||
flushStackEnvironment
|
||||
runSession hieCommand fullCaps "test/testdata/addPackageTest/cabal-exe" $ do
|
||||
runSession hlsCommand fullCaps "test/testdata/addPackageTest/cabal-exe" $ do
|
||||
doc <- openDoc "AddPackage.hs" "haskell"
|
||||
|
||||
-- ignore the first empty hlint diagnostic publish
|
||||
@ -209,7 +222,7 @@ packageTests = testGroup "add package suggestions" [
|
||||
any (\l -> "text -any" `T.isSuffixOf` l || "text : {} -any" `T.isSuffixOf` l) (T.lines contents) @? "Contains text package"
|
||||
|
||||
, ignoreTestBecause "Broken" $ testCase "adds to hpack package.yaml files" $
|
||||
runSession hieCommand fullCaps "test/testdata/addPackageTest/hpack-exe" $ do
|
||||
runSession hlsCommand fullCaps "test/testdata/addPackageTest/hpack-exe" $ do
|
||||
doc <- openDoc "app/Asdf.hs" "haskell"
|
||||
|
||||
-- ignore the first empty hlint diagnostic publish
|
||||
@ -242,7 +255,7 @@ packageTests = testGroup "add package suggestions" [
|
||||
redundantImportTests :: TestTree
|
||||
redundantImportTests = testGroup "redundant import code actions" [
|
||||
ignoreTestBecause "Broken" $ testCase "remove solitary redundant imports" $
|
||||
runSession hieCommand fullCaps "test/testdata/redundantImportTest/" $ do
|
||||
runSession hlsCommand fullCaps "test/testdata/redundantImportTest/" $ do
|
||||
doc <- openDoc "src/CodeActionRedundant.hs" "haskell"
|
||||
|
||||
-- ignore the first empty hlint diagnostic publish
|
||||
@ -272,7 +285,7 @@ redundantImportTests = testGroup "redundant import code actions" [
|
||||
contents <- documentContents doc
|
||||
liftIO $ contents @?= "module CodeActionRedundant where\nmain :: IO ()\nmain = putStrLn \"hello\""
|
||||
|
||||
, ignoreTestBecause "Broken" $ testCase "doesn't touch other imports" $ runSession hieCommand noLiteralCaps "test/testdata/redundantImportTest/" $ do
|
||||
, ignoreTestBecause "Broken" $ testCase "doesn't touch other imports" $ runSession hlsCommand noLiteralCaps "test/testdata/redundantImportTest/" $ do
|
||||
doc <- openDoc "src/MultipleImports.hs" "haskell"
|
||||
_ <- count 2 waitForDiagnostics
|
||||
[CACommand cmd, _] <- getAllCodeActions doc
|
||||
@ -289,36 +302,36 @@ redundantImportTests = testGroup "redundant import code actions" [
|
||||
typedHoleTests :: TestTree
|
||||
typedHoleTests = testGroup "typed hole code actions" [
|
||||
ignoreTestBecause "Broken" $ testCase "works" $
|
||||
runSession hieCommand fullCaps "test/testdata" $ do
|
||||
runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc "TypedHoles.hs" "haskell"
|
||||
_ <- waitForDiagnosticsSource "bios"
|
||||
cas <- map (\(CACodeAction x)-> x) <$> getAllCodeActions doc
|
||||
|
||||
suggestion <-
|
||||
case ghcVersion of
|
||||
GHC88 -> do
|
||||
liftIO $ map (^. L.title) cas `matchList`
|
||||
let substitutions GHC810 = substitutions GHC88
|
||||
substitutions GHC88 =
|
||||
[ "Substitute hole (Int) with x ([Int])"
|
||||
, "Substitute hole (Int) with foo ([Int] -> Int Valid hole fits include)"
|
||||
, "Substitute hole (Int) with maxBound (forall a. Bounded a => a with maxBound @Int)"
|
||||
, "Substitute hole (Int) with minBound (forall a. Bounded a => a with minBound @Int)"
|
||||
] @? "Contains substitutions"
|
||||
return "x"
|
||||
GHC86 -> do
|
||||
liftIO $ map (^. L.title) cas `matchList`
|
||||
]
|
||||
substitutions GHC86 =
|
||||
[ "Substitute hole (Int) with x ([Int])"
|
||||
, "Substitute hole (Int) with foo ([Int] -> Int Valid hole fits include)"
|
||||
, "Substitute hole (Int) with maxBound (forall a. Bounded a => a with maxBound @Int)"
|
||||
, "Substitute hole (Int) with minBound (forall a. Bounded a => a with minBound @Int)"
|
||||
] @? "Contains substitutions"
|
||||
return "x"
|
||||
GHC84 -> do
|
||||
liftIO $ map (^. L.title) cas `matchList`
|
||||
]
|
||||
substitutions GHC84 =
|
||||
[ "Substitute hole (Int) with maxBound (forall a. Bounded a => a)"
|
||||
, "Substitute hole (Int) with minBound (forall a. Bounded a => a)"
|
||||
, "Substitute hole (Int) with undefined (forall (a :: TYPE r). GHC.Stack.Types.HasCallStack => a)"
|
||||
] @? "Contains substitutions"
|
||||
return "maxBound"
|
||||
]
|
||||
|
||||
liftIO $ map (^. L.title) cas `matchList`
|
||||
substitutions ghcVersion @? "Contains substitutions"
|
||||
|
||||
let suggestion = case ghcVersion of
|
||||
GHC84 -> "maxBound"
|
||||
_ -> "x"
|
||||
|
||||
executeCodeAction $ head cas
|
||||
|
||||
@ -331,35 +344,35 @@ typedHoleTests = testGroup "typed hole code actions" [
|
||||
]
|
||||
|
||||
, ignoreTestBecause "Broken" $ testCase "shows more suggestions" $
|
||||
runSession hieCommand fullCaps "test/testdata" $ do
|
||||
runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc "TypedHoles2.hs" "haskell"
|
||||
_ <- waitForDiagnosticsSource "bios"
|
||||
cas <- map fromAction <$> getAllCodeActions doc
|
||||
|
||||
suggestion <-
|
||||
case ghcVersion of
|
||||
GHC88 -> do
|
||||
liftIO $ map (^. L.title) cas `matchList`
|
||||
let substitutions GHC810 = substitutions GHC88
|
||||
substitutions GHC88 =
|
||||
[ "Substitute hole (A) with stuff (A -> A)"
|
||||
, "Substitute hole (A) with x ([A])"
|
||||
, "Substitute hole (A) with foo2 ([A] -> A)"
|
||||
] @? "Contains substitutions"
|
||||
return "stuff"
|
||||
GHC86 -> do
|
||||
liftIO $ map (^. L.title) cas `matchList`
|
||||
]
|
||||
substitutions GHC86 =
|
||||
[ "Substitute hole (A) with stuff (A -> A)"
|
||||
, "Substitute hole (A) with x ([A])"
|
||||
, "Substitute hole (A) with foo2 ([A] -> A)"
|
||||
] @? "Contains substituions"
|
||||
return "stuff"
|
||||
GHC84 -> do
|
||||
liftIO $ map (^. L.title) cas `matchList`
|
||||
]
|
||||
substitutions GHC84 =
|
||||
[ "Substitute hole (A) with undefined (forall (a :: TYPE r). GHC.Stack.Types.HasCallStack => a)"
|
||||
, "Substitute hole (A) with stuff (A -> A)"
|
||||
, "Substitute hole (A) with x ([A])"
|
||||
, "Substitute hole (A) with foo2 ([A] -> A)"
|
||||
] @? "Contains substitutions"
|
||||
return "undefined"
|
||||
]
|
||||
|
||||
liftIO $ map (^. L.title) cas `matchList`
|
||||
substitutions ghcVersion @? "Contains substitutions"
|
||||
|
||||
let suggestion = case ghcVersion of
|
||||
GHC84 -> "undefined"
|
||||
_ -> "stuff"
|
||||
|
||||
executeCodeAction $ head cas
|
||||
|
||||
@ -387,7 +400,7 @@ typedHoleTests = testGroup "typed hole code actions" [
|
||||
signatureTests :: TestTree
|
||||
signatureTests = testGroup "missing top level signature code actions" [
|
||||
ignoreTestBecause "Broken" $ testCase "Adds top level signature" $
|
||||
runSession hieCommand fullCaps "test/testdata/" $ do
|
||||
runSession hlsCommand fullCaps "test/testdata/" $ do
|
||||
doc <- openDoc "TopLevelSignature.hs" "haskell"
|
||||
|
||||
_ <- waitForDiagnosticsSource "bios"
|
||||
@ -413,7 +426,7 @@ signatureTests = testGroup "missing top level signature code actions" [
|
||||
missingPragmaTests :: TestTree
|
||||
missingPragmaTests = testGroup "missing pragma warning code actions" [
|
||||
ignoreTestBecause "Broken" $ testCase "Adds TypeSynonymInstances pragma" $
|
||||
runSession hieCommand fullCaps "test/testdata/addPragmas" $ do
|
||||
runSession hlsCommand fullCaps "test/testdata/addPragmas" $ do
|
||||
doc <- openDoc "NeedsPragmas.hs" "haskell"
|
||||
|
||||
_ <- waitForDiagnosticsSource "bios"
|
||||
@ -450,7 +463,7 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [
|
||||
unusedTermTests :: TestTree
|
||||
unusedTermTests = testGroup "unused term code actions" [
|
||||
-- ignoreTestBecause "Broken" $ testCase "Prefixes with '_'" $ pendingWith "removed because of HaRe"
|
||||
-- runSession hieCommand fullCaps "test/testdata/" $ do
|
||||
-- runSession hlsCommand fullCaps "test/testdata/" $ do
|
||||
-- doc <- openDoc "UnusedTerm.hs" "haskell"
|
||||
--
|
||||
-- _ <- waitForDiagnosticsSource "bios"
|
||||
@ -474,7 +487,7 @@ unusedTermTests = testGroup "unused term code actions" [
|
||||
|
||||
-- See https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#textDocument_codeAction
|
||||
-- `CodeActionContext`
|
||||
ignoreTestBecause "Broken" $ testCase "respect 'only' parameter" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
ignoreTestBecause "Broken" $ testCase "respect 'only' parameter" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc "CodeActionOnly.hs" "haskell"
|
||||
_ <- count 2 waitForDiagnostics -- need to wait for both hlint and ghcmod
|
||||
diags <- getCurrentDiagnostics doc
|
||||
|
@ -21,7 +21,7 @@ import Test.Tasty.HUnit
|
||||
tests :: TestTree
|
||||
tests = testGroup "liquid haskell diagnostics" [
|
||||
ignoreTestBecause "Broken" $ testCase "runs diagnostics on save, no liquid" $
|
||||
runSession hieCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do
|
||||
runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do
|
||||
doc <- openDoc "liquid/Evens.hs" "haskell"
|
||||
|
||||
diags@(reduceDiag:_) <- waitForDiagnostics
|
||||
@ -51,8 +51,8 @@ tests = testGroup "liquid haskell diagnostics" [
|
||||
-- ---------------------------------
|
||||
|
||||
, ignoreTestBecause "Broken" $ testCase "runs diagnostics on save, with liquid haskell" $
|
||||
runSession hieCommand codeActionSupportCaps "test/testdata" $ do
|
||||
-- runSessionWithConfig logConfig hieCommand codeActionSupportCaps "test/testdata" $ do
|
||||
runSession hlsCommand codeActionSupportCaps "test/testdata" $ do
|
||||
-- runSessionWithConfig logConfig hlsCommand codeActionSupportCaps "test/testdata" $ do
|
||||
doc <- openDoc "liquid/Evens.hs" "haskell"
|
||||
|
||||
diags@(reduceDiag:_) <- waitForDiagnostics
|
||||
|
@ -16,14 +16,14 @@ tests :: TestTree
|
||||
tests = testGroup "hie-bios" [
|
||||
ignoreTestBecause "Broken" $ testCase "loads modules inside main-is" $ do
|
||||
writeFile (hieBiosErrorPath </> "hie.yaml") ""
|
||||
runSession hieCommand fullCaps "test/testdata/hieBiosMainIs" $ do
|
||||
runSession hlsCommand fullCaps "test/testdata/hieBiosMainIs" $ do
|
||||
_ <- openDoc "Main.hs" "haskell"
|
||||
_ <- count 2 waitForDiagnostics
|
||||
return ()
|
||||
|
||||
, ignoreTestBecause "Broken" $ testCase "reports errors in hie.yaml" $ do
|
||||
writeFile (hieBiosErrorPath </> "hie.yaml") ""
|
||||
runSession hieCommand fullCaps hieBiosErrorPath $ do
|
||||
runSession hlsCommand fullCaps hieBiosErrorPath $ do
|
||||
_ <- openDoc "Foo.hs" "haskell"
|
||||
_ <- skipManyTill loggingNotification (satisfy isMessage)
|
||||
return ()
|
||||
|
@ -12,7 +12,7 @@ import Test.Tasty.HUnit
|
||||
|
||||
tests :: TestTree
|
||||
tests = testGroup "highlight" [
|
||||
ignoreTestBecause "Broken" $ testCase "works" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
ignoreTestBecause "Broken" $ testCase "works" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc "Highlight.hs" "haskell"
|
||||
_ <- count 2 $ skipManyTill loggingNotification noDiagnostics
|
||||
highlights <- getHighlights doc (Position 2 2)
|
||||
|
@ -26,7 +26,7 @@ import Language.Haskell.LSP.Types ( ApplyWorkspaceEditRequest
|
||||
import System.FilePath ( (<.>)
|
||||
, (</>)
|
||||
)
|
||||
import Test.Hls.Util ( hieCommand )
|
||||
import Test.Hls.Util ( hlsCommand )
|
||||
import Test.Tasty ( TestTree
|
||||
, testGroup
|
||||
)
|
||||
@ -42,7 +42,7 @@ tests = testGroup
|
||||
]
|
||||
|
||||
goldenTest :: FilePath -> IO ()
|
||||
goldenTest input = runSession hieCommand fullCaps testdataPath $ do
|
||||
goldenTest input = runSession hlsCommand fullCaps testdataPath $ do
|
||||
doc <- openDoc input "haskell"
|
||||
-- getCodeLenses doc >>= liftIO . print . length
|
||||
[CodeLens { _command = Just c }] <- getCodeLenses doc
|
||||
|
@ -21,7 +21,7 @@ tests :: TestTree
|
||||
tests = testGroup "window/workDoneProgress" [
|
||||
ignoreTestBecause "Broken" $ testCase "sends indefinite progress notifications" $
|
||||
-- Testing that ghc-mod sends progress notifications
|
||||
runSession hieCommand progressCaps "test/testdata" $ do
|
||||
runSession hlsCommand progressCaps "test/testdata" $ do
|
||||
doc <- openDoc "ApplyRefact2.hs" "haskell"
|
||||
|
||||
skipMany loggingNotification
|
||||
@ -77,7 +77,7 @@ tests = testGroup "window/workDoneProgress" [
|
||||
|
||||
, ignoreTestBecause "Broken" $ testCase "sends indefinite progress notifications with liquid" $
|
||||
-- Testing that Liquid Haskell sends progress notifications
|
||||
runSession hieCommand progressCaps "test/testdata" $ do
|
||||
runSession hlsCommand progressCaps "test/testdata" $ do
|
||||
doc <- openDoc "liquid/Evens.hs" "haskell"
|
||||
|
||||
skipMany loggingNotification
|
||||
|
@ -13,7 +13,7 @@ import Test.Tasty.HUnit
|
||||
|
||||
tests :: TestTree
|
||||
tests = testGroup "references" [
|
||||
ignoreTestBecause "Broken" $ testCase "works with definitions" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
ignoreTestBecause "Broken" $ testCase "works with definitions" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc "References.hs" "haskell"
|
||||
let pos = Position 2 7 -- foo = bar <--
|
||||
refs <- getReferences doc pos True
|
||||
@ -26,7 +26,7 @@ tests = testGroup "references" [
|
||||
, mkRange 2 6 2 9
|
||||
] `isInfixOf` refs @? "Contains references"
|
||||
-- TODO: Respect withDeclaration parameter
|
||||
-- ignoreTestBecause "Broken" $ testCase "works without definitions" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
-- ignoreTestBecause "Broken" $ testCase "works without definitions" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
-- doc <- openDoc "References.hs" "haskell"
|
||||
-- let pos = Position 2 7 -- foo = bar <--
|
||||
-- refs <- getReferences doc pos False
|
||||
|
@ -12,7 +12,7 @@ tests :: TestTree
|
||||
tests = testGroup "rename" [
|
||||
testCase "works" $ True @?= True
|
||||
-- pendingWith "removed because of HaRe"
|
||||
-- runSession hieCommand fullCaps "test/testdata" $ do
|
||||
-- runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
-- doc <- openDoc "Rename.hs" "haskell"
|
||||
-- rename doc (Position 3 1) "baz" -- foo :: Int -> Int
|
||||
-- documentContents doc >>= liftIO . flip shouldBe expected
|
||||
|
@ -19,7 +19,7 @@ tests = testGroup "document symbols" [
|
||||
|
||||
v310Tests :: TestTree
|
||||
v310Tests = testGroup "3.10 hierarchical document symbols" [
|
||||
ignoreTestBecause "Broken" $ testCase "provides nested data types and constructors" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
ignoreTestBecause "Broken" $ testCase "provides nested data types and constructors" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc "Symbols.hs" "haskell"
|
||||
Left symbs <- getDocumentSymbols doc
|
||||
|
||||
@ -29,7 +29,7 @@ v310Tests = testGroup "3.10 hierarchical document symbols" [
|
||||
|
||||
liftIO $ myData `elem` symbs @? "Contains symbol"
|
||||
|
||||
,ignoreTestBecause "Broken" $ testCase "provides nested where functions" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
,ignoreTestBecause "Broken" $ testCase "provides nested where functions" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc "Symbols.hs" "haskell"
|
||||
Left symbs <- getDocumentSymbols doc
|
||||
|
||||
@ -40,7 +40,7 @@ v310Tests = testGroup "3.10 hierarchical document symbols" [
|
||||
|
||||
liftIO $ foo `elem` symbs @? "Contains symbol"
|
||||
|
||||
, ignoreTestBecause "Broken" $ testCase "provides pattern synonyms" $ runSession hieCommand fullCaps "test/testdata" $ do
|
||||
, ignoreTestBecause "Broken" $ testCase "provides pattern synonyms" $ runSession hlsCommand fullCaps "test/testdata" $ do
|
||||
doc <- openDoc "Symbols.hs" "haskell"
|
||||
Left symbs <- getDocumentSymbols doc
|
||||
|
||||
@ -54,7 +54,7 @@ v310Tests = testGroup "3.10 hierarchical document symbols" [
|
||||
|
||||
pre310Tests :: TestTree
|
||||
pre310Tests = testGroup "pre 3.10 symbol information" [
|
||||
ignoreTestBecause "Broken" $ testCase "provides nested data types and constructors" $ runSession hieCommand oldCaps "test/testdata" $ do
|
||||
ignoreTestBecause "Broken" $ testCase "provides nested data types and constructors" $ runSession hlsCommand oldCaps "test/testdata" $ do
|
||||
doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell"
|
||||
Right symbs <- getDocumentSymbols doc
|
||||
|
||||
@ -64,7 +64,7 @@ pre310Tests = testGroup "pre 3.10 symbol information" [
|
||||
|
||||
liftIO $ [myData, a, b] `isInfixOf` symbs @? "Contains symbols"
|
||||
|
||||
,ignoreTestBecause "Broken" $ testCase "provides nested where functions" $ runSession hieCommand oldCaps "test/testdata" $ do
|
||||
,ignoreTestBecause "Broken" $ testCase "provides nested where functions" $ runSession hlsCommand oldCaps "test/testdata" $ do
|
||||
doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell"
|
||||
Right symbs <- getDocumentSymbols doc
|
||||
|
||||
|
@ -9,7 +9,11 @@ module Tactic
|
||||
where
|
||||
|
||||
import Control.Applicative.Combinators ( skipManyTill )
|
||||
import Control.Lens hiding ((<.>))
|
||||
import Control.Monad (unless)
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Aeson
|
||||
import Data.Either (isLeft)
|
||||
import Data.Foldable
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
@ -17,13 +21,14 @@ import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import Ide.Plugin.Tactic.TestTypes
|
||||
import Language.Haskell.LSP.Test
|
||||
import Language.Haskell.LSP.Types (ApplyWorkspaceEditRequest, Position(..) , Range(..) , CAResult(..) , CodeAction(..))
|
||||
import Language.Haskell.LSP.Types (ExecuteCommandParams(ExecuteCommandParams), ClientMethod (..), Command, ExecuteCommandResponse, ResponseMessage (..), ApplyWorkspaceEditRequest, Position(..) , Range(..) , CAResult(..) , CodeAction(..))
|
||||
import Language.Haskell.LSP.Types.Lens hiding (id, capabilities, message, executeCommand, applyEdit, rename)
|
||||
import System.Directory (doesFileExist)
|
||||
import System.FilePath
|
||||
import Test.Hls.Util
|
||||
import Test.Tasty
|
||||
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
|
||||
import Test.Tasty.HUnit
|
||||
import System.FilePath
|
||||
import System.Directory (doesFileExist)
|
||||
import Control.Monad (unless)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -93,9 +98,24 @@ tests = testGroup
|
||||
, goldenTest "GoldenEitherHomomorphic.hs" 2 15 Auto ""
|
||||
, goldenTest "GoldenNote.hs" 2 8 Auto ""
|
||||
, goldenTest "GoldenPureList.hs" 2 12 Auto ""
|
||||
, goldenTest "GoldenListFmap.hs" 2 12 Auto ""
|
||||
, goldenTest "GoldenFromMaybe.hs" 2 13 Auto ""
|
||||
, goldenTest "GoldenFoldr.hs" 2 10 Auto ""
|
||||
, goldenTest "GoldenSwap.hs" 2 8 Auto ""
|
||||
, goldenTest "GoldenFmapTree.hs" 4 11 Auto ""
|
||||
, goldenTest "GoldenGADTDestruct.hs" 7 17 Destruct "gadt"
|
||||
, goldenTest "GoldenGADTDestructCoercion.hs" 8 17 Destruct "gadt"
|
||||
, goldenTest "GoldenGADTAuto.hs" 7 13 Auto ""
|
||||
, goldenTest "GoldenSwapMany.hs" 2 12 Auto ""
|
||||
, goldenTest "GoldenBigTuple.hs" 4 12 Auto ""
|
||||
, goldenTest "GoldenShow.hs" 2 10 Auto ""
|
||||
, goldenTest "GoldenShowCompose.hs" 2 15 Auto ""
|
||||
, goldenTest "GoldenShowMapChar.hs" 2 8 Auto ""
|
||||
, goldenTest "GoldenSuperclass.hs" 7 8 Auto ""
|
||||
, ignoreTestBecause "It is unreliable in circleci builds"
|
||||
$ goldenTest "GoldenApplicativeThen.hs" 2 11 Auto ""
|
||||
, goldenTest "GoldenSafeHead.hs" 2 12 Auto ""
|
||||
, expectFail "GoldenFish.hs" 5 18 Auto ""
|
||||
]
|
||||
|
||||
|
||||
@ -114,8 +134,9 @@ mkTest
|
||||
-> TestTree
|
||||
mkTest name fp line col ts =
|
||||
testCase name $ do
|
||||
runSession hieCommand fullCaps tacticPath $ do
|
||||
runSession hlsCommand fullCaps tacticPath $ do
|
||||
doc <- openDoc fp "haskell"
|
||||
_ <- waitForDiagnostics
|
||||
actions <- getCodeActions doc $ pointRange line col
|
||||
let titles = mapMaybe codeActionTitle actions
|
||||
for_ ts $ \(f, tc, var) -> do
|
||||
@ -128,8 +149,9 @@ mkTest name fp line col ts =
|
||||
goldenTest :: FilePath -> Int -> Int -> TacticCommand -> Text -> TestTree
|
||||
goldenTest input line col tc occ =
|
||||
testCase (input <> " (golden)") $ do
|
||||
runSession hieCommand fullCaps tacticPath $ do
|
||||
runSession hlsCommand fullCaps tacticPath $ do
|
||||
doc <- openDoc input "haskell"
|
||||
_ <- waitForDiagnostics
|
||||
actions <- getCodeActions doc $ pointRange line col
|
||||
Just (CACodeAction (CodeAction {_command = Just c}))
|
||||
<- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions
|
||||
@ -144,6 +166,27 @@ goldenTest input line col tc occ =
|
||||
liftIO $ edited @?= expected
|
||||
|
||||
|
||||
expectFail :: FilePath -> Int -> Int -> TacticCommand -> Text -> TestTree
|
||||
expectFail input line col tc occ =
|
||||
testCase (input <> " (golden)") $ do
|
||||
runSession hlsCommand fullCaps tacticPath $ do
|
||||
doc <- openDoc input "haskell"
|
||||
_ <- waitForDiagnostics
|
||||
actions <- getCodeActions doc $ pointRange line col
|
||||
Just (CACodeAction (CodeAction {_command = Just c}))
|
||||
<- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions
|
||||
resp <- executeCommandWithResp c
|
||||
liftIO $ unless (isLeft $ _result resp) $
|
||||
assertFailure "didn't fail, but expected one"
|
||||
|
||||
|
||||
tacticPath :: FilePath
|
||||
tacticPath = "test/testdata/tactic"
|
||||
|
||||
|
||||
executeCommandWithResp :: Command -> Session ExecuteCommandResponse
|
||||
executeCommandWithResp cmd = do
|
||||
let args = decode $ encode $ fromJust $ cmd ^. arguments
|
||||
execParams = ExecuteCommandParams (cmd ^. command) args Nothing
|
||||
request WorkspaceExecuteCommand execParams
|
||||
|
||||
|
@ -12,7 +12,7 @@ import Test.Tasty.HUnit
|
||||
tests :: TestTree
|
||||
tests = testGroup "type definitions" [
|
||||
ignoreTestBecause "Broken" $ testCase "finds local definition of record variable"
|
||||
$ runSession hieCommand fullCaps "test/testdata/gototest"
|
||||
$ runSession hlsCommand fullCaps "test/testdata/gototest"
|
||||
$ do
|
||||
doc <- openDoc "src/Lib.hs" "haskell"
|
||||
defs <- getTypeDefinitions doc (toPos (11, 23))
|
||||
@ -22,7 +22,7 @@ tests = testGroup "type definitions" [
|
||||
(Range (toPos (8, 1)) (toPos (8, 29)))
|
||||
]
|
||||
, ignoreTestBecause "Broken" $ testCase "finds local definition of newtype variable"
|
||||
$ runSession hieCommand fullCaps "test/testdata/gototest"
|
||||
$ runSession hlsCommand fullCaps "test/testdata/gototest"
|
||||
$ do
|
||||
doc <- openDoc "src/Lib.hs" "haskell"
|
||||
defs <- getTypeDefinitions doc (toPos (16, 21))
|
||||
@ -32,7 +32,7 @@ tests = testGroup "type definitions" [
|
||||
(Range (toPos (13, 1)) (toPos (13, 30)))
|
||||
]
|
||||
, ignoreTestBecause "Broken" $ testCase "finds local definition of sum type variable"
|
||||
$ runSession hieCommand fullCaps "test/testdata/gototest"
|
||||
$ runSession hlsCommand fullCaps "test/testdata/gototest"
|
||||
$ do
|
||||
doc <- openDoc "src/Lib.hs" "haskell"
|
||||
defs <- getTypeDefinitions doc (toPos (21, 13))
|
||||
@ -42,7 +42,7 @@ tests = testGroup "type definitions" [
|
||||
(Range (toPos (18, 1)) (toPos (18, 26)))
|
||||
]
|
||||
, ignoreTestBecause "Broken" $ testCase "finds local definition of sum type contructor"
|
||||
$ runSession hieCommand fullCaps "test/testdata/gototest"
|
||||
$ runSession hlsCommand fullCaps "test/testdata/gototest"
|
||||
$ do
|
||||
doc <- openDoc "src/Lib.hs" "haskell"
|
||||
defs <- getTypeDefinitions doc (toPos (24, 7))
|
||||
@ -53,14 +53,14 @@ tests = testGroup "type definitions" [
|
||||
(Range (toPos (18, 1)) (toPos (18, 26)))
|
||||
]
|
||||
, ignoreTestBecause "Broken" $ testCase "can not find non-local definition of type def"
|
||||
$ runSession hieCommand fullCaps "test/testdata/gototest"
|
||||
$ runSession hlsCommand fullCaps "test/testdata/gototest"
|
||||
$ do
|
||||
doc <- openDoc "src/Lib.hs" "haskell"
|
||||
defs <- getTypeDefinitions doc (toPos (30, 17))
|
||||
liftIO $ defs @?= []
|
||||
|
||||
, ignoreTestBecause "Broken" $ testCase "find local definition of type def"
|
||||
$ runSession hieCommand fullCaps "test/testdata/gototest"
|
||||
$ runSession hlsCommand fullCaps "test/testdata/gototest"
|
||||
$ do
|
||||
doc <- openDoc "src/Lib.hs" "haskell"
|
||||
defs <- getTypeDefinitions doc (toPos (35, 16))
|
||||
@ -73,7 +73,7 @@ tests = testGroup "type definitions" [
|
||||
{-- TODO Implement
|
||||
, ignoreTestBecause "Broken" $ testCase "find type-definition of type def in component"
|
||||
$ pendingWith "Finding symbols cross module is currently not supported"
|
||||
$ runSession hieCommand fullCaps "test/testdata/gototest"
|
||||
$ runSession hlsCommand fullCaps "test/testdata/gototest"
|
||||
$ do
|
||||
doc <- openDoc "src/Lib2.hs" "haskell"
|
||||
otherDoc <- openDoc "src/Lib.hs" "haskell"
|
||||
@ -87,7 +87,7 @@ tests = testGroup "type definitions" [
|
||||
]
|
||||
--}
|
||||
, ignoreTestBecause "Broken" $ testCase "find definition of parameterized data type"
|
||||
$ runSession hieCommand fullCaps "test/testdata/gototest"
|
||||
$ runSession hlsCommand fullCaps "test/testdata/gototest"
|
||||
$ do
|
||||
doc <- openDoc "src/Lib.hs" "haskell"
|
||||
defs <- getTypeDefinitions doc (toPos (40, 19))
|
||||
|
4
test/testdata/ApplyRefact.hs
vendored
4
test/testdata/ApplyRefact.hs
vendored
@ -1,4 +0,0 @@
|
||||
|
||||
main = (putStrLn "hello")
|
||||
|
||||
foo x = (x + 1)
|
4
test/testdata/hlint/hie.yaml
vendored
Normal file
4
test/testdata/hlint/hie.yaml
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
cradle:
|
||||
direct:
|
||||
arguments:
|
||||
- "ApplyRefact2"
|
2
test/testdata/tactic/GoldenApplicativeThen.hs
vendored
Normal file
2
test/testdata/tactic/GoldenApplicativeThen.hs
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
useThen :: Applicative f => f Int -> f a -> f a
|
||||
useThen = _
|
2
test/testdata/tactic/GoldenApplicativeThen.hs.expected
vendored
Normal file
2
test/testdata/tactic/GoldenApplicativeThen.hs.expected
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
useThen :: Applicative f => f Int -> f a -> f a
|
||||
useThen = (\ x x8 -> (*>) x x8)
|
4
test/testdata/tactic/GoldenBigTuple.hs
vendored
Normal file
4
test/testdata/tactic/GoldenBigTuple.hs
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
-- There used to be a bug where we were unable to perform a nested split. The
|
||||
-- more serious regression test of this is 'AutoTupleSpec'.
|
||||
bigTuple :: (a, b, c, d) -> (a, b, (c, d))
|
||||
bigTuple = _
|
4
test/testdata/tactic/GoldenBigTuple.hs.expected
vendored
Normal file
4
test/testdata/tactic/GoldenBigTuple.hs.expected
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
-- There used to be a bug where we were unable to perform a nested split. The
|
||||
-- more serious regression test of this is 'AutoTupleSpec'.
|
||||
bigTuple :: (a, b, c, d) -> (a, b, (c, d))
|
||||
bigTuple = (\ pabcd -> case pabcd of { (a, b, c, d) -> (a, b, (c, d)) })
|
5
test/testdata/tactic/GoldenFish.hs
vendored
Normal file
5
test/testdata/tactic/GoldenFish.hs
vendored
Normal file
@ -0,0 +1,5 @@
|
||||
-- There was an old bug where we would only pull skolems from the hole, rather
|
||||
-- than the entire hypothesis. Because of this, the 'b' here would be
|
||||
-- considered a univar, which could then be unified with the skolem 'c'.
|
||||
fish :: Monad m => (a -> m b) -> (b -> m c) -> a -> m c
|
||||
fish amb bmc a = _
|
4
test/testdata/tactic/GoldenFmapTree.hs
vendored
Normal file
4
test/testdata/tactic/GoldenFmapTree.hs
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
data Tree a = Leaf a | Branch (Tree a) (Tree a)
|
||||
|
||||
instance Functor Tree where
|
||||
fmap = _
|
7
test/testdata/tactic/GoldenFmapTree.hs.expected
vendored
Normal file
7
test/testdata/tactic/GoldenFmapTree.hs.expected
vendored
Normal file
@ -0,0 +1,7 @@
|
||||
data Tree a = Leaf a | Branch (Tree a) (Tree a)
|
||||
|
||||
instance Functor Tree where
|
||||
fmap = (\ fab ta
|
||||
-> case ta of
|
||||
(Leaf a) -> Leaf (fab a)
|
||||
(Branch ta2 ta3) -> Branch (fmap fab ta2) (fmap fab ta3))
|
2
test/testdata/tactic/GoldenFoldr.hs
vendored
Normal file
2
test/testdata/tactic/GoldenFoldr.hs
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
foldr2 :: (a -> b -> b) -> b -> [a] -> b
|
||||
foldr2 = _
|
5
test/testdata/tactic/GoldenFoldr.hs.expected
vendored
Normal file
5
test/testdata/tactic/GoldenFoldr.hs.expected
vendored
Normal file
@ -0,0 +1,5 @@
|
||||
foldr2 :: (a -> b -> b) -> b -> [a] -> b
|
||||
foldr2 = (\ f_b b l_a
|
||||
-> case l_a of
|
||||
[] -> b
|
||||
(a : l_a4) -> f_b a (foldr2 f_b b l_a4))
|
2
test/testdata/tactic/GoldenFromMaybe.hs
vendored
Normal file
2
test/testdata/tactic/GoldenFromMaybe.hs
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
fromMaybe :: a -> Maybe a -> a
|
||||
fromMaybe = _
|
5
test/testdata/tactic/GoldenFromMaybe.hs.expected
vendored
Normal file
5
test/testdata/tactic/GoldenFromMaybe.hs.expected
vendored
Normal file
@ -0,0 +1,5 @@
|
||||
fromMaybe :: a -> Maybe a -> a
|
||||
fromMaybe = (\ a ma
|
||||
-> case ma of
|
||||
Nothing -> a
|
||||
(Just a2) -> a2)
|
2
test/testdata/tactic/GoldenJoinCont.hs
vendored
2
test/testdata/tactic/GoldenJoinCont.hs
vendored
@ -1,4 +1,4 @@
|
||||
type Cont r a = ((a -> r) -> r)
|
||||
|
||||
joinCont :: Show a => (a -> c) -> (b -> c) -> Either a b -> (c -> d) -> d
|
||||
joinCont :: Cont r (Cont r a) -> Cont r a
|
||||
joinCont = _
|
||||
|
@ -1,7 +1,4 @@
|
||||
type Cont r a = ((a -> r) -> r)
|
||||
|
||||
joinCont :: Show a => (a -> c) -> (b -> c) -> Either a b -> (c -> d) -> d
|
||||
joinCont = (\ fac fbc eab fcd
|
||||
-> case eab of
|
||||
(Left a) -> fcd (fac a)
|
||||
(Right b) -> fcd (fbc b))
|
||||
joinCont :: Cont r (Cont r a) -> Cont r a
|
||||
joinCont = (\ f_r far -> f_r (\ f_r2 -> f_r2 far))
|
||||
|
2
test/testdata/tactic/GoldenListFmap.hs
vendored
Normal file
2
test/testdata/tactic/GoldenListFmap.hs
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
fmapList :: (a -> b) -> [a] -> [b]
|
||||
fmapList = _
|
5
test/testdata/tactic/GoldenListFmap.hs.expected
vendored
Normal file
5
test/testdata/tactic/GoldenListFmap.hs.expected
vendored
Normal file
@ -0,0 +1,5 @@
|
||||
fmapList :: (a -> b) -> [a] -> [b]
|
||||
fmapList = (\ fab l_a
|
||||
-> case l_a of
|
||||
[] -> []
|
||||
(a : l_a3) -> fab a : fmapList fab l_a3)
|
@ -1,2 +1,2 @@
|
||||
pureList :: a -> [a]
|
||||
pureList = (\ a -> (:) a [])
|
||||
pureList = (\ a -> a : [])
|
||||
|
2
test/testdata/tactic/GoldenSafeHead.hs
vendored
Normal file
2
test/testdata/tactic/GoldenSafeHead.hs
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
safeHead :: [x] -> Maybe x
|
||||
safeHead = _
|
5
test/testdata/tactic/GoldenSafeHead.hs.expected
vendored
Normal file
5
test/testdata/tactic/GoldenSafeHead.hs.expected
vendored
Normal file
@ -0,0 +1,5 @@
|
||||
safeHead :: [x] -> Maybe x
|
||||
safeHead = (\ l_x
|
||||
-> case l_x of
|
||||
[] -> Nothing
|
||||
(x : l_x2) -> Just x)
|
2
test/testdata/tactic/GoldenShow.hs
vendored
Normal file
2
test/testdata/tactic/GoldenShow.hs
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
showMe :: Show a => a -> String
|
||||
showMe = _
|
2
test/testdata/tactic/GoldenShow.hs.expected
vendored
Normal file
2
test/testdata/tactic/GoldenShow.hs.expected
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
showMe :: Show a => a -> String
|
||||
showMe = show
|
2
test/testdata/tactic/GoldenShowCompose.hs
vendored
Normal file
2
test/testdata/tactic/GoldenShowCompose.hs
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
showCompose :: Show a => (b -> a) -> b -> String
|
||||
showCompose = _
|
2
test/testdata/tactic/GoldenShowCompose.hs.expected
vendored
Normal file
2
test/testdata/tactic/GoldenShowCompose.hs.expected
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
showCompose :: Show a => (b -> a) -> b -> String
|
||||
showCompose = (\ fba b -> show (fba b))
|
2
test/testdata/tactic/GoldenShowMapChar.hs
vendored
Normal file
2
test/testdata/tactic/GoldenShowMapChar.hs
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
test :: Show a => a -> (String -> b) -> b
|
||||
test = _
|
2
test/testdata/tactic/GoldenShowMapChar.hs.expected
vendored
Normal file
2
test/testdata/tactic/GoldenShowMapChar.hs.expected
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
test :: Show a => a -> (String -> b) -> b
|
||||
test = (\ a fl_cb -> fl_cb (show a))
|
8
test/testdata/tactic/GoldenSuperclass.hs
vendored
Normal file
8
test/testdata/tactic/GoldenSuperclass.hs
vendored
Normal file
@ -0,0 +1,8 @@
|
||||
class Super a where
|
||||
super :: a
|
||||
|
||||
class Super a => Sub a
|
||||
|
||||
blah :: Sub a => a
|
||||
blah = _
|
||||
|
8
test/testdata/tactic/GoldenSuperclass.hs.expected
vendored
Normal file
8
test/testdata/tactic/GoldenSuperclass.hs.expected
vendored
Normal file
@ -0,0 +1,8 @@
|
||||
class Super a where
|
||||
super :: a
|
||||
|
||||
class Super a => Sub a
|
||||
|
||||
blah :: Sub a => a
|
||||
blah = super
|
||||
|
2
test/testdata/tactic/GoldenSwap.hs
vendored
Normal file
2
test/testdata/tactic/GoldenSwap.hs
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
swap :: (a, b) -> (b, a)
|
||||
swap = _
|
2
test/testdata/tactic/GoldenSwap.hs.expected
vendored
Normal file
2
test/testdata/tactic/GoldenSwap.hs.expected
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
swap :: (a, b) -> (b, a)
|
||||
swap = (\ p_ab -> case p_ab of { (a, b) -> (b, a) })
|
2
test/testdata/tactic/GoldenSwapMany.hs
vendored
Normal file
2
test/testdata/tactic/GoldenSwapMany.hs
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
swapMany :: (a, b, c, d, e) -> (e, d, c, b, a)
|
||||
swapMany = _
|
2
test/testdata/tactic/GoldenSwapMany.hs.expected
vendored
Normal file
2
test/testdata/tactic/GoldenSwapMany.hs.expected
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
swapMany :: (a, b, c, d, e) -> (e, d, c, b, a)
|
||||
swapMany = (\ pabcde -> case pabcde of { (a, b, c, d, e) -> (e, d, c, b, a) })
|
@ -6,9 +6,9 @@ module Test.Hls.Util
|
||||
, flushStackEnvironment
|
||||
, getHspecFormattedConfig
|
||||
, ghcVersion, GhcVersion(..)
|
||||
, hieCommand
|
||||
, hieCommandExamplePlugin
|
||||
, hieCommandVomit
|
||||
, hlsCommand
|
||||
, hlsCommandExamplePlugin
|
||||
, hlsCommandVomit
|
||||
, logConfig
|
||||
, logFilePath
|
||||
, noLogConfig
|
||||
@ -31,6 +31,7 @@ import System.Environment
|
||||
import System.FilePath
|
||||
import qualified System.Log.Logger as L
|
||||
import System.IO.Temp
|
||||
import System.IO.Unsafe
|
||||
import Test.Hspec.Runner
|
||||
import Test.Hspec.Core.Formatters
|
||||
import Text.Blaze.Renderer.String (renderMarkup)
|
||||
@ -95,13 +96,16 @@ files =
|
||||
]
|
||||
|
||||
data GhcVersion
|
||||
= GHC88
|
||||
= GHC810
|
||||
| GHC88
|
||||
| GHC86
|
||||
| GHC84
|
||||
deriving (Eq,Show)
|
||||
|
||||
ghcVersion :: GhcVersion
|
||||
#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,8,0,0)))
|
||||
#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)))
|
||||
ghcVersion = GHC810
|
||||
#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,8,0,0)))
|
||||
ghcVersion = GHC88
|
||||
#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)))
|
||||
ghcVersion = GHC86
|
||||
@ -110,24 +114,23 @@ ghcVersion = GHC84
|
||||
#endif
|
||||
|
||||
logFilePath :: String
|
||||
logFilePath = "hie-" ++ show ghcVersion ++ ".log"
|
||||
logFilePath = "hls-" ++ show ghcVersion ++ ".log"
|
||||
|
||||
-- | The command to execute the version of hie for the current compiler.
|
||||
--
|
||||
-- Both @stack test@ and @cabal new-test@ setup the environment so @hie@ is
|
||||
-- on PATH. Cabal seems to respond to @build-tool-depends@ specifically while
|
||||
-- stack just puts all project executables on PATH.
|
||||
hieCommand :: String
|
||||
-- hieCommand = "hie --lsp --bios-verbose -d -l test-logs/" ++ logFilePath
|
||||
-- hieCommand = "haskell-language-server --lsp"
|
||||
-- hieCommand = "haskell-language-server --lsp --test --shake-profiling=test-logs/" ++ logFilePath
|
||||
hieCommand = "haskell-language-server --lsp -d -l test-logs/" ++ logFilePath
|
||||
hlsCommand :: String
|
||||
hlsCommand = unsafePerformIO $ do
|
||||
testExe <- fromMaybe "haskell-language-server" <$> lookupEnv "HLS_TEST_EXE"
|
||||
pure $ testExe ++ " --lsp -d -l test-logs/" ++ logFilePath
|
||||
|
||||
hieCommandVomit :: String
|
||||
hieCommandVomit = hieCommand ++ " --vomit"
|
||||
hlsCommandVomit :: String
|
||||
hlsCommandVomit = hlsCommand ++ " --vomit"
|
||||
|
||||
hieCommandExamplePlugin :: String
|
||||
hieCommandExamplePlugin = hieCommand ++ " --example"
|
||||
hlsCommandExamplePlugin :: String
|
||||
hlsCommandExamplePlugin = hlsCommand ++ " --example"
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user