haskell/haskell-language-server
1
1
Fork 0
mirror of https://github.com/haskell/haskell-language-server.git synced 2024-09-19 20:57:21 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into tactic-exclude-coercions

Browse Source
This commit is contained in:
Hiromi ISHII 2020-11-23 12:24:35 +09:00
commit 8050b14406
No known key found for this signature in database
GPG Key ID: 2264973C1115F8EA
101 changed files with 3274 additions and 841 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
.circleci/config.yml
View File

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

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

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

@ -6,6 +6,8 @@ cabal.project.local
*~
*.lock
.tasty-rerun-log
# shake build information
_build/

363
ChangeLog.md
View File

@ -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,68 +219,68 @@ 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
cabal: 3.2.0.0
stack: 2.3.3
ghc: 8.10.2
cabal: 3.2.0.0
stack: 2.3.3
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
View File

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

14
cabal.project
View File

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

5
exe/Main.hs
View File

@ -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
@ -55,11 +57,12 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
, StylishHaskell.descriptor "stylish-haskell"
, Retrie.descriptor "retrie"
#if AGPL
, Brittany.descriptor "brittany"
, Brittany.descriptor "brittany"
#endif
, Eval.descriptor "eval"
, ImportLens.descriptor "importLens"
, ModuleName.descriptor "moduleName"
, Hlint.descriptor "hlint"
]
examplePlugins =
[Example.descriptor "eg"

2
ghcide

@ -1 +1 @@
Subproject commit c1678223bbe9ec73628888ef466e0e471258040c
Subproject commit 9b8aaf9b06846571cc0b5d46680e686e4f9153a3

34
haskell-language-server.cabal
View File

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

7
hie.yaml.cbl
View File

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

9
hie.yaml.stack
View File

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

5
hls-plugin-api/hls-plugin-api.cabal
View File

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

13
hls-plugin-api/src/Ide/Plugin.hs
View File

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

14
hls-plugin-api/src/Ide/Plugin/Formatter.hs
View File

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

4
plugins/default/src/Ide/Plugin/Eval.hs
View File

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

8
plugins/default/src/Ide/Plugin/ImportLens.hs
View File

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

1
plugins/default/src/Ide/Plugin/ModuleName.hs
View File

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

20
plugins/default/src/Ide/Plugin/Retrie.hs
View File

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

112
plugins/tactics/src/Ide/Plugin/Tactic.hs
View File

@ -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,20 +297,27 @@ 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
case runTactic ctx jdg
$ tac
$ mkVarOcc
$ T.unpack var_name of
Left err ->
pure $ (, Nothing)
$ Left
$ ResponseError InvalidRequest (T.pack $ show err) Nothing
Right res -> do
let g = graft (RealSrcSpan span) res
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)
x <- lift $ timeout 2e8 $
case runTactic ctx jdg
$ tac
$ mkVarOcc
$ T.unpack var_name of
Left err ->
pure $ (, Nothing)
$ Left
$ ResponseError InvalidRequest (T.pack $ show err) Nothing
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
View 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

187
plugins/tactics/src/Ide/Plugin/Tactic/CodeGen.hs
View File

@ -1,35 +1,70 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Ide.Plugin.Tactic.CodeGen where
import Control.Monad.Except
import Data.List
import Data.Traversable
import DataCon
import Development.IDE.GHC.Compat
import GHC.Exts
import GHC.SourceGen.Binds
import GHC.SourceGen.Expr
import GHC.SourceGen.Overloaded
import GHC.SourceGen.Pat
import Ide.Plugin.Tactic.Judgements
import Ide.Plugin.Tactic.Machinery
import Ide.Plugin.Tactic.Naming
import Ide.Plugin.Tactic.Types
import Name
import Type hiding (Var)
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
import GHC.SourceGen.Pat
import Ide.Plugin.Tactic.Judgements
import Ide.Plugin.Tactic.Machinery
import Ide.Plugin.Tactic.Naming
import Ide.Plugin.Tactic.Types
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

86
plugins/tactics/src/Ide/Plugin/Tactic/Context.hs
View File

@ -3,23 +3,77 @@
module Ide.Plugin.Tactic.Context where
import Bag
import Control.Arrow
import Control.Monad.Reader
import Development.IDE.GHC.Compat
import Ide.Plugin.Tactic.Types
import OccName
import TcRnTypes
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
. (getFunBindId =<<)
. fmap unLoc
. bagToList
. tcg_binds
mkContext locals tcg = Context
{ ctxDefiningFuncs = locals
, ctxModuleFuncs = fmap splitId
. (getFunBindId =<<)
. fmap unLoc
. bagToList
$ 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

41
plugins/tactics/src/Ide/Plugin/Tactic/Debug.hs
View File

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

103
plugins/tactics/src/Ide/Plugin/Tactic/GHC.hs
View File

@ -1,15 +1,24 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
module Ide.Plugin.Tactic.GHC where
import Data.Maybe (isJust)
import TcType
import TyCoRep
import TyCon
import Type
import TysWiredIn (intTyCon, floatTyCon, doubleTyCon, charTyCon)
import Unique
import Var
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 Type
import TysWiredIn (intTyCon, floatTyCon, doubleTyCon, charTyCon)
import Unique
import Var
tcTyVar_maybe :: Type -> Maybe Var
@ -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

363
plugins/tactics/src/Ide/Plugin/Tactic/Judgements.hs
View File

@ -1,14 +1,47 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# 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
View 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
]

242
plugins/tactics/src/Ide/Plugin/Tactic/Machinery.hs
View File

@ -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
modify (\s -> s { ts_unifier = unionTCvSubst subst (ts_unifier s) })
Nothing -> throwError (UnificationError inst goal)
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

241
plugins/tactics/src/Ide/Plugin/Tactic/Tactics.hs
View File

@ -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
useOccName jdg name
pure $ noLoc $ var' name
False -> throwError $ GoalMismatch "assume" g
Just (hi_type -> ty) -> do
unify ty $ jGoal jdg
for_ (M.lookup name $ jPatHypothesis jdg) markStructuralySmallerRecursion
useOccName jdg name
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,73 +100,142 @@ 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
. foldl' (@@) (var' func)
$ fmap unLoc sgs
Nothing -> throwError $ GoalMismatch "apply" g
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 -> 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
------------------------------------------------------------------------------
-- | Attempt to instantiate the given data constructor to solve the goal.
splitDataCon :: DataCon -> TacticsM ()
splitDataCon dc = rule $ \jdg -> do
-- | 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
Just (tc, apps) -> do
case elem dc $ tyConDataCons tc of
True -> buildDataCon jdg dc apps
False -> throwError $ IncorrectDataCon dc
Nothing -> throwError $ GoalMismatch "splitDataCon" g
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 =
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 (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]

286
plugins/tactics/src/Ide/Plugin/Tactic/Types.hs
View File

@ -1,10 +1,15 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# 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
, _jGoal :: !(a)
{ _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

3
plugins/tactics/src/Ide/TreeTransform.hs
View File

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

@ -0,0 +1 @@
{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Main #-}

65
plugins/tactics/test/UnificationSpec.hs Normal file
View 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

18
stack-8.10.1.yaml
View File

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

14
stack-8.10.2.yaml
View File

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

20
stack-8.6.4.yaml
View File

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

18
stack-8.6.5.yaml
View File

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

23
stack-8.8.2.yaml
View File

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

22
stack-8.8.3.yaml
View File

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

21
stack-8.8.4.yaml
View File

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

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

4
test/functional/Command.hs
View File

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

48
test/functional/Completion.hs
View File

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

12
test/functional/Deferred.hs
View File

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

10
test/functional/Definition.hs
View File

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

8
test/functional/Diagnostic.hs
View File

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

34
test/functional/Eval.hs
View File

@ -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
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"
liftIO $ edited @?= expected
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 <- 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"

34
test/functional/Format.hs
View File

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

4
test/functional/FunctionalBadProject.hs
View File

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

207
test/functional/FunctionalCodeAction.hs
View File

@ -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`
[ "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`
[ "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`
[ "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"
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)"
]
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)"
]
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)"
]
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`
[ "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`
[ "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`
[ "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"
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)"
]
substitutions GHC86 =
[ "Substitute hole (A) with stuff (A -> A)"
, "Substitute hole (A) with x ([A])"
, "Substitute hole (A) with foo2 ([A] -> A)"
]
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)"
]
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

6
test/functional/FunctionalLiquid.hs
View File

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

4
test/functional/HieBios.hs
View File

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

2
test/functional/Highlight.hs
View File

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

4
test/functional/ModuleName.hs
View File

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

4
test/functional/Progress.hs
View File

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

4
test/functional/Reference.hs
View File

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

2
test/functional/Rename.hs
View File

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

10
test/functional/Symbol.hs
View File

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

63
test/functional/Tactic.hs
View File

@ -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)
------------------------------------------------------------------------------
@ -86,16 +91,31 @@ tests = testGroup
[ (not, DestructLambdaCase, "")
]
, goldenTest "GoldenIntros.hs" 2 8 Intros ""
, goldenTest "GoldenEitherAuto.hs" 2 11 Auto ""
, goldenTest "GoldenJoinCont.hs" 4 12 Auto ""
, goldenTest "GoldenIdentityFunctor.hs" 3 11 Auto ""
, goldenTest "GoldenIdTypeFam.hs" 7 11 Auto ""
, goldenTest "GoldenEitherAuto.hs" 2 11 Auto ""
, goldenTest "GoldenJoinCont.hs" 4 12 Auto ""
, goldenTest "GoldenIdentityFunctor.hs" 3 11 Auto ""
, goldenTest "GoldenIdTypeFam.hs" 7 11 Auto ""
, 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

16
test/functional/TypeDefinition.hs
View File

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

@ -1,4 +0,0 @@
main = (putStrLn "hello")
foo x = (x + 1)

0
test/testdata/ApplyRefact2.hs → test/testdata/hlint/ApplyRefact2.hs vendored
View File

4
test/testdata/hlint/hie.yaml vendored Normal file
View File

@ -0,0 +1,4 @@
cradle:
direct:
arguments:
- "ApplyRefact2"

2
test/testdata/tactic/GoldenApplicativeThen.hs vendored Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View File

@ -0,0 +1,2 @@
foldr2 :: (a -> b -> b) -> b -> [a] -> b
foldr2 = _

5
test/testdata/tactic/GoldenFoldr.hs.expected vendored Normal file
View 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
View File

@ -0,0 +1,2 @@
fromMaybe :: a -> Maybe a -> a
fromMaybe = _

5
test/testdata/tactic/GoldenFromMaybe.hs.expected vendored Normal file
View 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
View File

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

7
test/testdata/tactic/GoldenJoinCont.hs.expected vendored
View File

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

@ -0,0 +1,2 @@
fmapList :: (a -> b) -> [a] -> [b]
fmapList = _

5
test/testdata/tactic/GoldenListFmap.hs.expected vendored Normal file
View 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)

2
test/testdata/tactic/GoldenPureList.hs.expected vendored
View File

@ -1,2 +1,2 @@
pureList :: a -> [a]
pureList = (\ a -> (:) a [])
pureList = (\ a -> a : [])

2
test/testdata/tactic/GoldenSafeHead.hs vendored Normal file
View File

@ -0,0 +1,2 @@
safeHead :: [x] -> Maybe x
safeHead = _

5
test/testdata/tactic/GoldenSafeHead.hs.expected vendored Normal file
View 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
View File

@ -0,0 +1,2 @@
showMe :: Show a => a -> String
showMe = _

2
test/testdata/tactic/GoldenShow.hs.expected vendored Normal file
View File

@ -0,0 +1,2 @@
showMe :: Show a => a -> String
showMe = show

2
test/testdata/tactic/GoldenShowCompose.hs vendored Normal file
View File

@ -0,0 +1,2 @@
showCompose :: Show a => (b -> a) -> b -> String
showCompose = _

2
test/testdata/tactic/GoldenShowCompose.hs.expected vendored Normal file
View 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
View File

@ -0,0 +1,2 @@
test :: Show a => a -> (String -> b) -> b
test = _

2
test/testdata/tactic/GoldenShowMapChar.hs.expected vendored Normal file
View 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
View 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
View 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
View File

@ -0,0 +1,2 @@
swap :: (a, b) -> (b, a)
swap = _

2
test/testdata/tactic/GoldenSwap.hs.expected vendored Normal file
View 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
View 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
View 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) })

33
test/utils/Test/Hls/Util.hs
View File

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