diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,679 @@ +# Changelog for haskell-language-server + +## 0.8.0 + +- This version adds support for ghc-8.10.3 +- `hls-plugin-api` has been bumped to 0.6.0.0 and `ghcide` has been bumped from 0.6.0.1 to 0.7.0.0. +- It has a new brand plugin: hls-class-plugin, which helps to write class instances + +![gif](https://user-images.githubusercontent.com/12473268/103059293-af071f80-4572-11eb-963a-7e76b45f28b9.gif) + +- The eval plugin has been revamped, adding these new features: + - Tests in both plain comments and Haddock comments + - For Haddock comments: shows differences between latest and previous result + - Setup section, executed before every test + - Execution of a section/group of tests at the time + - Property testing + - Setup of GHC extensions +- A new tactic to generate automatically `Arbitrary` instances has been added to tactic plugin +- There had been lot of internal changes: + - ghcide lives now directly in this repository + - the test suite has been cleaned and improved (continuing the work done in 0.7.0) + + +Thanks to all contributors and happy new year! + +### Pull requests merged for 0.8.0 + +- Ci fixes +([#783)](https://github.com/haskell/haskell-language-server/pull/783) by @pepeiborra +- Fix extend imports regression +([#769)](https://github.com/haskell/haskell-language-server/pull/769) by @pepeiborra +- Cleanup format testfiles +([#765)](https://github.com/haskell/haskell-language-server/pull/765) by @peterwicksstringfield +- Retry a failed cradle if the cradle descriptor changes +([#762)](https://github.com/haskell/haskell-language-server/pull/762) by @pepeiborra +- Perform memory measurement on SIGUSR1 +([#761)](https://github.com/haskell/haskell-language-server/pull/761) by @pepeiborra +- Add ghc-8.10.3 support after merging ghcide repo +([#721)](https://github.com/haskell/haskell-language-server/pull/721) by @jneira +- Merge ghcide repository (replacing the submodule) +([#702)](https://github.com/haskell/haskell-language-server/pull/702) by @pepeiborra +- Invert the dependency between hls-plugin-api and ghcide +([#701)](https://github.com/haskell/haskell-language-server/pull/701) by @pepeiborra +- Move eval plugin to hls-eval-plugin +([#700)](https://github.com/haskell/haskell-language-server/pull/700) by @tittoassini +- Fix and enable progress message tests. +([#698)](https://github.com/haskell/haskell-language-server/pull/698) by @peterwicksstringfield +- Add a known tactic for writing arbitrary instances +([#695)](https://github.com/haskell/haskell-language-server/pull/695) by @isovector +- Introduce generic config for plugins +([#691)](https://github.com/haskell/haskell-language-server/pull/691) by @alanz +- Enable get type definition tests +([#690)](https://github.com/haskell/haskell-language-server/pull/690) by @peterwicksstringfield +- Fix ghc version for windows 8.10.2.2 in github build workflow +([#688)](https://github.com/haskell/haskell-language-server/pull/688) by @jneira +- Add plugins conditionally at compile time +([#687)](https://github.com/haskell/haskell-language-server/pull/687) by @jneira +- Implement basic Class plugin +([#661)](https://github.com/haskell/haskell-language-server/pull/661) by @Ailrun +- Extended Eval Plugin +([#438)](https://github.com/haskell/haskell-language-server/pull/438) by @tittoassini + +## 0.7.1 + +- This is a minor bug fix release: + - It fixes an issue that removed accidentally desugarer warnings (#676). + - It disables auto extend import lists in completions, see #679. + +### Pull requests merged for 0.7.1 + +- Disable auto extend import lists in completions. It fixes #679. +([#685)](https://github.com/haskell/haskell-language-server/pull/685) by @pepeiborra +- Restore kick (#676). It fixes #676. +([#677)](https://github.com/haskell/haskell-language-server/pull/677) by @wz1000 +- README: Remove instructions to execute data target +([#675)](https://github.com/haskell/haskell-language-server/pull/675) by @andys8 +- Add hlint tests over cpp, extensions and ignore hints +([#674)](https://github.com/haskell/haskell-language-server/pull/674) by @jneira + +## 0.7.0 + +- This version contains mainly refactors and updates of upstream packages +- It bumps up some formatter versions: + - ormolu is 0.1.4.1 + - fourmolu is 0.3.0.0 + - brittany is 0.13.1.0 +- It uses last implicit-hie-cradle-0.3.0.2, with some [bug](https://github.com/Avi-D-coder/implicit-hie/issues/29) [fixes](https://github.com/Avi-D-coder/implicit-hie/issues/30) +- It uses last ghcide-0.6.0.1 with [improvements and bug fixes](https://github.com/haskell/ghcide/blob/master/CHANGELOG.md#060-2020-12-06): + - Do not enable every "unnecessary" warning by default + - Improvements over completions: + - record fields + - identifiers not in explicit import lists + - extend explicit import list automatically + +Thanks to all haskell-language-server, ghcide and other upstream packages contributors (the list continue growing healthy) for make this release possible. + +### Pull requests merged for 0.7.0 + +- Miscellanous fixes: correct tactic plugin package metadata and cabal.hie.yaml/stack.hie.yaml +([#672)](https://github.com/haskell/haskell-language-server/pull/672) by @berberman +- Remove unnecessary pluginId setting and user Better Map functions in tactics plugin +([#669)](https://github.com/haskell/haskell-language-server/pull/669) by @jhrcek +- Do not suggest explicitly disabled pragmas +([#666)](https://github.com/haskell/haskell-language-server/pull/666) by @berberman +- fixed hie.yaml.stack +([#664)](https://github.com/haskell/haskell-language-server/pull/664) by @tittoassini +- Add pragmas completions +([#662)](https://github.com/haskell/haskell-language-server/pull/662) by @gdevanla +- Enable code completion tests +([#657)](https://github.com/haskell/haskell-language-server/pull/657) by @peterwicksstringfield +- Enable highlight unittests +([#656)](https://github.com/haskell/haskell-language-server/pull/656) by @peterwicksstringfield +- Fix document symbols unit tests. +([#655)](https://github.com/haskell/haskell-language-server/pull/655) by @peterwicksstringfield +- Delete duplicate cabal clause for applyrefact2 +([#654)](https://github.com/haskell/haskell-language-server/pull/654) by @peterwicksstringfield +- Add extra-source-files for split plugins +([#650)](https://github.com/haskell/haskell-language-server/pull/650) by @berberman +- [nix-shell] Actually use gitignore +([#649)](https://github.com/haskell/haskell-language-server/pull/649) by @pepeiborra +- idempotent command and code cleanup +([#648)](https://github.com/haskell/haskell-language-server/pull/648) by @tittoassini +- Split the Imports and Retrie plugins +([#647)](https://github.com/haskell/haskell-language-server/pull/647) by @pepeiborra +- Simplify and Bump implicit-hie version constraints +([#645)](https://github.com/haskell/haskell-language-server/pull/645) by @Avi-D-coder +- Fix and enable disabled code action unit tests, fix fallback handler +([#643)](https://github.com/haskell/haskell-language-server/pull/643) by @peterwicksstringfield +- Add Ghcide hie.yaml instruction for Stack users +([#641)](https://github.com/haskell/haskell-language-server/pull/641) by @Sir4ur0n +- Upgrade the Nix build system +([#639)](https://github.com/haskell/haskell-language-server/pull/639) by @pepeiborra +- No longer needed to build once for Stack +([#637)](https://github.com/haskell/haskell-language-server/pull/637) by @Sir4ur0n +- Preserve the last empty comment line after eval plugin +([#631)](https://github.com/haskell/haskell-language-server/pull/631) by @expipiplus1 +- Update fourmolu to 0.3.0.0 +([#624)](https://github.com/haskell/haskell-language-server/pull/624) by @gwils +- Add hspec-discover to build-tool-depends in tactics plugin +([#623)](https://github.com/haskell/haskell-language-server/pull/623) by @gwils +- Add build to ghc-8.10.2 and windows +([#619)](https://github.com/haskell/haskell-language-server/pull/619) by @jneira +- Module Name Plugin: Treat modules starting with lowercase as Main module +([#616)](https://github.com/haskell/haskell-language-server/pull/616) by @konn +- Bump ormolu to 0.1.4.1 +([#614)](https://github.com/haskell/haskell-language-server/pull/614) by @AlistairB +- Fix fourmolu plugin inconsistent formatting +([#599)](https://github.com/haskell/haskell-language-server/pull/599) by @zweimach +- Hlint: bring over idea2Message for formatting +([#598)](https://github.com/haskell/haskell-language-server/pull/598) by @alanz +- Makes dictionary argument exclusion logic in Tactic plugin more robust +([#508)](https://github.com/haskell/haskell-language-server/pull/508) by @konn + +## 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 for 0.6.0 + +- 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 for 0.5.1 + +- 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 +([#482)](https://github.com/haskell/haskell-language-server/pull/482) by @maksbotan +- 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 +([#475)](https://github.com/haskell/haskell-language-server/pull/475) by @Anrock +- 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 +([#470)](https://github.com/haskell/haskell-language-server/pull/470) by @iyefrat +- 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 +([#422)](https://github.com/haskell/haskell-language-server/pull/422) by @AlistairB + +## 0.5.0 + +0.5.0 comes with a new tactics plugin which provides case splitting, homomorphic case splitting, and lambda introduction: + +![Case splitting](https://user-images.githubusercontent.com/307223/92657198-3d4be400-f2a9-11ea-8ad3-f541c8eea891.gif) + +It can even attempt to fully fill a hole! + +![Attempt to fill in hole code action](https://user-images.githubusercontent.com/307223/94743611-82a18580-032c-11eb-9f13-8f46bc45f928.gif) + +The imports lens plugin also learnt a new code action to make all imports explicit: + +![Explicit imports code action](https://user-images.githubusercontent.com/2488460/94994815-1a53dd80-0592-11eb-8a12-ec704ae92385.gif) + +There's also plenty of bug fixes, improvements and updates to the underlying tools, including Fourmolu, implicit-hie-cradle and ghcide. [Some of the improvements from ghcide](https://github.com/haskell/ghcide/releases/tag/v0.4.0) include: + +- The entire project is typechecked on load +- Reverse dependencies of a module are typechecked upon saving +- Code completion includes local terms +- Import code actions now also suggest open imports +- Documentation on hover shows for symbols defined in the same module + +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 for 0.5.0 + +- 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 +([#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 +([#454)](https://github.com/haskell/haskell-language-server/pull/454) by @bubba +- 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 +([#448)](https://github.com/haskell/haskell-language-server/pull/448) by @ocharles +- Update README.md +([#446)](https://github.com/haskell/haskell-language-server/pull/446) by @moodmosaic +- 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 +([#439)](https://github.com/haskell/haskell-language-server/pull/439) by @jneira +- 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 +([#432)](https://github.com/haskell/haskell-language-server/pull/432) by @googleson78 +- 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 +([#428)](https://github.com/haskell/haskell-language-server/pull/428) by @Anrock +- 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 +([#424)](https://github.com/haskell/haskell-language-server/pull/424) by @pepeiborra +- Separate paragraphs +([#423)](https://github.com/haskell/haskell-language-server/pull/423) by @jneira +- 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 +([#419)](https://github.com/haskell/haskell-language-server/pull/419) by @jneira +- 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 +([#408)](https://github.com/haskell/haskell-language-server/pull/408) by @pepeiborra +- Progress reporting for Eval plugin +([#398)](https://github.com/haskell/haskell-language-server/pull/398) by @pepeiborra +- bump ghcide submodule +([#396)](https://github.com/haskell/haskell-language-server/pull/396) by @wz1000 +- Fix cradles +([#393)](https://github.com/haskell/haskell-language-server/pull/393) by @pepeiborra +- Case splitting and lambda introduction +([#391)](https://github.com/haskell/haskell-language-server/pull/391) by @isovector +- 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 +([#379)](https://github.com/haskell/haskell-language-server/pull/379) by @jneira +- Rebase on ghcide HEAD +([#378)](https://github.com/haskell/haskell-language-server/pull/378) by @pepeiborra +- README clarify how exactly to use code evaluation +([#377)](https://github.com/haskell/haskell-language-server/pull/377) by @DunetsNM +- Revise README.md +([#374)](https://github.com/haskell/haskell-language-server/pull/374) by @gihyeonsung + +## 0.4.0 + +0.4.0 introduces the import lens plugin, which can convert your import statements into qualified imports, or into an explicit import list: + +![Imports code lens](https://imgur.com/pX9kvY4.gif) + +The eval plugin has also learnt two new commands, `:type` and `:kind`: + +```haskell +{-# LANGUAGE TypeApplications #-} +foo :: Show a => a -> String +foo = show + +-- >>> :type foo @Int +-- foo @Int :: Int -> String + +-- >>> :type +v foo @Int +-- foo @Int :: Show Int => Int -> String +``` + +```haskell +-- >>> type N = 1 +-- >>> type M = 40 +-- >>> :kind N + M + 1 +-- N + M + 1 :: Nat + +-- >>> type N = 1 +-- >>> type M = 40 +-- >>> :kind N + M + 1 +-- N + M + 1 :: Nat +``` + +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 +``` + +### Pull requests merged for 0.4.0 + +- Bring over a [tutorial about how to add hls plugins](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 +([#370](https://github.com/haskell/haskell-language-server/pull/370) by @alanz) +- 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 +([#343](https://github.com/haskell/haskell-language-server/pull/343) by @rgleichman) +- 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 +([#357](https://github.com/haskell/haskell-language-server/pull/357) by @maralorn) +- 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 +([#321](https://github.com/haskell/haskell-language-server/pull/321) by @pepeiborra) +- 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) +([#310](https://github.com/haskell/haskell-language-server/pull/310) by @pepeiborra) +- 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 +([#350](https://github.com/haskell/haskell-language-server/pull/350) by @willbush) +- 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 +([#329](https://github.com/haskell/haskell-language-server/pull/329) by @Sir4ur0n) +- 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 +([#332](https://github.com/haskell/haskell-language-server/pull/332) by @jneira) +- 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 +([#328](https://github.com/haskell/haskell-language-server/pull/328) by @Sir4ur0n) +- Replace wrong occurrences of "engine" by "server" +([#319](https://github.com/haskell/haskell-language-server/pull/319) by @tchoutri) +- Simplify coc.nvim instructions +([#315](https://github.com/haskell/haskell-language-server/pull/315) by @oblitum) +- 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 +([#312](https://github.com/haskell/haskell-language-server/pull/312) by @jneira) +- 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 +([#309](https://github.com/haskell/haskell-language-server/pull/309) by @fendor) +- 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 +([#264](https://github.com/haskell/haskell-language-server/pull/264) by @georgefst) + +## 0.3.0 + +0.3.0 comes with two new plugins, retrie and fourmolu, provides binaries for +GHC 8.8.4, and comes with a host of bug fixes. + +The retrie plugin supports RULES, functions and type synonyms which can be +accessed through contextual code actions. + +Fourmolu can be used to format your code by setting the +`haskell.formattingProvider` field in your LSP configuration to + +```json +{ + "haskell": { + "formattingProvider": "fourmolu" + } +} +``` + +The Brittany formatter is now also available on GHC 8.10.1. + +### Pull requests merged + +- Fix haddock parse error in install.hs +([#255](https://github.com/haskell/haskell-language-server/pull/255) by @georgefst) +- Ormolu flags +([#246](https://github.com/haskell/haskell-language-server/pull/246) by @pepeiborra) +- Ormolu fix +([#257](https://github.com/haskell/haskell-language-server/pull/257) by @sureyeaah) +- Remove redundant CircleCI steps +([#259](https://github.com/haskell/haskell-language-server/pull/259) by @bubba) +- Slow down Tasty by limiting it to -j1 +([#261](https://github.com/haskell/haskell-language-server/pull/261) by @bubba) +- Remove hspec-expectations +([#260](https://github.com/haskell/haskell-language-server/pull/260) by @bubba) +- Remove a redundant caching step +([#262](https://github.com/haskell/haskell-language-server/pull/262) by @Ailrun) +- add hie.yaml to coc configuration +([#267](https://github.com/haskell/haskell-language-server/pull/267) by @sureyeaah) +- Initial Retrie plugin +([#266](https://github.com/haskell/haskell-language-server/pull/266) by @pepeiborra) +- Add exe extension to win executables +([#284](https://github.com/haskell/haskell-language-server/pull/284) by @jneira) +- Use wz1000/hls-3 ghcide branch +([#275](https://github.com/haskell/haskell-language-server/pull/275) by @alanz) +- Fix rename capability being declared +([#285](https://github.com/haskell/haskell-language-server/pull/285) by @bubba) +- 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 +([#250](https://github.com/haskell/haskell-language-server/pull/250) by @fendor) +- 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 +([#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 +([#264](https://github.com/haskell/haskell-language-server/pull/264) by @georgefst) +- Trying new hls-3 branch +([#300](https://github.com/haskell/haskell-language-server/pull/300) by @alanz) + +## 0.2.2 + +This changes the configuration section from "languageServerHaskell" to "haskell" +to align it with vscode-haskell-1.0.0. Whilst the old section is still +supported for now, you should update your LSP configuration (which varies per +client) from + +```json +{ + "languageServerHaskell": { + "formattingProvider": "stylish-haskell" + } +} +``` + +to + +```json +{ + "haskell": { + "formattingProvider": "stylish-haskell" + } +} +``` + +### Pull requests merged for 0.2.2 + +- 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 +([#224](https://github.com/haskell/haskell-language-server/pull/224) by @bubba) +- 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 +([#214](https://github.com/haskell/haskell-language-server/pull/214) by @jneira) +- slightly better shell.nix for local development +([#235](https://github.com/haskell/haskell-language-server/pull/235) by @pepeiborra) +- Shell nix further steps +([#240](https://github.com/haskell/haskell-language-server/pull/240) by @pepeiborra) +- 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 +([#243](https://github.com/haskell/haskell-language-server/pull/243) by @bubba) +- 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 +([#248](https://github.com/haskell/haskell-language-server/pull/248) by @bubba) + +## 0.2.1 + +This release includes a new eval plugin that allows Haddock code examples to be +evaluated through a code lens. For example, the code below will now offer to +evaluate `intercalate " " example`, and will insert the output in the line +below. + +```haskell +example :: [String] +example = ["This is an example", "of", "interactive", "evaluation"] + +-- >>> intercalate " " example +-- "This is an example of interactive evaluation" +-- +``` + +This is also the first release to have binaries distributed alongside it. Some +behind the scene changes include the GHC library directory now being obtained on +the fly, so either `ghc`, `cabal` or `stack` will need to be present on your +PATH depending on your project. See `docs/releases.md` for more information. If +you find any issues with this, please let us know! + +### Pull requests merged for 0.2.1 + +- Bump ormolu to 0.1.2.0 +([#189](https://github.com/haskell/haskell-language-server/pull/189) by @AlistairB) +- 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 +([#199](https://github.com/haskell/haskell-language-server/pull/199) by @bubba) +- Fix install script stack targets +([#203](https://github.com/haskell/haskell-language-server/pull/203) by @jneira) +- Add support for ghc-8.8.4 +([#206](https://github.com/haskell/haskell-language-server/pull/206) by @jneira) +- Simple Eval plugin +([#191](https://github.com/haskell/haskell-language-server/pull/191) by @pepeiborra) +- Distributable binaries +([#165](https://github.com/haskell/haskell-language-server/pull/165) by @bubba) + +## 0.2 + +- Use cabal-plan from Hackage +([#185](https://github.com/haskell/haskell-language-server/pull/185) by @georgefst) +- 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 +([#177](https://github.com/haskell/haskell-language-server/pull/177) by @Sir4ur0n) +- 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 +([#163](https://github.com/haskell/haskell-language-server/pull/163) by @fendor) +- Use an unique install/stack.yaml +([#154](https://github.com/haskell/haskell-language-server/pull/154) by @jneira) +- Introduce golden testing +([#152](https://github.com/haskell/haskell-language-server/pull/152) by @Ailrun) +- 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 +([#147](https://github.com/haskell/haskell-language-server/pull/147) by @Sir4ur0n) +- [Plugin] stylish-haskell formatter +([#146](https://github.com/haskell/haskell-language-server/pull/146) by @Ailrun) +- 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 +([#136](https://github.com/haskell/haskell-language-server/pull/136) by @jneira) +- Add zlibc to readme +([#134](https://github.com/haskell/haskell-language-server/pull/134) by @Sir4ur0n) +- Complete editor integrations +([#132](https://github.com/haskell/haskell-language-server/pull/132) by @jneira) +- Remove inexistent component from hie.yaml.stack +([#131](https://github.com/haskell/haskell-language-server/pull/131) by @jneira) +- Bump to new mpickering/ghcide +([#130](https://github.com/haskell/haskell-language-server/pull/130) by @alanz) +- Update ghc-lib-parser version +([#129](https://github.com/haskell/haskell-language-server/pull/129) by @jneira) +- Remove redundant import +([#128](https://github.com/haskell/haskell-language-server/pull/128) by @bubba) +- 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 +([#125](https://github.com/haskell/haskell-language-server/pull/125) by @414owen) +- Fix install script dev target +([#124](https://github.com/haskell/haskell-language-server/pull/124) by @jneira) +- 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 +([#120](https://github.com/haskell/haskell-language-server/pull/120) by @jneira) +- Add lower bound to tasty-ant-xml +([#119](https://github.com/haskell/haskell-language-server/pull/119) by @jneira) +- Fix build using brittany revision +([#117](https://github.com/haskell/haskell-language-server/pull/117) by @jneira) +- 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 +([#115](https://github.com/haskell/haskell-language-server/pull/115) by @yuanw) +- 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 +([#108](https://github.com/haskell/haskell-language-server/pull/108) by @jneira) +- [#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. +([#106](https://github.com/haskell/haskell-language-server/pull/106) by @jneira) +- 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 +([#100](https://github.com/haskell/haskell-language-server/pull/100) by @fendor) +- 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 +([#95](https://github.com/haskell/haskell-language-server/pull/95) by @jneira) +- Fix haddock parsing errors +([#92](https://github.com/haskell/haskell-language-server/pull/92) by @jneira) +- Update for haskell-lsp 0.22 +([#89](https://github.com/haskell/haskell-language-server/pull/89) by @alanz) +- 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 + +### Changes + +This is the initial version, so too many to list individually. + +The key point is that is now supports multi-component cradles, and has been in +daily use by the developers for some time. + +It still does not have feature parity with `haskell-ide-engine`, but it is +currently useful. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,749 @@ +# haskell-language-server + +[![License Apache 2.0][badge-license]][license] +[![CircleCI][badge-circleci]][circleci] + +[badge-license]: https://img.shields.io/badge/license-Apache2-green.svg?dummy +[license]: https://github.com/haskell/haskell-language-server/blob/master/LICENSE +[badge-circleci]: https://img.shields.io/circleci/project/github/haskell/haskell-language-server/master.svg +[circleci]: https://circleci.com/gh/haskell/haskell-language-server/ + +Integration point for [ghcide](https://github.com/haskell/ghcide) and [haskell-ide-engine](https://github.com/haskell/haskell-ide-engine). One IDE to rule +them all. Read the [project's +background](https://neilmitchell.blogspot.com/2020/01/one-haskell-ide-to-rule-them-all.html). + +- [Haskell Language Server (HLS)](#haskell-language-server) + - [Features](#features) + - [Installation](#installation) + - [Prerequisites](#prerequisites) + - [ghcup](#ghcup) + - [Visual Studio Code](#visual-studio-code) + - [Pre-built binaries](#pre-built-binaries) + - [Installation from source](#installation-from-source) + - [Common pre-requirements](#common-pre-requirements) + - [Linux-specific pre-requirements](#linux-specific-pre-requirements) + - [Windows-specific pre-requirements](#windows-specific-pre-requirements) + - [Download the source code](#download-the-source-code) + - [Building](#building) + - [Install via cabal](#install-via-cabal) + - [Install specific GHC Version](#install-specific-ghc-version) + - [Installation from Hackage](#installation-from-hackage) + - [Configuring haskell-language-server](#configuring-haskell-language-server) + - [Configuring your project build](#configuring-your-project-build) + - [Configuring your editor](#configuring-your-editor) + - [VS Code](#using-haskell-language-server-with-vs-code) + - [Sublime Text](#using-haskell-language-server-with-sublime-text) + - [Vim or Neovim](#using-haskell-language-server-with-vim-or-neovim) + - [Atom](#using-haskell-language-server-with-atom) + - [Emacs](#using-haskell-language-server-with-emacs) + - [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) + - [Using Stack](#using-stack) + - [Introduction tutorial](#instructions-tutorial) + - [Test your hacked HLS in your editor](#test-your-hacked-hls-in-your-editor) + +## Features + + - Code evaluation codelens (inspired by [Dante](https://github.com/jyp/dante#-reploid)). You can evaluate code by writing it in a comment of the form -- >>> + + ![Eval](https://i.imgur.com/bh992sT.gif) + +- Type information and documentation on hover. Note that currently, in order for docs to be displayed for dependencies, they must have been built with GHC's `-haddock` flag: + + - For cabal: + - Add to your global config file (e.g. `~/.cabal/config`): + ``` + program-default-options + ghc-options: -haddock + ``` + - Or, for a single project, run `cabal configure --ghc-options=-haddock` + + - For stack, add to global `$STACK_ROOT\config.yaml`, or project's `stack.yaml`: + ``` + ghc-options: + "$everything": -haddock + ``` + + This will cause compilation errors if a dependency contains invalid Haddock markup, though from GHC version 9.0, [these will be demoted to warnings](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/2377). + + - Integration with [retrie](https://hackage.haskell.org/package/retrie) + + ![Retrie](https://i.imgur.com/Ev7B87k.gif) + + - Code lenses for explicit import lists + + ![Imports code lens](https://imgur.com/pX9kvY4.gif) + + - Many more (TBD) + +## Installation + +### Prerequisites + +- For standalone `.hs`/`.lhs` files, [ghc](https://www.haskell.org/ghc/) must be installed and on the PATH. The easiest way to install it is with [ghcup](https://www.haskell.org/ghcup/) or [Chocolatey](https://www.haskell.org/platform/windows.html) on Windows. +- For Cabal based projects, both ghc and [cabal-install](https://www.haskell.org/cabal/) must be installed and on the PATH. It can also be installed with [ghcup](https://www.haskell.org/ghcup/) or [Chocolatey](https://www.haskell.org/platform/windows.html) on Windows. +- For Stack based projects, [stack](http://haskellstack.org) must be installed and on the PATH. + +### ghcup + +If you are using [`ghcup`](https://www.haskell.org/ghcup/) to manage your installations, you can install the latest version of `haskell-language-server` with +``` +ghcup install hls +``` + +### Visual Studio Code + +If you are using Visual Studio Code, the [Haskell extension](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) will automatically download and install `haskell-language-server` for you. + +### Pre-built binaries + +There are pre-built binaries available from the [releases page](https://github.com/haskell/haskell-language-server/releases) for Linux, Windows and macOS. +To install, download the `haskell-language-server-wrapper` executable for your platform as well as any `haskell-language-server` executables for the GHC versions you plan on working with, and either put them on your PATH or point your client to them. + +### Installation from source + +#### Common pre-requirements + +- `stack` or `cabal` must be in your PATH + - You need stack version >= 2.1.1 or cabal >= 2.4.0.0 +- `git` must be in your PATH +- The directory where `stack`or `cabal` put the binaries must be in you PATH: + - For stack you can get it with `stack path --local-bin` + - For cabal it is by default `$HOME/.cabal/bin` in linux and `%APPDATA%\cabal\bin` in windows. + +Tip: you can quickly check if some command is in your path by running the command. +If you receive some meaningful output instead of "command not found"-like message +then it means you have the command in PATH. + +#### Linux-specific pre-requirements + +On Linux you will need install a couple of extra libraries: +- [Unicode (ICU)](http://site.icu-project.org/) +- [NCURSES](https://www.gnu.org/software/ncurses/) +- [Zlib](https://zlib.net/) + +**Debian 9/Ubuntu 18.04 or earlier**: + +```bash +sudo apt install libicu-dev libtinfo-dev libgmp-dev zlib1g-dev +``` + +**Debian 10/Ubuntu 18.10 or later**: + +```bash +sudo apt install libicu-dev libncurses-dev libgmp-dev zlib1g-dev +``` + +**Fedora**: + +```bash +sudo dnf install libicu-devel ncurses-devel zlib-devel +``` + +#### Windows-specific pre-requirements + +In order to avoid problems with long paths on Windows you can do either one of the following: + +1. Clone the `haskell-language-server` to a short path, for example the root of your logical drive (e.g. to + `C:\hls`). Even if you choose `C:\haskell-language-server` you could hit the problem. If this doesn't work or you want to use a longer path, try the second option. + +2. If the `Local Group Policy Editor` is available on your system, go to: `Local Computer Policy -> Computer Configuration -> Administrative Templates -> System -> Filesystem` set `Enable Win32 long paths` to `Enabled`. If you don't have the policy editor you can use regedit by using the following instructions [here](https://docs.microsoft.com/en-us/windows/win32/fileio/naming-a-file#enable-long-paths-in-windows-10-version-1607-and-later). You also need to configure git to allow longer paths by using unicode paths. To set this for all your git repositories use `git config --system core.longpaths true` (you probably need an administrative shell for this) or for just this one repository use `git config core.longpaths true`. + +In addition make sure `haskell-language-server.exe` is not running by closing your editor, otherwise in case of an upgrade the executable can not be installed. + +#### Download the source code + +```bash +git clone https://github.com/haskell/haskell-language-server --recurse-submodules +cd haskell-language-server +``` + +#### Building + +Note, on first invocation of the build script with stack, a GHC is being installed for execution. +The GHC used for the `install.hs` can be adjusted in `./install/stack.yaml` by using a different resolver. + +Available commands can be seen with: + +```bash +stack ./install.hs help +``` + +Remember, this will take time to download a Stackage-LTS and an appropriate GHC for build +haskell-language-server the first time. + +##### Install via cabal + +The install-script can be invoked via `cabal` instead of `stack` with the command + +```bash +cabal v2-run ./install.hs --project-file install/shake.project +``` + +or using the existing alias script + +```bash +./cabal-hls-install +``` + +Running the script with cabal on windows requires a cabal version greater or equal to `3.0.0.0`. + +For brevity, only the `stack`-based commands are presented in the following sections. + +##### Install specific GHC Version + +The script will install the executables `haskell-language-server-wrapper` and `haskell-language-server`. + +It will copy the latter appending the used ghc version, needed by the wrapper to choose the suitable version +for the project at hand. + +So installing the executables directly with `stack install` or `cabal v2-install` may not be enough +for it to work properly. + +Install haskell-language-server for the latest available and supported GHC version (and hoogle docs): + +```bash +stack ./install.hs hls +``` + +Install haskell-language-server for a specific GHC version (and hoogle docs): + +```bash +stack ./install.hs hls-8.8.3 +``` + +`hls-8.8.3` target will build the project and install `haskell-language-server-wrapper`, +`haskell-language-server`, `haskell-language-server-8.8.3` and `haskell-language-server-8.8` +executables. + +The Haskell Language Server can also be built with `cabal v2-build` instead of `stack build`. +This has the advantage that you can decide how the GHC versions have been installed. +To see what GHC versions are available, the command `cabal-hls-install ghcs` can be used. +It will list all *supported* GHC versions that are on the path for build with their respective installation directory. +If you think, this list is incomplete, you can try to modify the PATH variable, such that the executables can be found. +Note, that the targets `hls` and `data` depend on the found GHC versions. + +An example output is: + +```bash +> ./cabal-hls-install ghcs +****************************************************************** +Found the following GHC paths: +ghc-8.6.5: /opt/bin/ghc-8.6.5 +ghc-8.8.3: /opt/bin/ghc-8.8.3 + +****************************************************************** +``` + +If your desired ghc has been found, you use it to install haskell-language-server. + +```bash +./cabal-hls-install hls-8.6.5 +``` + +### Installation from Hackage + +Direct installation from Hackage, while possible via `cabal install haskell-language-server`, is not recommended for most people. +Said command builds the `haskell-language-server` binary and installs it in the default Cabal binaries folder, +but the binary will only work with projects that use the same GHC version that built it. + +## Configuring `haskell-language-server` + +Language servers like `haskell-language-server` expose most of their configuration via the client (i.e. the editor). +That means that the way in which you configure the settings will depend on the client. + +Most clients (editors) already have an opinion about how settings should be configured! +For example, in VS Code you use the graphical Settings tab or `settings.json`, whereas in Emacs you use customization variables. +In the [editor configuration section](#configuring-your-editor) we give some pointers for popular editors, but you should consult the documentation for your specific editor if you have trouble. + +However, we can say some high-level things about the kinds of configuration `haskell-language-server` uses, and how to use them. +This can sound a bit confusing, but ultimately the client should present you with these options in a user-friendly way that makes sense for that editor. + +### Generic server options + +The LSP protocol is designed to support many useful server configuration options generically. +These are sent to the server by the client, and can be controlled without reference to a specific language. + +For example, there are protocol methods for highlighting matching identifiers throughout a document. +This is a capability which any server can implement, so the client can decide generically whether to ask the server to do it or not. +So your editor can provide a setting to turn this on or off globally, for any language server you might use. + +Settings like this are typically provided by the generic LSP client support for your editor, for example in Emacs by `lsp-mode`. + +### Generic editor options + +Your editor may provide some settings that affect how the information from the language server is used. +For example, whether popups are shown, or whether code lenses appear by default. + +Settings like this are typically provided by the generic LSP client support for your editor, for example in Emacs by `lsp-mode`. + +### Language-specific server options + +A specific language server can also have its own configuration options. +These are still sent to the server by the client, but they can only be controlled by a specific client that knows about those options. + +For example, `haskell-language-server` allows you to choose the formatting provider which will be used for formatting Haskell source. +This option obviously would not make sense for language servers for other languages, or even for other Haskell language servers (which need not even support formatting). + +Here is a list of the additional settings currently supported by `haskell-language-server`, along with their setting key (you may not need to know this) and default: +- Formatting provider (`haskell.formattingProvider`, default `ormolu`): what formatter to use; one of `floskell`, `ormolu`, `fourmolu`, `stylish-haskell`, or `brittany` (if compiled with AGPL) +- Format on imports (`haskell.formatOnImportOn`, default true): whether to format after adding an import +- Maximum number of problems to report (`haskell.maxNumberOfProblems`, default 100): the maximum number of problems the server will send to the client +- 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 + +Settings like this are typically provided by the language-specific LSP client support for your editor, for example in Emacs by `lsp-haskell`. + +### Client options + +A particular client might also have some options of its own, for example to control how the server executable is started. + +Settings like this are typically be provided by the language-specific LSP client support for your editor, for example in Emacs by `lsp-haskell`. + +## Configuring your project build + +`haskell-language-server` has to compile your project in order to give you diagnostics, which means that it needs to know how to do so. +This is handled by the [`hie-bios`](https://github.com/mpickering/hie-bios) project. + +**For a full explanation of how `hie-bios` determines the project build configuration, and how to configure it manually, refer to the [`hie-bios` README](https://github.com/mpickering/hie-bios/blob/master/README.md).** + +At the moment, `haskell-language-server` has some limited support to automatically detect your project build configuration. +The plan is to improve it to handle most use cases. + +However, for now, the most reliable way is to manually configure `hie-bios` using a `hie.yaml` file in the root of the workspace. +A `hie.yaml` file **explicitly** describes how to setup the environment to compile the various parts of your project. +For that you need to know what *components* your project has, and the path associated with each one. +So you will need some knowledge about +[stack](https://docs.haskellstack.org/en/stable/build_command/#components) or [cabal](https://cabal.readthedocs.io/en/latest/cabal-commands.html?#cabal-v2-build) components. + +You also can use [this utility](https://github.com/Avi-D-coder/implicit-hie) to automatically generate `hie.yaml` files for +the most common stack and cabal configurations + +For example, to state that you want to use `stack` then the configuration file +would look like: + +```yaml +cradle: + stack: + component: "haskell-language-server:lib" +``` + +If you use `cabal` then you probably need to specify which component you want +to use. + +```yaml +cradle: + cabal: + component: "lib:haskell-language-server" +``` + +If you have a project with multiple components, you can use a cabal-multi +cradle: + +```yaml +cradle: + cabal: + - path: "./test/functional/" + component: "haskell-language-server:func-test" + - path: "./test/utils/" + component: "haskell-language-server:hls-test-utils" + - path: "./exe/Main.hs" + component: "haskell-language-server:exe:haskell-language-server" + - path: "./exe/Wrapper.hs" + component: "haskell-language-server:exe:haskell-language-server-wrapper" + - path: "./src" + component: "lib:haskell-language-server" + - path: "./ghcide/src" + component: "ghcide:lib:ghcide" + - path: "./ghcide/exe" + component: "ghcide:exe:ghcide" +``` + +Equivalently, you can use stack: + +```yaml +cradle: + stack: + - path: "./test/functional/" + component: "haskell-language-server:func-test" + - path: "./exe/Main.hs" + component: "haskell-language-server:exe:haskell-language-server" + - path: "./exe/Wrapper.hs" + component: "haskell-language-server:exe:haskell-language-server-wrapper" + - path: "./src" + component: "haskell-language-server:lib" + - path: "./ghcide/src" + component: "ghcide:lib:ghcide" + - path: "./ghcide/exe" + component: "ghcide:exe:ghcide" +``` + +Or you can explicitly state the program which should be used to collect +the options by supplying the path to the program. It is interpreted +relative to the current working directory if it is not an absolute path. + +```yaml +cradle: + bios: + program: ".hie-bios" +``` + +The complete configuration is a subset of + +```yaml +cradle: + cabal: + component: "optional component name" + stack: + component: "optional component name" + bios: + program: "program to run" + dependency-program: "optional program to run" + direct: + arguments: ["list","of","ghc","arguments"] + default: + none: + +dependencies: + - someDep +``` + +## Configuring your editor + +Most editors provide a Haskell-specific extension that provides support for launching `haskell-language-server` and talking to it, as well as [exposing configuration options](#configuring-haskell-language-server). + +Editors typically assume that you have already installed `haskell-language-server` (see above) and that the installation script put the `haskell-language-server` and `haskell-language-server-wrapper` binaries in your `PATH` (usually `~/.local/bin` or `~/.cabal/bin` on Linux and macOS, `%APPDATA%\local\bin` or `%APPDATA%\cabal\bin` on Windows). +The exception is VS Code, which can automatically install the binaries if they are not installed already. + +### Using Haskell Language Server with VS Code + +Install from +[the VSCode marketplace](https://marketplace.visualstudio.com/items?itemName=haskell.haskell), or manually from the repository [vscode-haskell](https://github.com/haskell/vscode-haskell). +The `haskell-language-server` and `haskell-language-server-wrapper` binaries will be automatically downloaded on an ad-hoc basis, but if you have them already installed on your PATH then it will just use them instead. + +Configuration is done via the "Haskell" section of "Settings". + +### Using Haskell Language Server with Sublime Text + +- Install [LSP](https://packagecontrol.io/packages/LSP) using [Package Control](https://packagecontrol.io/) +- From Sublime Text, go to Preferences and search for LSP Settings +- Paste in these settings. Make sure to change the command path to your `haskell-language-server-wrapper` + +```json +{ + "clients": { + "haskell-language-server": { + "command": ["haskell-language-server-wrapper", "--lsp"], + "scopes": ["source.haskell"], + "syntaxes": ["Packages/Haskell/Haskell.sublime-syntax"], + "languageId": "haskell" + } + } +} +``` + +Now open a Haskell project with Sublime Text and enable Language Server in the project. +You should have these features available: + +1. Errors are underlined in red +2. LSP: Show Diagnostics will show a list of hints and errors +3. LSP: Format Document will prettify the file + +### Using Haskell Language Server with Vim or Neovim + +You can use [Coc](https://github.com/neoclide/coc.nvim), [LanguageClient-neovim](https://github.com/autozimu/LanguageClient-neovim) +or any other Vim Language server protocol client. +Coc is recommend since it is the only complete LSP implementation for Vim and Neovim and offers snippets and floating documentation out of the box. + +#### Coc + +Follow Coc's [installation instructions](https://github.com/neoclide/coc.nvim). +Then issue `:CocConfig` and add the following to your Coc config file. + +```json +{ + "languageserver": { + "haskell": { + "command": "haskell-language-server-wrapper", + "args": ["--lsp"], + "rootPatterns": ["*.cabal", "stack.yaml", "cabal.project", "package.yaml", "hie.yaml"], + "filetypes": ["haskell", "lhaskell"] + } + } +} +``` + +#### LanguageClient-neovim + +##### vim-plug + +If you use [vim-plug](https://github.com/junegunn/vim-plug), then you can do this by e.g., +including the following line in the Plug section of your `init.vim` or `~/.vimrc`: + +```text +Plug 'autozimu/LanguageClient-neovim', { + \ 'branch': 'next', + \ 'do': 'bash install.sh' + \ } +``` + +and issuing a `:PlugInstall` command within Neovim or Vim. + +##### Clone the LanguageClient-neovim repo + +As an alternative to using [vim-plug](https://github.com/junegunn/vim-plug) shown above, clone [LanguageClient-neovim](https://github.com/autozimu/LanguageClient-neovim) +into `~/.vim/pack/XXX/start/`, where `XXX` is just a name for your "plugin suite". + +##### Configuration and sample `~/.vimrc` sections + +```vim +set rtp+=~/.vim/pack/XXX/start/LanguageClient-neovim +let g:LanguageClient_serverCommands = { 'haskell': ['haskell-language-server-wrapper', '--lsp'] } +``` + +You'll probably want to add some mappings for common commands: + +```vim +nnoremap :call LanguageClient_contextMenu() +map lk :call LanguageClient#textDocument_hover() +map lg :call LanguageClient#textDocument_definition() +map lr :call LanguageClient#textDocument_rename() +map lf :call LanguageClient#textDocument_formatting() +map lb :call LanguageClient#textDocument_references() +map la :call LanguageClient#textDocument_codeAction() +map ls :call LanguageClient#textDocument_documentSymbol() +``` + +Use Ctrl+xCtrl+o (``) to open up the auto-complete menu, +or for asynchronous auto-completion, follow the setup instructions on +[LanguageClient](https://github.com/autozimu/LanguageClient-neovim). + +If you'd like diagnostics to be highlighted, add a highlight group for `ALEError`/`ALEWarning`/`ALEInfo`, +or customize `g:LanguageClient_diagnosticsDisplay`: + +```vim +hi link ALEError Error +hi Warning term=underline cterm=underline ctermfg=Yellow gui=undercurl guisp=Gold +hi link ALEWarning Warning +hi link ALEInfo SpellCap +``` + +If you're finding that the server isn't starting at the correct project root, +it may also be helpful to also specify root markers: + +```vim +let g:LanguageClient_rootMarkers = ['*.cabal', 'stack.yaml'] +``` + +Further configuration can be done by pointing the [`g:LanguageClient_settingsPath`](https://github.com/autozimu/LanguageClient-neovim/blob/0e5c9546bfddbaa2b01e5056389c25aefc8bf989/doc/LanguageClient.txt#L221) +variable to the file in which you want to keep your LSP settings. + +### Using Haskell Language Server with Atom + +Install the two Atom packages [atom-ide-ui](https://atom.io/packages/atom-ide-ui) and [haskell](https://atom.io/packages/haskell), + +```bash +$ apm install language-haskell atom-ide-ui haskell +``` + +### Using haskell-language-server with Emacs + +Emacs support is provided by a combination of the following packages: + +[lsp-mode](https://github.com/emacs-lsp/lsp-mode) +[lsp-ui](https://github.com/emacs-lsp/lsp-ui) +[lsp-haskell](https://github.com/emacs-lsp/lsp-haskell) + +You can install these manually if you are using plain Emacs; instructions for some specific flavours +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 executable. + +#### Using haskell-language-server with [doom-emacs](https://github.com/hlissner/doom-emacs/tree/develop/modules/lang/haskell#module-flags) + +Manual installation of packages is not required. +Enable the lsp module and the haskell lang module with lsp flag in `.doom.d/init.el`: + +``` emacs-lisp +:tools +lsp +;; ... +:lang +(haskell +lsp) +``` + +then do `$HOME/.emacs.d/bin/doom sync` + +#### Using haskell-language-server with [Spacemacs](https://github.com/syl20bnr/spacemacs) + +Manual installation of packages is not required. +Enable the `haskell` layer and the `lsp` layer in your Spacemacs config file: + +```emacs-lisp +dotspacemacs-configuration-layers + '( + haskell + lsp + ;; ... + ) +``` + +### Using haskell-language-server with [Kakoune](https://github.com/mawww/kakoune) + +1. Grab a copy of [kak-lsp](https://github.com/ul/kak-lsp), and follow the setup instructions. +2. Point your `kak-lsp.toml` to `haskell-language-server-wrapper`. + +```toml +[language.haskell] +filetypes = ["haskell"] +roots = ["Setup.hs", "stack.yaml", "*.cabal"] +command = "haskell-language-server-wrapper" +args = ["--lsp"] +``` + +## Known limitations + +### Preprocessor +HLS is not yet able to find project preprocessors, which may result in `could not execute: ` errors. This problem is +tracked in https://github.com/haskell/haskell-language-server/issues/176 and originally comes from https://github.com/mpickering/hie-bios/issues/125 + +As a workaround, you need to ensure the preprocessor is available in the path (install globally with Stack or Cabal, provide in `shell.nix`, etc.). + +Example with `tasty-discover`: +```haskell +{-# OPTIONS_GHC -F -pgmF 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: + +- Join [our IRC channel](https://webchat.freenode.net/?channels=haskell-ide-engine) at `#haskell-ide-engine` on `freenode`. +- Fork this repo and [ghcide](https://github.com/haskell/ghcide) and hack as much as you can. + +### Style guidelines + +The project includes a [`.editorconfig`](https://editorconfig.org) [file](https://github.com/haskell/haskell-language-server/blob/master/.editorconfig) with the editor basic settings used by the project. +However, most editors will need some action to honour those settings automatically. +For example vscode needs to have installed a specific [extension](https://marketplace.visualstudio.com/items?itemName=EditorConfig.EditorConfig). +Please, try to follow those basic settings to keep the codebase as uniform as possible. + +### Building haskell-language-server + +The project can be built with both `cabal build` and `stack build`. + +haskell-language-server can also be used with itself. We provide preset samples of `hie.yaml` for Cabal and Stack. + +Note: the `./install/` folder is not directly tied to the project so it has dedicated `./install/hie.yaml.[cbl|stack]` +templates. + +#### Using Cabal + +```shell +$ cp hie-cabal.yaml hie.yaml +$ cp install/hie-cabal.yaml install/hie.yaml +``` + +#### Using Stack + +```shell +$ cp hie-stack.yaml hie.yaml +$ cp install/hie-stack.yaml install/hie.yaml +$ cp ghcide/hie-stack.yaml ghcide/hie.yaml +$ stack build --test --no-run-tests +$ cd install +$ stack build +``` + +#### Using Nix + +The instructions below show how to set up a Cachix binary cache and open a nix shell for local development. + +```shell +$ cachix use haskell-language-server +$ nix-shell +$ cabal update +$ cabal build +``` + +If you are looking for a Nix expression to create haskell-language-server binaries, see https://github.com/haskell/haskell-language-server/issues/122 + +#### Introduction tutorial +Pepeiborra [wrote an tutorial](https://github.com/pepeiborra/hls-tutorial) on writing a plugin in HLS. + +#### Test your hacked HLS in your editor +If you want to test HLS while hacking on it, follow the steps below. + +To do once: +- Open some codebase on which you want to test your hacked HLS in your favorite editor +- Configure this editor to use your custom HLS executable + - With Cabal: + - On Unix systems: `cabal exec which haskell-language-server` + - On Windows: `cabal exec where haskell-language-server` + - With Stack: `$(stack path --dist-dir)/build/haskell-language-server/haskell-language-server` + +To do every time you changed code and want to test it: +- Build HLS + - With Cabal: `cabal build exe:haskell-language-server` + - With Stack: `stack build haskell-language-server:exe:haskell-language-server` +- Restart HLS + - With VS Code: `Haskell: Restart Haskell LSP Server` + +### Adding support for a new editor + +Adding support for new editors is fairly easy if the editor already has good support for generic LSP-based extensions. +In that case, there will likely be an editor-specific support system for this (like `lsp-mode` for Emacs). +This will typically provide instructions for how to support new languages. + +In some cases you may need to write a small bit of additional client support, or expose a way for the user to set the server's [configuration options](#configuring-haskell-language-server) and +for them to configure how the server is started. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/exe/Main.hs b/exe/Main.hs new file mode 100644 --- /dev/null +++ b/exe/Main.hs @@ -0,0 +1,22 @@ +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Main(main) where + +import Ide.Arguments (Arguments (..), LspArguments (..), + getArguments) +import Ide.Main (defaultMain) +import Plugins +import Main.Utf8 (withUtf8) + +main :: IO () +main = withUtf8 $ do + args <- getArguments "haskell-language-server" + + let withExamples = + case args of + LspMode (LspArguments{..}) -> argsExamplePlugin + _ -> False + + defaultMain args (idePlugins withExamples) diff --git a/exe/Plugins.hs b/exe/Plugins.hs new file mode 100644 --- /dev/null +++ b/exe/Plugins.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Plugins where + +import Ide.Types (IdePlugins) +import Ide.PluginUtils (pluginDescToIdePlugins) + +-- fixed plugins +import Ide.Plugin.Example as Example +import Ide.Plugin.Example2 as Example2 +import Development.IDE (IdeState) +import Development.IDE.Plugin.HLS.GhcIde as GhcIde + +-- haskell-language-server optional plugins + +#if class +import Ide.Plugin.Class as Class +#endif + +#if eval +import Ide.Plugin.Eval as Eval +#endif + +#if importLens +import Ide.Plugin.ExplicitImports as ExplicitImports +#endif + +#if retrie +import Ide.Plugin.Retrie as Retrie +#endif + +#if tactic +import Ide.Plugin.Tactic as Tactic +#endif + +#if hlint +import Ide.Plugin.Hlint as Hlint +#endif + +#if moduleName +import Ide.Plugin.ModuleName as ModuleName +#endif + +#if pragmas +import Ide.Plugin.Pragmas as Pragmas +#endif + +-- formatters + +#if floskell +import Ide.Plugin.Floskell as Floskell +#endif + +#if fourmolu +import Ide.Plugin.Fourmolu as Fourmolu +#endif + +#if ormolu +import Ide.Plugin.Ormolu as Ormolu +#endif + +#if stylishHaskell +import Ide.Plugin.StylishHaskell as StylishHaskell +#endif + +#if AGPL && brittany +import Ide.Plugin.Brittany as Brittany +#endif + +-- --------------------------------------------------------------------- + +-- | The plugins configured for use in this instance of the language +-- server. +-- These can be freely added or removed to tailor the available +-- features of the server. + +idePlugins :: Bool -> IdePlugins IdeState +idePlugins includeExamples = pluginDescToIdePlugins allPlugins + where + allPlugins = if includeExamples + then basePlugins ++ examplePlugins + else basePlugins + basePlugins = + [ GhcIde.descriptor "ghcide" +#if pragmas + , Pragmas.descriptor "pragmas" +#endif +#if floskell + , Floskell.descriptor "floskell" +#endif +#if fourmolu + , Fourmolu.descriptor "fourmolu" +#endif +#if tactic + , Tactic.descriptor "tactic" +#endif +#if ormolu + , Ormolu.descriptor "ormolu" +#endif +#if stylishHaskell + , StylishHaskell.descriptor "stylish-haskell" +#endif +#if retrie + , Retrie.descriptor "retrie" +#endif +#if AGPL && brittany + , Brittany.descriptor "brittany" +#endif +#if class + , Class.descriptor "class" +#endif +#if eval + , Eval.descriptor "eval" +#endif +#if importLens + , ExplicitImports.descriptor "importLens" +#endif +#if moduleName + , ModuleName.descriptor "moduleName" +#endif +#if hlint + , Hlint.descriptor "hlint" +#endif + ] + examplePlugins = + [Example.descriptor "eg" + ,Example2.descriptor "eg2" + ] diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs new file mode 100644 --- /dev/null +++ b/exe/Wrapper.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE RecordWildCards #-} +-- | This module is based on the hie-wrapper.sh script in +-- https://github.com/alanz/vscode-hie-server +module Main where + +import Control.Monad.Extra +import Data.Foldable +import Data.List +import Data.Void +import Development.IDE.Session (findCradle, defaultLoadingOptions) +import HIE.Bios hiding (findCradle) +import HIE.Bios.Environment +import HIE.Bios.Types +import Ide.Arguments +import Ide.Version +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import System.IO +import System.Info +import System.Process + +-- --------------------------------------------------------------------- + +main :: IO () +main = do + -- WARNING: If you write to stdout before runLanguageServer + -- then the language server will not work + args <- getArguments "haskell-language-server-wrapper" + + hlsVer <- haskellLanguageServerVersion + case args of + ProbeToolsMode -> do + programsOfInterest <- findProgramVersions + putStrLn hlsVer + putStrLn "Tool versions found on the $PATH" + putStrLn $ showProgramVersionOfInterest programsOfInterest + + VersionMode PrintVersion -> + putStrLn hlsVer + + VersionMode PrintNumericVersion -> + putStrLn haskellLanguageServerNumericVersion + + LspMode lspArgs -> + launchHaskellLanguageServer lspArgs + +launchHaskellLanguageServer :: LspArguments -> IO () +launchHaskellLanguageServer LspArguments{..} = do + whenJust argsCwd setCurrentDirectory + + d <- getCurrentDirectory + + -- Get the cabal directory from the cradle + cradle <- findLocalCradle (d "a") + setCurrentDirectory $ cradleRootDir cradle + + when argsProjectGhcVersion $ getRuntimeGhcVersion' cradle >>= putStrLn >> exitSuccess + + progName <- getProgName + hPutStrLn stderr $ "Run entered for haskell-language-server-wrapper(" ++ progName ++ ") " + ++ hlsVersion + hPutStrLn stderr $ "Current directory: " ++ d + hPutStrLn stderr $ "Operating system: " ++ os + args <- getArgs + hPutStrLn stderr $ "Arguments: " ++ show args + hPutStrLn stderr $ "Cradle directory: " ++ cradleRootDir cradle + hPutStrLn stderr $ "Cradle type: " ++ show (actionName (cradleOptsProg cradle)) + programsOfInterest <- findProgramVersions + hPutStrLn stderr "" + hPutStrLn stderr "Tool versions found on the $PATH" + hPutStrLn stderr $ showProgramVersionOfInterest programsOfInterest + hPutStrLn stderr "" + -- Get the ghc version -- this might fail! + hPutStrLn stderr $ "Consulting the cradle to get project GHC version..." + ghcVersion <- getRuntimeGhcVersion' cradle + hPutStrLn stderr $ "Project GHC version: " ++ ghcVersion + + let + hlsBin = "haskell-language-server-" ++ ghcVersion + backupHlsBin = + case dropWhileEnd (/='.') ghcVersion of + [] -> "haskell-language-server" + xs -> "haskell-language-server-" ++ init xs + candidates' = [hlsBin, backupHlsBin, "haskell-language-server"] + candidates = map (++ exeExtension) candidates' + + hPutStrLn stderr $ "haskell-language-server exe candidates: " ++ show candidates + + mexes <- traverse findExecutable candidates + + case asum mexes of + Nothing -> hPutStrLn stderr $ "Cannot find any haskell-language-server exe, looked for: " ++ intercalate ", " candidates + Just e -> do + hPutStrLn stderr $ "Launching haskell-language-server exe at:" ++ e + callProcess e args + +-- | Version of 'getRuntimeGhcVersion' that dies if we can't get it, and also +-- checks to see if the tool is missing if it is one of +getRuntimeGhcVersion' :: Show a => Cradle a -> IO String +getRuntimeGhcVersion' cradle = do + + -- See if the tool is installed + case actionName (cradleOptsProg cradle) of + Stack -> checkToolExists "stack" + Cabal -> checkToolExists "cabal" + Default -> checkToolExists "ghc" + Direct -> checkToolExists "ghc" + _ -> pure () + + ghcVersionRes <- getRuntimeGhcVersion cradle + case ghcVersionRes of + CradleSuccess ver -> do + return ver + CradleFail error -> die $ "Failed to get project GHC version:" ++ show error + CradleNone -> die "Failed get project GHC version, since we have a none cradle" + where + checkToolExists exe = do + exists <- findExecutable exe + case exists of + Just _ -> pure () + Nothing -> + die $ "Cradle requires " ++ exe ++ " but couldn't find it" ++ "\n" + ++ show cradle + +-- | Find the cradle that the given File belongs to. +-- +-- First looks for a "hie.yaml" file in the directory of the file +-- or one of its parents. If this file is found, the cradle +-- is read from the config. If this config does not comply to the "hie.yaml" +-- specification, an error is raised. +-- +-- If no "hie.yaml" can be found, the implicit config is used. +-- The implicit config uses different heuristics to determine the type +-- of the project that may or may not be accurate. +findLocalCradle :: FilePath -> IO (Cradle Void) +findLocalCradle fp = do + cradleConf <- (findCradle defaultLoadingOptions) fp + crdl <- case cradleConf of + Just yaml -> do + hPutStrLn stderr $ "Found \"" ++ yaml ++ "\" for \"" ++ fp ++ "\"" + loadCradle yaml + Nothing -> loadImplicitCradle fp + hPutStrLn stderr $ "Module \"" ++ fp ++ "\" is loaded by Cradle: " ++ show crdl + return crdl + diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal new file mode 100644 --- /dev/null +++ b/haskell-language-server.cabal @@ -0,0 +1,444 @@ +cabal-version: 2.2 +category: Development +name: haskell-language-server +version: 0.8.0.0 +synopsis: LSP server for GHC +description: + Please see the README on GitHub at + +homepage: https://github.com/haskell/haskell-language-server#readme +bug-reports: https://github.com/haskell/haskell-language-server/issues +author: The Haskell IDE Team +maintainer: alan.zimm@gmail.com +copyright: The Haskell IDE Team +license: Apache-2.0 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + include/ghc-api-version.h + +flag agpl + description: Enable AGPL dependencies + default: True + manual: True + +flag pedantic + description: Enable -Werror + default: False + manual: True + +source-repository head + type: git + location: https://github.com/haskell/haskell-language-server + +common agpl + if flag(agpl) + cpp-options: -DAGPL + +common common-deps + build-depends: + , base >=4.12 && <5 + , directory + , extra + , filepath + , text + +library + import: agpl, common-deps + exposed-modules: + Ide.Arguments + Ide.Main + Ide.Version + + other-modules: Paths_haskell_language_server + autogen-modules: Paths_haskell_language_server + hs-source-dirs: src + build-depends: + , containers + , data-default + , ghc + , ghcide >=0.7 + , gitrev + , haskell-lsp ^>=0.22 + , hls-plugin-api >=0.6 + , hslogger + , optparse-applicative + , optparse-simple + , process + , shake + , unordered-containers + + ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing + + if flag(pedantic) + ghc-options: -Werror + + default-language: Haskell2010 + +-- Plugin flags are designed for 'cabal install haskell-language-server': +-- - Packaged plugins should be manual:False +-- - Non packaged plugins and bulk flags should be manual:True +-- - Bulk flags should be default:False +-- - Individual flags should be default:True + +flag all-plugins + description: Enable all non formatter plugins + default: False + manual: True + +flag all-formatters + description: Enable all fomatters + default: False + manual: True + +flag class + description: Enable class plugin + default: True + manual: False + +flag eval + description: Enable eval plugin + default: True + manual: False + +flag importLens + description: Enable importLens plugin + default: True + manual: False + +flag retrie + description: Enable retrie plugin + default: True + manual: False + +flag tactic + description: Enable tactic plugin + default: True + manual: False + +flag hlint + description: Enable hlint plugin + default: True + manual: False + +flag moduleName + description: Enable moduleName plugin + default: True + manual: True + +flag pragmas + description: Enable pragmas plugin + default: True + manual: True + +-- formatters + +flag floskell + description: Enable floskell plugin + default: True + manual: True + +flag fourmolu + description: Enable fourmolu plugin + default: True + manual: True + +flag ormolu + description: Enable ormolu plugin + default: True + manual: True + +flag stylishHaskell + description: Enable stylishHaskell plugin + default: True + manual: True + +flag brittany + description: Enable brittany plugin + default: True + manual: True + +common example-plugins + hs-source-dirs: plugins/default/src + other-modules: Ide.Plugin.Example, + Ide.Plugin.Example2 + +common class + if flag(class) || flag(all-plugins) + build-depends: hls-class-plugin + cpp-options: -Dclass + +common eval + if flag(eval) || flag(all-plugins) + build-depends: hls-eval-plugin + cpp-options: -Deval + +common importLens + if flag(importLens) || flag(all-plugins) + build-depends: hls-explicit-imports-plugin + cpp-options: -DimportLens + +common retrie + if flag(retrie) || flag(all-plugins) + build-depends: hls-retrie-plugin + cpp-options: -Dretrie + +common tactic + if flag(tactic) || flag(all-plugins) + build-depends: hls-tactics-plugin + cpp-options: -Dtactic + +common hlint + if flag(hlint) || flag(all-plugins) + build-depends: hls-hlint-plugin + cpp-options: -Dhlint + +common moduleName + if flag(moduleName) || flag(all-plugins) + hs-source-dirs: plugins/default/src + other-modules: Ide.Plugin.ModuleName + cpp-options: -DmoduleName + +common pragmas + if flag(pragmas) || flag(all-plugins) + hs-source-dirs: plugins/default/src + other-modules: Ide.Plugin.Pragmas + cpp-options: -Dpragmas + +-- formatters + +common floskell + if flag(floskell) || flag(all-formatters) + hs-source-dirs: plugins/default/src + other-modules: Ide.Plugin.Floskell + build-depends: floskell ^>=0.10 + cpp-options: -Dfloskell + +common fourmolu + if flag(fourmolu) || flag(all-formatters) + hs-source-dirs: plugins/default/src + other-modules: Ide.Plugin.Fourmolu + build-depends: fourmolu ^>=0.3 + cpp-options: -Dfourmolu + +common ormolu + if flag(ormolu) || flag(all-formatters) + hs-source-dirs: plugins/default/src + other-modules: Ide.Plugin.Ormolu + build-depends: ormolu ^>=0.1.2 + cpp-options: -Dormolu + +common stylishHaskell + if flag(stylishHaskell) || flag(all-formatters) + hs-source-dirs: plugins/default/src + other-modules: Ide.Plugin.StylishHaskell + build-depends: stylish-haskell ^>=0.12 + cpp-options: -DstylishHaskell + +common brittany + if (flag(brittany) || flag(all-formatters)) && flag(agpl) + hs-source-dirs: plugins/default/src + other-modules: Ide.Plugin.Brittany + build-depends: brittany >= 0.13.1.0 + cpp-options: -Dbrittany + +executable haskell-language-server + import: agpl + , common-deps + -- plugins + , example-plugins + , class + , eval + , importLens + , retrie + , tactic + , hlint + , moduleName + , pragmas + , floskell + , fourmolu + , ormolu + , stylishHaskell + , brittany + + main-is: Main.hs + hs-source-dirs: exe + other-modules: Plugins + + ghc-options: + -threaded -Wall -Wno-name-shadowing -Wredundant-constraints + -- allow user RTS overrides + -rtsopts + -- disable idle GC + -- disable parallel GC + -- increase nursery size + "-with-rtsopts=-I0 -qg -A128M" + if flag(pedantic) + ghc-options: -Werror + + build-depends: + , aeson + , binary + , bytestring + , containers + , deepseq + , ghc + , ghc-boot-th + , ghcide + , hashable + , haskell-language-server + , haskell-lsp ^>=0.22 + , lens + , regex-tdfa + , hslogger + , optparse-applicative + , hls-plugin-api + , lens + , mtl + , regex-tdfa + , safe-exceptions + , shake >=0.17.5 + , temporary + , transformers + , unordered-containers + , with-utf8 + + include-dirs: include + default-language: Haskell2010 + +executable haskell-language-server-wrapper + import: agpl, common-deps + main-is: Wrapper.hs + hs-source-dirs: exe + other-modules: Paths_haskell_language_server + autogen-modules: Paths_haskell_language_server + ghc-options: + -threaded -Wall -Wno-name-shadowing -Wredundant-constraints + -- allow user RTS overrides + -rtsopts + -- disable idle GC + -- disable parallel GC + -- increase nursery size + "-with-rtsopts=-I0 -qg -A128M" + if flag(pedantic) + ghc-options: -Werror + + build-depends: + , ghc + , ghc-paths + , ghcide + , gitrev + , haskell-language-server + , hie-bios + , optparse-applicative + , optparse-simple + , process + + default-language: Haskell2010 + +-- This common stanza simulates a previous private lib +-- We removed it due to issues with stack when loading the project using a stack based hie.yaml +-- See https://github.com/haskell/haskell-language-server/issues/114 +common hls-test-utils + import: agpl, common-deps + hs-source-dirs: test/utils + other-modules: Test.Hls.Util + build-depends: + , aeson + , blaze-markup + , containers + , data-default + , haskell-lsp + , hie-bios + , hls-plugin-api >=0.6 + , hslogger + , hspec + , hspec-core + , lens + , lsp-test >=0.11.0.6 + , stm + , tasty-expected-failure + , tasty-hunit + , temporary + , transformers + , unordered-containers + , yaml + + ghc-options: -Wall -Wredundant-constraints + + if flag(pedantic) + ghc-options: -Werror + + default-language: Haskell2010 + +test-suite func-test + import: agpl, common-deps, hls-test-utils + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-tool-depends: + haskell-language-server:haskell-language-server -any, + ghcide:ghcide-test-preprocessor -any + + build-depends: + , bytestring + , data-default + , hspec-expectations + , lens + , tasty + , tasty-ant-xml >=1.1.6 + , tasty-golden + , tasty-rerun + + hs-source-dirs: test/functional plugins/tactics/src plugins/hls-eval-plugin/test + + main-is: Main.hs + other-modules: + Class + Command + Completion + Config + Deferred + Definition + Diagnostic + Eval + Format + FunctionalBadProject + FunctionalCodeAction + FunctionalLiquid + HieBios + Highlight + ModuleName + Progress + Reference + Rename + Symbol + TypeDefinition + Tactic + Ide.Plugin.Tactic.TestTypes + + ghc-options: + -Wall -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N + + if flag(pedantic) + ghc-options: -Werror -Wredundant-constraints + +test-suite wrapper-test + import: agpl, hls-test-utils + type: exitcode-stdio-1.0 + build-tool-depends: + haskell-language-server:haskell-language-server-wrapper -any + + default-language: Haskell2010 + build-depends: + , base + , directory + , process + , tasty + , tasty-ant-xml >=1.1.6 + , tasty-rerun + + hs-source-dirs: test/wrapper + main-is: Main.hs + ghc-options: -Wall diff --git a/include/ghc-api-version.h b/include/ghc-api-version.h new file mode 100644 --- /dev/null +++ b/include/ghc-api-version.h @@ -0,0 +1,10 @@ +#ifndef GHC_API_VERSION_H +#define GHC_API_VERSION_H + +#ifdef GHC_LIB +#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z) +#else +#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z) +#endif + +#endif diff --git a/plugins/default/src/Ide/Plugin/Brittany.hs b/plugins/default/src/Ide/Plugin/Brittany.hs new file mode 100644 --- /dev/null +++ b/plugins/default/src/Ide/Plugin/Brittany.hs @@ -0,0 +1,99 @@ +module Ide.Plugin.Brittany where + +import Control.Lens +import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) +import Data.Coerce +import Data.Semigroup +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE +-- import Development.IDE.Plugin.Formatter +import Language.Haskell.Brittany +import Language.Haskell.LSP.Types as J +import qualified Language.Haskell.LSP.Types.Lens as J +import Ide.PluginUtils +import Ide.Types + +import System.FilePath +import Data.Maybe (maybeToList) + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) + { pluginFormattingProvider = Just provider + } + +-- | Formatter provider of Brittany. +-- Formats the given source in either a given Range or the whole Document. +-- If the provider fails an error is returned that can be displayed to the user. +provider + :: FormattingProvider IdeState IO +provider _lf _ideState typ contents fp opts = do +-- text uri formatType opts = pluginGetFile "brittanyCmd: " uri $ \fp -> do + confFile <- liftIO $ getConfFile fp + let (range, selectedContents) = case typ of + FormatText -> (fullRange contents, contents) + FormatRange r -> (normalize r, extractRange r contents) + + res <- formatText confFile opts selectedContents + case res of + Left err -> return $ Left $ responseError (T.pack $ "brittanyCmd: " ++ unlines (map showErr err)) + Right newText -> return $ Right $ J.List [TextEdit range newText] + +-- | Primitive to format text with the given option. +-- May not throw exceptions but return a Left value. +-- Errors may be presented to the user. +formatText + :: MonadIO m + => Maybe FilePath -- ^ Path to configs. If Nothing, default configs will be used. + -> FormattingOptions -- ^ Options for the formatter such as indentation. + -> Text -- ^ Text to format + -> m (Either [BrittanyError] Text) -- ^ Either formatted Text or a error from Brittany. +formatText confFile opts text = + liftIO $ runBrittany tabSize confFile text + where tabSize = opts ^. J.tabSize + +-- | Recursively search in every directory of the given filepath for brittany.yaml. +-- If no such file has been found, return Nothing. +getConfFile :: NormalizedFilePath -> IO (Maybe FilePath) +getConfFile = findLocalConfigPath . takeDirectory . fromNormalizedFilePath + +-- | Run Brittany on the given text with the given tab size and +-- a configuration path. If no configuration path is given, a +-- default configuration is chosen. The configuration may overwrite +-- tab size parameter. +-- +-- Returns either a list of Brittany Errors or the reformatted text. +-- May not throw an exception. +runBrittany :: Int -- ^ tab size + -> Maybe FilePath -- ^ local config file + -> Text -- ^ text to format + -> IO (Either [BrittanyError] Text) +runBrittany tabSize confPath text = do + let cfg = mempty + { _conf_layout = + mempty { _lconfig_indentAmount = opt (coerce tabSize) + } + , _conf_forward = + (mempty :: CForwardOptions Option) + { _options_ghc = opt (runIdentity ( _options_ghc forwardOptionsSyntaxExtsEnabled)) + } + } + + config <- fromMaybeT (pure staticDefaultConfig) (readConfigsWithUserConfig cfg (maybeToList confPath)) + parsePrintModule config text + +fromMaybeT :: Monad m => m a -> MaybeT m a -> m a +fromMaybeT def act = runMaybeT act >>= maybe def return + +opt :: a -> Option a +opt = Option . Just + +showErr :: BrittanyError -> String +showErr (ErrorInput s) = s +showErr (ErrorMacroConfig err input) + = "Error: parse error in inline configuration: " ++ err ++ " in the string \"" ++ input ++ "\"." +showErr (ErrorUnusedComment s) = s +showErr (LayoutWarning s) = s +showErr (ErrorUnknownNode s _) = s +showErr ErrorOutputCheck = "Brittany error - invalid output" diff --git a/plugins/default/src/Ide/Plugin/Example.hs b/plugins/default/src/Ide/Plugin/Example.hs new file mode 100644 --- /dev/null +++ b/plugins/default/src/Ide/Plugin/Example.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.Example + ( + descriptor + ) where + +import Control.DeepSeq ( NFData ) +import Control.Monad.Trans.Maybe +import Data.Aeson +import Data.Binary +import Data.Functor +import qualified Data.HashMap.Strict as Map +import Data.Hashable +import qualified Data.Text as T +import Data.Typeable +import Development.IDE as D +import Development.IDE.GHC.Compat (ParsedModule(ParsedModule)) +import Development.IDE.Core.Rules (useE) +import Development.IDE.Core.Shake (getDiagnostics, getHiddenDiagnostics) +import GHC.Generics +import Ide.PluginUtils +import Ide.Types +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() + +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) + { pluginRules = exampleRules + , pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] + , pluginCodeActionProvider = Just codeAction + , pluginCodeLensProvider = Just codeLens + , pluginHoverProvider = Just hover + , pluginSymbolsProvider = Just symbols + , pluginCompletionProvider = Just completion + } + +-- --------------------------------------------------------------------- + +hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) +hover = request "Hover" blah (Right Nothing) foundHover + +blah :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text])) +blah _ (Position line col) + = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover 1\n"]) + +-- --------------------------------------------------------------------- +-- Generating Diagnostics via rules +-- --------------------------------------------------------------------- + +data Example = Example + deriving (Eq, Show, Typeable, Generic) +instance Hashable Example +instance NFData Example +instance Binary Example + +type instance RuleResult Example = () + +exampleRules :: Rules () +exampleRules = do + define $ \Example file -> do + _pm <- getParsedModule file + let diag = mkDiag file "example" DsError (Range (Position 0 0) (Position 1 0)) "example diagnostic, hello world" + return ([diag], Just ()) + + action $ do + files <- getFilesOfInterest + void $ uses Example $ Map.keys files + +mkDiag :: NormalizedFilePath + -> DiagnosticSource + -> DiagnosticSeverity + -> Range + -> T.Text + -> FileDiagnostic +mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) + Diagnostic + { _range = loc + , _severity = Just sev + , _source = Just diagSource + , _message = msg + , _code = Nothing + , _tags = Nothing + , _relatedInformation = Nothing + } + +-- --------------------------------------------------------------------- +-- code actions +-- --------------------------------------------------------------------- + +-- | Generate code actions. +codeAction :: CodeActionProvider IdeState +codeAction _lf state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do + let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri + Just (ParsedModule{},_) <- runIdeAction "example" (shakeExtras state) $ useWithStaleFast GetParsedModule nfp + let + title = "Add TODO Item 1" + tedit = [TextEdit (Range (Position 2 0) (Position 2 0)) + "-- TODO1 added by Example Plugin directly\n"] + edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing + pure $ Right $ List + [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) (Just edit) Nothing ] + +-- --------------------------------------------------------------------- + +codeLens :: CodeLensProvider IdeState +codeLens _lf ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do + logInfo (ideLogger ideState) "Example.codeLens entered (ideLogger)" -- AZ + case uriToFilePath' uri of + Just (toNormalizedFilePath -> filePath) -> do + _ <- runIdeAction "Example.codeLens" (shakeExtras ideState) $ runMaybeT $ useE TypeCheck filePath + _diag <- getDiagnostics ideState + _hDiag <- getHiddenDiagnostics ideState + let + title = "Add TODO Item via Code Lens" + -- tedit = [TextEdit (Range (Position 3 0) (Position 3 0)) + -- "-- TODO added by Example Plugin via code lens action\n"] + -- edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing + range = Range (Position 3 0) (Position 4 0) + let cmdParams = AddTodoParams uri "do abc" + cmd <- mkLspCommand plId "codelens.todo" title (Just [(toJSON cmdParams)]) + pure $ Right $ List [ CodeLens range (Just cmd) Nothing ] + Nothing -> pure $ Right $ List [] + +-- --------------------------------------------------------------------- +-- | Parameters for the addTodo PluginCommand. +data AddTodoParams = AddTodoParams + { file :: Uri -- ^ Uri of the file to add the pragma to + , todoText :: T.Text + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +addTodoCmd :: CommandFunction IdeState AddTodoParams +addTodoCmd _lf _ide (AddTodoParams uri todoText) = do + let + pos = Position 3 0 + textEdits = List + [TextEdit (Range pos pos) + ("-- TODO:" <> todoText <> "\n") + ] + res = WorkspaceEdit + (Just $ Map.singleton uri textEdits) + Nothing + return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res)) + +-- --------------------------------------------------------------------- + +foundHover :: (Maybe Range, [T.Text]) -> Either ResponseError (Maybe Hover) +foundHover (mbRange, contents) = + Right $ Just $ Hover (HoverContents $ MarkupContent MkMarkdown + $ T.intercalate sectionSeparator contents) mbRange + + +-- | Respond to and log a hover or go-to-definition request +request + :: T.Text + -> (NormalizedFilePath -> Position -> Action (Maybe a)) + -> Either ResponseError b + -> (a -> Either ResponseError b) + -> IdeState + -> TextDocumentPositionParams + -> IO (Either ResponseError b) +request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do + mbResult <- case uriToFilePath' uri of + Just path -> logAndRunRequest label getResults ide pos path + Nothing -> pure Nothing + pure $ maybe notFound found mbResult + +logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) + -> IdeState -> Position -> String -> IO b +logAndRunRequest label getResults ide pos path = do + let filePath = toNormalizedFilePath path + logInfo (ideLogger ide) $ + label <> " request at position " <> T.pack (showPosition pos) <> + " in file: " <> T.pack path + runAction "Example" ide $ getResults filePath pos + +-- --------------------------------------------------------------------- + +symbols :: SymbolsProvider IdeState +symbols _lf _ide (DocumentSymbolParams _doc _mt) + = pure $ Right [r] + where + r = DocumentSymbol name detail kind deprecation range selR chList + name = "Example_symbol_name" + detail = Nothing + kind = SkVariable + deprecation = Nothing + range = Range (Position 2 0) (Position 2 5) + selR = range + chList = Nothing + +-- --------------------------------------------------------------------- + +completion :: CompletionProvider IdeState +completion _lf _ide (CompletionParams _doc _pos _mctxt _mt) + = pure $ Right $ Completions $ List [r] + where + r = CompletionItem label kind tags detail documentation deprecated preselect + sortText filterText insertText insertTextFormat + textEdit additionalTextEdits commitCharacters + command xd + label = "Example completion" + kind = Nothing + tags = List [] + detail = Nothing + documentation = Nothing + deprecated = Nothing + preselect = Nothing + sortText = Nothing + filterText = Nothing + insertText = Nothing + insertTextFormat = Nothing + textEdit = Nothing + additionalTextEdits = Nothing + commitCharacters = Nothing + command = Nothing + xd = Nothing + +-- --------------------------------------------------------------------- diff --git a/plugins/default/src/Ide/Plugin/Example2.hs b/plugins/default/src/Ide/Plugin/Example2.hs new file mode 100644 --- /dev/null +++ b/plugins/default/src/Ide/Plugin/Example2.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.Example2 + ( + descriptor + ) where + +import Control.DeepSeq (NFData) +import Control.Monad.Trans.Maybe +import Data.Aeson +import Data.Binary +import Data.Functor +import qualified Data.HashMap.Strict as Map +import Data.Hashable +import qualified Data.Text as T +import Data.Typeable +import Development.IDE as D +import Development.IDE.Core.Rules +import Development.IDE.Core.Shake +import GHC.Generics +import Ide.PluginUtils +import Ide.Types +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() + +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) + { pluginRules = exampleRules + , pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] + , pluginCodeActionProvider = Just codeAction + , pluginCodeLensProvider = Just codeLens + , pluginHoverProvider = Just hover + , pluginSymbolsProvider = Just symbols + , pluginCompletionProvider = Just completion + } + +-- --------------------------------------------------------------------- + +hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) +hover = request "Hover" blah (Right Nothing) foundHover + +blah :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text])) +blah _ (Position line col) + = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover 2\n"]) + +-- --------------------------------------------------------------------- +-- Generating Diagnostics via rules +-- --------------------------------------------------------------------- + +data Example2 = Example2 + deriving (Eq, Show, Typeable, Generic) +instance Hashable Example2 +instance NFData Example2 +instance Binary Example2 + +type instance RuleResult Example2 = () + +exampleRules :: Rules () +exampleRules = do + define $ \Example2 file -> do + _pm <- getParsedModule file + let diag = mkDiag file "example2" DsError (Range (Position 0 0) (Position 1 0)) "example2 diagnostic, hello world" + return ([diag], Just ()) + + action $ do + files <- getFilesOfInterest + void $ uses Example2 $ Map.keys files + +mkDiag :: NormalizedFilePath + -> DiagnosticSource + -> DiagnosticSeverity + -> Range + -> T.Text + -> FileDiagnostic +mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) + Diagnostic + { _range = loc + , _severity = Just sev + , _source = Just diagSource + , _message = msg + , _code = Nothing + , _tags = Nothing + , _relatedInformation = Nothing + } + +-- --------------------------------------------------------------------- +-- code actions +-- --------------------------------------------------------------------- + +-- | Generate code actions. +codeAction :: CodeActionProvider IdeState +codeAction _lf _state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do + let + title = "Add TODO2 Item" + tedit = [TextEdit (Range (Position 3 0) (Position 3 0)) + "-- TODO2 added by Example2 Plugin directly\n"] + edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing + pure $ Right $ List + [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) (Just edit) Nothing ] + +-- --------------------------------------------------------------------- + +codeLens :: CodeLensProvider IdeState +codeLens _lf ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do + logInfo (ideLogger ideState) "Example2.codeLens entered (ideLogger)" -- AZ + case uriToFilePath' uri of + Just (toNormalizedFilePath -> filePath) -> do + _ <- runIdeAction (fromNormalizedFilePath filePath) (shakeExtras ideState) $ runMaybeT $ useE TypeCheck filePath + _diag <- getDiagnostics ideState + _hDiag <- getHiddenDiagnostics ideState + let + title = "Add TODO2 Item via Code Lens" + range = Range (Position 3 0) (Position 4 0) + let cmdParams = AddTodoParams uri "do abc" + cmd <- mkLspCommand plId "codelens.todo" title (Just [toJSON cmdParams]) + pure $ Right $ List [ CodeLens range (Just cmd) Nothing ] + Nothing -> pure $ Right $ List [] + +-- --------------------------------------------------------------------- +-- | Parameters for the addTodo PluginCommand. +data AddTodoParams = AddTodoParams + { file :: Uri -- ^ Uri of the file to add the pragma to + , todoText :: T.Text + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +addTodoCmd :: CommandFunction IdeState AddTodoParams +addTodoCmd _lf _ide (AddTodoParams uri todoText) = do + let + pos = Position 5 0 + textEdits = List + [TextEdit (Range pos pos) + ("-- TODO2:" <> todoText <> "\n") + ] + res = WorkspaceEdit + (Just $ Map.singleton uri textEdits) + Nothing + return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res)) + +-- --------------------------------------------------------------------- + +foundHover :: (Maybe Range, [T.Text]) -> Either ResponseError (Maybe Hover) +foundHover (mbRange, contents) = + Right $ Just $ Hover (HoverContents $ MarkupContent MkMarkdown + $ T.intercalate sectionSeparator contents) mbRange + + +-- | Respond to and log a hover or go-to-definition request +request + :: T.Text + -> (NormalizedFilePath -> Position -> Action (Maybe a)) + -> Either ResponseError b + -> (a -> Either ResponseError b) + -> IdeState + -> TextDocumentPositionParams + -> IO (Either ResponseError b) +request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do + mbResult <- case uriToFilePath' uri of + Just path -> logAndRunRequest label getResults ide pos path + Nothing -> pure Nothing + pure $ maybe notFound found mbResult + +logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) + -> IdeState -> Position -> String -> IO b +logAndRunRequest label getResults ide pos path = do + let filePath = toNormalizedFilePath path + logInfo (ideLogger ide) $ + label <> " request at position " <> T.pack (showPosition pos) <> + " in file: " <> T.pack path + runAction "Example2" ide $ getResults filePath pos + +-- --------------------------------------------------------------------- + +symbols :: SymbolsProvider IdeState +symbols _lf _ide (DocumentSymbolParams _doc _mt) + = pure $ Right [r] + where + r = DocumentSymbol name detail kind deprecation range selR chList + name = "Example2_symbol_name" + detail = Nothing + kind = SkVariable + deprecation = Nothing + range = Range (Position 4 1) (Position 4 7) + selR = range + chList = Nothing + +-- --------------------------------------------------------------------- + +completion :: CompletionProvider IdeState +completion _lf _ide (CompletionParams _doc _pos _mctxt _mt) + = pure $ Right $ Completions $ List [r] + where + r = CompletionItem label kind tags detail documentation deprecated preselect + sortText filterText insertText insertTextFormat + textEdit additionalTextEdits commitCharacters + command xd + label = "Example2 completion" + kind = Nothing + tags = List [] + detail = Nothing + documentation = Nothing + deprecated = Nothing + preselect = Nothing + sortText = Nothing + filterText = Nothing + insertText = Nothing + insertTextFormat = Nothing + textEdit = Nothing + additionalTextEdits = Nothing + commitCharacters = Nothing + command = Nothing + xd = Nothing + +-- --------------------------------------------------------------------- diff --git a/plugins/default/src/Ide/Plugin/Floskell.hs b/plugins/default/src/Ide/Plugin/Floskell.hs new file mode 100644 --- /dev/null +++ b/plugins/default/src/Ide/Plugin/Floskell.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Floskell + ( + descriptor + , provider + ) +where + +import qualified Data.ByteString.Lazy as BS +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Development.IDE as D +import Floskell +import Ide.PluginUtils +import Ide.Types +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() + +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) + { pluginFormattingProvider = Just provider + } + +-- --------------------------------------------------------------------- + +-- | Format provider of Floskell. +-- Formats the given source in either a given Range or the whole Document. +-- If the provider fails an error is returned that can be displayed to the user. +provider :: FormattingProvider IdeState IO +provider _lf _ideState typ contents fp _ = do + let file = fromNormalizedFilePath fp + config <- findConfigOrDefault file + let (range, selectedContents) = case typ of + FormatText -> (fullRange contents, contents) + FormatRange r -> (r, extractRange r contents) + result = reformat config (Just file) (BS.fromStrict (T.encodeUtf8 selectedContents)) + case result of + Left err -> return $ Left $ responseError (T.pack $ "floskellCmd: " ++ err) + Right new -> return $ Right $ List [TextEdit range (T.decodeUtf8 (BS.toStrict new))] + +-- | Find Floskell Config, user and system wide or provides a default style. +-- Every directory of the filepath will be searched to find a user configuration. +-- Also looks into places such as XDG_CONFIG_DIRECTORY. +-- This function may not throw an exception and returns a default config. +findConfigOrDefault :: FilePath -> IO AppConfig +findConfigOrDefault file = do + mbConf <- findAppConfigIn file + case mbConf of + Just confFile -> readAppConfig confFile + Nothing -> + let gibiansky = head (filter (\s -> styleName s == "gibiansky") styles) + in return $ defaultAppConfig { appStyle = gibiansky } + +-- --------------------------------------------------------------------- diff --git a/plugins/default/src/Ide/Plugin/Fourmolu.hs b/plugins/default/src/Ide/Plugin/Fourmolu.hs new file mode 100644 --- /dev/null +++ b/plugins/default/src/Ide/Plugin/Fourmolu.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module Ide.Plugin.Fourmolu ( + descriptor, + provider, +) where + +import Control.Exception +import Data.Either.Extra +import System.FilePath + +import Control.Lens ((^.)) +import qualified Data.Text as T +import Development.IDE as D +import qualified DynFlags as D +import qualified EnumSet as S +import GHC (DynFlags, moduleNameString) +import GHC.LanguageExtensions.Type (Extension (Cpp)) +import GhcPlugins (HscEnv (hsc_dflags)) +import Ide.PluginUtils (responseError, makeDiffTextEdit) +import Language.Haskell.LSP.Messages (FromServerMessage (ReqShowMessage)) + +import Ide.Types +import Language.Haskell.LSP.Core +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Lens +import "fourmolu" Ormolu + +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = + (defaultPluginDescriptor plId) + { pluginFormattingProvider = Just provider + } + +-- --------------------------------------------------------------------- + +provider :: FormattingProvider IdeState IO +provider lf ideState typ contents fp fo = withIndefiniteProgress lf title Cancellable $ do + ghc <- runAction "Fourmolu" ideState $ use GhcSession fp + fileOpts <- case hsc_dflags . hscEnv <$> ghc of + Nothing -> return [] + Just df -> convertDynFlags df + + let format printerOpts = + mapLeft (responseError . ("Fourmolu: " <>) . T.pack . show) + <$> try @OrmoluException (makeDiffTextEdit contents <$> ormolu config fp' (T.unpack contents)) + where + config = + defaultConfig + { cfgDynOptions = fileOpts + , cfgRegion = region + , cfgDebug = True + , cfgPrinterOpts = + fillMissingPrinterOpts + (printerOpts <> lspPrinterOpts) + defaultPrinterOpts + } + + loadConfigFile fp' >>= \case + ConfigLoaded file opts -> do + putStrLn $ "Loaded Fourmolu config from: " <> file + format opts + ConfigNotFound searchDirs -> do + putStrLn + . unlines + $ ("No " ++ show configFileName ++ " found in any of:") : + map (" " ++) searchDirs + format mempty + ConfigParseError f (_, err) -> do + sendFunc lf . ReqShowMessage $ + RequestMessage + { _jsonrpc = "" + , _id = IdString "fourmolu" + , _method = WindowShowMessageRequest + , _params = + ShowMessageRequestParams + { _xtype = MtError + , _message = errorMessage + , _actions = Nothing + } + } + return . Left $ responseError errorMessage + where + errorMessage = "Failed to load " <> T.pack f <> ": " <> T.pack err + where + fp' = fromNormalizedFilePath fp + title = "Formatting " <> T.pack (takeFileName fp') + lspPrinterOpts = mempty{poIndentation = Just $ fo ^. tabSize} + region = case typ of + FormatText -> + RegionIndices Nothing Nothing + FormatRange (Range (Position sl _) (Position el _)) -> + RegionIndices (Just $ sl + 1) (Just $ el + 1) + +convertDynFlags :: DynFlags -> IO [DynOption] +convertDynFlags df = + let pp = if null p then [] else ["-pgmF=" <> p] + p = D.sPgm_F $ D.settings df + pm = map (("-fplugin=" <>) . moduleNameString) $ D.pluginModNames df + ex = map showExtension $ S.toList $ D.extensionFlags df + showExtension = \case + Cpp -> "-XCPP" + x -> "-X" ++ show x + in return $ map DynOption $ pp <> pm <> ex diff --git a/plugins/default/src/Ide/Plugin/ModuleName.hs b/plugins/default/src/Ide/Plugin/ModuleName.hs new file mode 100644 --- /dev/null +++ b/plugins/default/src/Ide/Plugin/ModuleName.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# OPTIONS_GHC -Wall -Wwarn -fno-warn-type-defaults -fno-warn-unused-binds -fno-warn-unused-imports #-} + +{- | Keep the module name in sync with its file path. + +Provide CodeLenses to: +* Add a module header ("module /moduleName/ where") to empty Haskell files +* Fix the module name if incorrect +-} +module Ide.Plugin.ModuleName ( + descriptor, +) where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Aeson ( + ToJSON (toJSON), + Value (Null), + ) +import Data.Char (isLower) +import qualified Data.HashMap.Strict as Map +import Data.List (find, intercalate, isPrefixOf) +import Data.Maybe (maybeToList) +import Data.String (IsString) +import Data.Text (Text, pack) +import qualified Data.Text as T +-- import Debug.Trace (trace) +import Development.IDE ( + GetParsedModule ( + GetParsedModule + ), + GhcSession (GhcSession), + HscEnvEq, + IdeState, + List (..), + NormalizedFilePath, + Position (Position), + Range (Range), + evalGhcEnv, + hscEnvWithImportPaths, + realSrcSpanToRange, + runAction, + toNormalizedUri, + uriToFilePath', + use, + use_, + ) +import GHC ( + DynFlags (importPaths), + GenLocated (L), + HsModule (hsmodName), + ParsedModule (pm_parsed_source), + SrcSpan (RealSrcSpan), + getSessionDynFlags, + unLoc, + ) +import Ide.PluginUtils (mkLspCmdId, getProcessID) +import Ide.Types ( + CommandFunction, + PluginCommand (..), + PluginDescriptor (..), + PluginId (..), + defaultPluginDescriptor, + ) +import Language.Haskell.LSP.Core ( + LspFuncs, + getVirtualFileFunc, + ) +import Language.Haskell.LSP.Types ( + ApplyWorkspaceEditParams (..), + CodeLens (CodeLens), + CodeLensParams (CodeLensParams), + Command (Command), + ServerMethod (..), + TextDocumentIdentifier ( + TextDocumentIdentifier + ), + TextEdit (TextEdit), + Uri, + WorkspaceEdit (..), + uriToNormalizedFilePath, + ) +import Language.Haskell.LSP.VFS (virtualFileText) +import System.Directory (canonicalizePath) +import System.FilePath ( + dropExtension, + splitDirectories, + takeFileName, + ) + +-- |Plugin descriptor +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = + (defaultPluginDescriptor plId) + { pluginCodeLensProvider = Just codeLens + , pluginCommands = [PluginCommand editCommandName editCommandName command] + } + +editCommandName :: IsString p => p +editCommandName = "edit" + +asCodeLens :: Text -> Action -> CodeLens +asCodeLens cid Replace{..} = + CodeLens + aRange + (Just $ Command aTitle cid (Just (List [toJSON aUri]))) + Nothing + +-- | Generate code lenses +codeLens :: + LspFuncs c -> + IdeState -> + PluginId -> + CodeLensParams -> + IO (Either a2 (List CodeLens)) +codeLens lsp state pluginId (CodeLensParams (TextDocumentIdentifier uri) _) = + do + pid <- pack . show <$> getProcessID + Right . List . maybeToList . (asCodeLens (mkLspCmdId pid pluginId editCommandName) <$>) <$> action lsp state uri + +-- | (Quasi) Idempotent command execution: recalculate action to execute on command request +command :: CommandFunction IdeState Uri +command lsp state uri = do + actMaybe <- action lsp state uri + return + ( Right Null + , (\act -> (WorkspaceApplyEdit, ApplyWorkspaceEditParams $ asEdit act)) <$> actMaybe + ) + +-- | A source code change +data Action = Replace {aUri :: Uri, aRange :: Range, aTitle :: Text, aCode :: Text} deriving (Show) + +-- | Convert an Action to the corresponding edit operation +asEdit :: Action -> WorkspaceEdit +asEdit act@Replace{..} = + WorkspaceEdit (Just $ Map.singleton aUri $ List (asTextEdits act)) Nothing + +asTextEdits :: Action -> [TextEdit] +asTextEdits Replace{..} = [TextEdit aRange aCode] + +-- | Required action (that can be converted to either CodeLenses or CodeActions) +action :: LspFuncs c -> IdeState -> Uri -> IO (Maybe Action) +action lsp state uri = + traceAs "action" <$> do + let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri + let Just fp = uriToFilePath' uri + + contents <- liftIO $ getVirtualFileFunc lsp $ toNormalizedUri uri + let emptyModule = maybe True (T.null . T.strip . virtualFileText) contents + + correctNameMaybe <- traceAs "correctName" <$> pathModuleName state nfp fp + statedNameMaybe <- traceAs "statedName" <$> codeModuleName state nfp + + let act = Replace uri + let todo = case (correctNameMaybe, statedNameMaybe) of + (Just correctName, Just (nameRange, statedName)) + | correctName /= statedName -> + Just $ + act + nameRange + ("Set module name to " <> correctName) + correctName + (Just correctName, _) + | emptyModule -> + let code = T.unwords ["module", correctName, "where\n"] + in Just $ act (Range (Position 0 0) (Position 0 0)) code code + _ -> Nothing + return todo + +-- | The module name, as derived by the position of the module in its source directory +pathModuleName :: IdeState -> NormalizedFilePath -> String -> IO (Maybe Text) +pathModuleName state normFilePath filePath + | isLower (head $ takeFileName filePath) = return $ Just "Main" + | otherwise = do + session :: HscEnvEq <- runAction "ModuleName.ghcSession" state $ use_ GhcSession normFilePath + srcPaths <- evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags + paths <- mapM canonicalizePath srcPaths + mdlPath <- canonicalizePath filePath + let maybePrefix = find (`isPrefixOf` mdlPath) paths + + let maybeMdlName = + ( \prefix -> + intercalate "." + . splitDirectories + . drop (length prefix + 1) + $ dropExtension mdlPath + ) + <$> maybePrefix + return $ T.pack <$> maybeMdlName + +-- | The module name, as stated in the module +codeModuleName :: IdeState -> NormalizedFilePath -> IO (Maybe (Range, Text)) +codeModuleName state nfp = + ((\(L (RealSrcSpan l) m) -> (realSrcSpanToRange l, T.pack . show $ m)) <$>) + . ((hsmodName . unLoc . pm_parsed_source) =<<) + <$> runAction "ModuleName.GetParsedModule" state (use GetParsedModule nfp) + +-- traceAs :: Show a => String -> a -> a +-- traceAs lbl a = trace (lbl ++ " = " ++ show a) a + +traceAs :: b -> a -> a +traceAs _ a = a diff --git a/plugins/default/src/Ide/Plugin/Ormolu.hs b/plugins/default/src/Ide/Plugin/Ormolu.hs new file mode 100644 --- /dev/null +++ b/plugins/default/src/Ide/Plugin/Ormolu.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Ide.Plugin.Ormolu + ( + descriptor + , provider + ) +where + +import Control.Exception +import qualified Data.Text as T +import Development.IDE +import qualified DynFlags as D +import qualified EnumSet as S +import GHC +import GHC.LanguageExtensions.Type +import GhcPlugins (HscEnv (hsc_dflags)) +import Ide.PluginUtils +import Ide.Types +import Language.Haskell.LSP.Core (LspFuncs (withIndefiniteProgress), + ProgressCancellable (Cancellable)) +import Language.Haskell.LSP.Types +import "ormolu" Ormolu +import System.FilePath (takeFileName) +import Text.Regex.TDFA.Text () + +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) + { pluginFormattingProvider = Just provider + } + +-- --------------------------------------------------------------------- + +provider :: FormattingProvider IdeState IO +provider lf ideState typ contents fp _ = withIndefiniteProgress lf title Cancellable $ do + let + fromDyn :: DynFlags -> IO [DynOption] + fromDyn df = + let + pp = + let p = D.sPgm_F $ D.settings df + in if null p then [] else ["-pgmF=" <> p] + pm = map (("-fplugin=" <>) . moduleNameString) $ D.pluginModNames df + ex = map showExtension $ S.toList $ D.extensionFlags df + in + return $ map DynOption $ pp <> pm <> ex + + ghc <- runAction "Ormolu" ideState $ use GhcSession fp + let df = hsc_dflags . hscEnv <$> ghc + fileOpts <- case df of + Nothing -> return [] + Just df -> fromDyn df + + let + fullRegion = RegionIndices Nothing Nothing + rangeRegion s e = RegionIndices (Just $ s + 1) (Just $ e + 1) + mkConf o region = defaultConfig { cfgDynOptions = o, cfgRegion = region } + fmt :: T.Text -> Config RegionIndices -> IO (Either OrmoluException T.Text) + fmt cont conf = + try @OrmoluException (ormolu conf (fromNormalizedFilePath fp) $ T.unpack cont) + + case typ of + FormatText -> ret <$> fmt contents (mkConf fileOpts fullRegion) + FormatRange (Range (Position sl _) (Position el _)) -> + ret <$> fmt contents (mkConf fileOpts (rangeRegion sl el)) + where + title = T.pack $ "Formatting " <> takeFileName (fromNormalizedFilePath fp) + ret :: Either OrmoluException T.Text -> Either ResponseError (List TextEdit) + ret (Left err) = Left + (responseError (T.pack $ "ormoluCmd: " ++ show err) ) + ret (Right new) = Right (makeDiffTextEdit contents new) + +showExtension :: Extension -> String +showExtension Cpp = "-XCPP" +showExtension other = "-X" ++ show other diff --git a/plugins/default/src/Ide/Plugin/Pragmas.hs b/plugins/default/src/Ide/Plugin/Pragmas.hs new file mode 100644 --- /dev/null +++ b/plugins/default/src/Ide/Plugin/Pragmas.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides code actions to add missing pragmas (whenever GHC suggests to) +module Ide.Plugin.Pragmas + ( + descriptor + -- , commands -- TODO: get rid of this + ) where + +import Control.Lens hiding (List) +import Data.Aeson +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import Development.IDE as D +import qualified GHC.Generics as Generics +import Ide.Types +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types as J +import qualified Language.Haskell.LSP.Types.Lens as J + +import Control.Monad (join) +import Development.IDE.GHC.Compat +import qualified Language.Haskell.LSP.Core as LSP +import qualified Language.Haskell.LSP.VFS as VFS + +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) + { pluginCodeActionProvider = Just codeActionProvider + , pluginCompletionProvider = Just completion + } + +-- --------------------------------------------------------------------- + +-- | Parameters for the addPragma PluginCommand. +data AddPragmaParams = AddPragmaParams + { file :: J.Uri -- ^ Uri of the file to add the pragma to + , pragma :: T.Text -- ^ Name of the Pragma to add + } + deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON) + +-- | Add a Pragma to the given URI at the top of the file. +-- Pragma is added to the first line of the Uri. +-- It is assumed that the pragma name is a valid pragma, +-- thus, not validated. +mkPragmaEdit :: Uri -> T.Text -> WorkspaceEdit +mkPragmaEdit uri pragmaName = res where + pos = J.Position 0 0 + textEdits = J.List + [J.TextEdit (J.Range pos pos) + ("{-# LANGUAGE " <> pragmaName <> " #-}\n") + ] + res = J.WorkspaceEdit + (Just $ H.singleton uri textEdits) + Nothing + +-- --------------------------------------------------------------------- +-- | Offer to add a missing Language Pragma to the top of a file. +-- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'. +codeActionProvider :: CodeActionProvider IdeState +codeActionProvider _ state _plId docId _ (J.CodeActionContext (J.List diags) _monly) = do + let mFile = docId ^. J.uri & uriToFilePath <&> toNormalizedFilePath' + pm <- fmap join $ runAction "addPragma" state $ getParsedModule `traverse` mFile + let dflags = ms_hspp_opts . pm_mod_summary <$> pm + -- Filter diagnostics that are from ghcmod + ghcDiags = filter (\d -> d ^. J.source == Just "typecheck") diags + -- Get all potential Pragmas for all diagnostics. + pragmas = concatMap (\d -> genPragma dflags (d ^. J.message)) ghcDiags + cmds <- mapM mkCodeAction pragmas + return $ Right $ List cmds + where + mkCodeAction pragmaName = do + let + codeAction = J.CACodeAction $ J.CodeAction title (Just J.CodeActionQuickFix) (Just (J.List [])) (Just edit) Nothing + title = "Add \"" <> pragmaName <> "\"" + edit = mkPragmaEdit (docId ^. J.uri) pragmaName + return codeAction + + genPragma mDynflags target + | Just dynFlags <- mDynflags, + -- GHC does not export 'OnOff', so we have to view it as string + disabled <- [ e | Just e <- T.stripPrefix "Off " . T.pack . prettyPrint <$> extensions dynFlags] + = [ r | r <- findPragma target, r `notElem` disabled] + | otherwise = [] + + +-- --------------------------------------------------------------------- + +-- | Find all Pragmas are an infix of the search term. +findPragma :: T.Text -> [T.Text] +findPragma str = concatMap check possiblePragmas + where + check p = [p | T.isInfixOf p str] + +-- --------------------------------------------------------------------- + +-- | Possible Pragma names. +-- See discussion at https://github.com/haskell/ghcide/pull/638 +possiblePragmas :: [T.Text] +possiblePragmas = [name | FlagSpec{flagSpecName = T.pack -> name} <- xFlags, "Strict" /= name] + +-- --------------------------------------------------------------------- + +completion :: CompletionProvider IdeState +completion lspFuncs _ide complParams = do + let (TextDocumentIdentifier uri) = complParams ^. J.textDocument + position = complParams ^. J.position + contents <- LSP.getVirtualFileFunc lspFuncs $ toNormalizedUri uri + fmap Right $ case (contents, uriToFilePath' uri) of + (Just cnts, Just _path) -> do + pfix <- VFS.getCompletionPrefix position cnts + return $ result pfix + where + result (Just pfix) + | "{-# LANGUAGE" `T.isPrefixOf` VFS.fullLine pfix + = Completions $ List $ map buildCompletion possiblePragmas + | otherwise + = Completions $ List [] + result Nothing = Completions $ List [] + buildCompletion p = + CompletionItem + { _label = p, + _kind = Just CiKeyword, + _tags = List [], + _detail = Nothing, + _documentation = Nothing, + _deprecated = Nothing, + _preselect = Nothing, + _sortText = Nothing, + _filterText = Nothing, + _insertText = Nothing, + _insertTextFormat = Nothing, + _textEdit = Nothing, + _additionalTextEdits = Nothing, + _commitCharacters = Nothing, + _command = Nothing, + _xdata = Nothing + } + _ -> return $ Completions $ List [] diff --git a/plugins/default/src/Ide/Plugin/StylishHaskell.hs b/plugins/default/src/Ide/Plugin/StylishHaskell.hs new file mode 100644 --- /dev/null +++ b/plugins/default/src/Ide/Plugin/StylishHaskell.hs @@ -0,0 +1,59 @@ +module Ide.Plugin.StylishHaskell + ( + descriptor + , provider + ) +where + +import Control.Monad.IO.Class +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE (IdeState) +import Ide.PluginUtils +import Ide.Types +import Language.Haskell.Stylish +import Language.Haskell.LSP.Types as J + +import System.Directory +import System.FilePath + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) + { pluginFormattingProvider = Just provider + } + +-- | Formatter provider of stylish-haskell. +-- Formats the given source in either a given Range or the whole Document. +-- If the provider fails an error is returned that can be displayed to the user. +provider :: FormattingProvider IdeState IO +provider _lf _ideState typ contents fp _opts = do + let file = fromNormalizedFilePath fp + config <- liftIO $ loadConfigFrom file + let (range, selectedContents) = case typ of + FormatText -> (fullRange contents, contents) + FormatRange r -> (normalize r, extractRange r contents) + result = runStylishHaskell file config selectedContents + case result of + Left err -> return $ Left $ responseError $ T.pack $ "stylishHaskellCmd: " ++ err + Right new -> return $ Right $ J.List [TextEdit range new] + +-- | Recursively search in every directory of the given filepath for .stylish-haskell.yaml. +-- If no such file has been found, return default config. +loadConfigFrom :: FilePath -> IO Config +loadConfigFrom file = do + currDir <- getCurrentDirectory + setCurrentDirectory (takeDirectory file) + config <- loadConfig (makeVerbose False) Nothing + setCurrentDirectory currDir + return config + +-- | Run stylish-haskell on the given text with the given configuration. +runStylishHaskell :: FilePath -- ^ Location of the file being formatted. Used for error message + -> Config -- ^ Configuration for stylish-haskell + -> Text -- ^ Text to format + -> Either String Text -- ^ Either formatted Text or an error message +runStylishHaskell file config = fmap fromLines . fmt . toLines + where + fromLines = T.pack . unlines + fmt = runSteps (configLanguageExtensions config) (Just file) (configSteps config) + toLines = lines . T.unpack diff --git a/plugins/hls-eval-plugin/test/Eval.hs b/plugins/hls-eval-plugin/test/Eval.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/Eval.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Eval ( + tests, +) where + +import Control.Applicative.Combinators ( + skipManyTill, + ) +import Control.Monad (when) +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 ( + Session, + anyMessage, + documentContents, + executeCommand, + fullCaps, + getCodeLenses, + message, + openDoc, + runSession, + ) +import Language.Haskell.LSP.Types ( + ApplyWorkspaceEditRequest, + CodeLens (CodeLens, _command, _range), + Command (Command, _title), + Position (..), + Range (..), + TextDocumentIdentifier, + ) +import System.Directory (doesFileExist) +import System.FilePath ( + (<.>), + (), + ) +import Test.Hls.Util (hlsCommand) +import Test.Tasty ( + TestTree, + testGroup, + ) +import Test.Tasty.ExpectedFailure ( + expectFailBecause, + ignoreTestBecause, + ) +import Test.Tasty.HUnit ( + testCase, + (@?=), + ) + +tests :: TestTree +tests = + testGroup + "eval" + [ testCase "Produces Evaluate code lenses" $ + runSession hlsCommand fullCaps evalPath $ do + doc <- openDoc "T1.hs" "haskell" + lenses <- getEvalCodeLenses doc + liftIO $ map (fmap _title . _command) lenses @?= [Just "Evaluate..."] + , testCase "Produces Refresh code lenses" $ + runSession hlsCommand fullCaps evalPath $ do + doc <- openDoc "T2.hs" "haskell" + lenses <- getEvalCodeLenses doc + liftIO $ map (fmap _title . _command) lenses @?= [Just "Refresh..."] + , testCase "Code lenses have ranges" $ + runSession hlsCommand fullCaps evalPath $ do + doc <- openDoc "T1.hs" "haskell" + lenses <- getEvalCodeLenses doc + liftIO $ map _range lenses @?= [Range (Position 4 0) (Position 5 0)] + , testCase "Multi-line expressions have a multi-line range" $ do + runSession hlsCommand fullCaps evalPath $ do + doc <- openDoc "T3.hs" "haskell" + lenses <- getEvalCodeLenses doc + liftIO $ map _range lenses @?= [Range (Position 3 0) (Position 5 0)] + , testCase "Executed expressions range covers only the expression" $ do + runSession hlsCommand fullCaps evalPath $ do + doc <- openDoc "T2.hs" "haskell" + lenses <- getEvalCodeLenses doc + liftIO $ map _range lenses @?= [Range (Position 4 0) (Position 5 0)] + , testCase "Evaluation of expressions" $ goldenTest "T1.hs" + , testCase "Reevaluation of expressions" $ goldenTest "T2.hs" + , testCase "Evaluation of expressions w/ imports" $ goldenTest "T3.hs" + , testCase "Evaluation of expressions w/ lets" $ goldenTest "T4.hs" + , testCase "Refresh an evaluation" $ goldenTest "T5.hs" + , testCase "Refresh an evaluation w/ lets" $ goldenTest "T6.hs" + , testCase "Refresh a multiline evaluation" $ goldenTest "T7.hs" + , testCase "Semantic and Lexical errors are reported" $ goldenTest "T8.hs" + , testCase "Applies file LANGUAGE extensions" $ goldenTest "T9.hs" + , testCase "Evaluate a type with :kind!" $ goldenTest "T10.hs" + , testCase "Reports an error for an incorrect type with :kind!" $ + goldenTest "T11.hs" + , testCase "Shows a kind with :kind" $ goldenTest "T12.hs" + , testCase "Reports an error for an incorrect type with :kind" $ + goldenTest "T13.hs" + , testCase "Returns a fully-instantiated type for :type" $ + goldenTest "T14.hs" + , testCase "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" $ + goldenTest "T15.hs" + , testCase "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments" $ + goldenTest "T16.hs" + , testCase ":type reports an error when given with unknown +x option" $ + goldenTest "T17.hs" + , testCase "Reports an error when given with unknown command" $ + goldenTest "T18.hs" + , testCase "Returns defaulted type for :type +d reflecting the default declaration specified in the >>> prompt" $ + goldenTest "T19.hs" + , expectFailBecause "known issue - see a note in P.R. #361" $ + testCase ":type +d reflects the `default' declaration of the module" $ + goldenTest "T20.hs" + , testCase ":type handles a multilined result properly" $ + goldenTest "T21.hs" + , testCase ":t behaves exactly the same as :type" $ + goldenTest "T22.hs" + , testCase ":type does \"dovetails\" for short identifiers" $ + goldenTest "T23.hs" + , testCase ":kind! treats a multilined result properly" $ + goldenTest "T24.hs" + , testCase ":kind treats a multilined result properly" $ + goldenTest "T25.hs" + , testCase "local imports" $ + goldenTest "T26.hs" + , testCase "Preserves one empty comment line after prompt" $ + goldenTest "T27.hs" + , testCase + "Multi line comments" + $ goldenTest "TMulti.hs" + , testCase + "Evaluate expressions in Plain comments in both single line and multi line format" + $ goldenTest "TPlainComment.hs" + , testCase + "Evaluate expressions in Haddock comments in both single line and multi line format" + $ goldenTest "THaddock.hs" + , testCase "Compare results (for Haddock tests only)" $ + goldenTest "TCompare.hs" + , testCase "Local Modules imports are accessible in a test" $ + goldenTest "TLocalImport.hs" + , -- , testCase "Local Modules can be imported in a test" $ goldenTest "TLocalImportInTest.hs" + ignoreTestBecause "Unexplained but minor issue" $ + testCase "Setting language option TupleSections" $ + goldenTest "TLanguageOptionsTupleSections.hs" + , testCase "IO expressions are supported, stdout/stderr output is ignored" $ + goldenTest "TIO.hs" + , testCase "Property checking" $ goldenTest "TProperty.hs" + , testCase + "Prelude has no special treatment, it is imported as stated in the module" + $ goldenTest "TPrelude.hs" +#if __GLASGOW_HASKELL__ >= 808 + , testCase "CPP support" $ goldenTest "TCPP.hs" + , testCase "Literate Haskell Bird Style" $ goldenTest "TLHS.lhs" +#endif + -- , testCase "Literate Haskell LaTeX Style" $ goldenTest "TLHSLateX.lhs" + ] + +goldenTest :: FilePath -> IO () +goldenTest = goldenTestBy isEvalTest + +{- |Execute all CodeLens accepted by 'filter' + Compare results with the contents of corresponding '.expected' file (and creates it, if missing) +-} +goldenTestBy :: (CodeLens -> Bool) -> FilePath -> IO () +goldenTestBy f input = runSession hlsCommand fullCaps evalPath $ do + doc <- openDoc input "haskell" + + -- Execute lenses backwards, to avoid affecting their position in the source file + codeLenses <- reverse <$> getCodeLensesBy f doc + -- liftIO $ print codeLenses + + -- Execute sequentially + mapM_ executeCmd $ [c | CodeLens{_command = Just c} <- codeLenses] + + edited <- replaceUnicodeQuotes <$> documentContents doc + -- liftIO $ T.putStrLn edited + + let expectedFile = evalPath input <.> "expected" + + liftIO $ do + -- Write expected file if missing + missingExpected <- not <$> doesFileExist expectedFile + when missingExpected $ T.writeFile expectedFile edited + + expected <- liftIO $ T.readFile expectedFile + liftIO $ edited @?= expected + +getEvalCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] +getEvalCodeLenses = getCodeLensesBy isEvalTest + +getCodeLensesBy :: (CodeLens -> Bool) -> TextDocumentIdentifier -> Session [CodeLens] +getCodeLensesBy f doc = filter f <$> getCodeLenses doc + +-- Execute command and wait for result +executeCmd :: Command -> Session () +executeCmd cmd = do + executeCommand cmd + _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + -- liftIO $ print _resp + return () + +-- Execute only Eval tests to avoid interference from other plugins (e.g ghcide:typesignature.add) +isEvalTest :: CodeLens -> Bool +isEvalTest (CodeLens _ (Just (Command _ cmd _)) _) + | ":eval:" `T.isInfixOf` cmd = True +isEvalTest _ = False + +replaceUnicodeQuotes :: T.Text -> T.Text +replaceUnicodeQuotes = T.replace "‘" "'" . T.replace "’" "'" + +evalPath :: FilePath +evalPath = "plugins/hls-eval-plugin/test/testdata" diff --git a/plugins/tactics/src/Ide/Plugin/Tactic/TestTypes.hs b/plugins/tactics/src/Ide/Plugin/Tactic/TestTypes.hs new file mode 100644 --- /dev/null +++ b/plugins/tactics/src/Ide/Plugin/Tactic/TestTypes.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.Tactic.TestTypes where + +import qualified Data.Text as T + +------------------------------------------------------------------------------ +-- | The list of tactics exposed to the outside world. These are attached to +-- actual tactics via 'commandTactic' and are contextually provided to the +-- editor via 'commandProvider'. +data TacticCommand + = Auto + | Intros + | Destruct + | Homomorphism + | DestructLambdaCase + | HomomorphismLambdaCase + deriving (Eq, Ord, Show, Enum, Bounded) + +-- | Generate a title for the command. +tacticTitle :: TacticCommand -> T.Text -> T.Text +tacticTitle Auto _ = "Attempt to fill hole" +tacticTitle Intros _ = "Introduce lambda" +tacticTitle Destruct var = "Case split on " <> var +tacticTitle Homomorphism var = "Homomorphic case split on " <> var +tacticTitle DestructLambdaCase _ = "Lambda case split" +tacticTitle HomomorphismLambdaCase _ = "Homomorphic lambda case split" diff --git a/src/Ide/Arguments.hs b/src/Ide/Arguments.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Arguments.hs @@ -0,0 +1,127 @@ +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} -- To get precise GHC version +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above + +module Ide.Arguments + ( Arguments(..) + , LspArguments(..) + , PrintVersion(..) + , getArguments + , haskellLanguageServerVersion + , haskellLanguageServerNumericVersion + ) where + +import Data.Version +import Development.GitRev +import Options.Applicative +import Paths_haskell_language_server +import System.Environment + +-- --------------------------------------------------------------------- + +data Arguments + = VersionMode PrintVersion + | ProbeToolsMode + | LspMode LspArguments + deriving Show + +data LspArguments = LspArguments + {argLSP :: Bool + ,argsCwd :: Maybe FilePath + ,argFiles :: [FilePath] + ,argsShakeProfiling :: Maybe FilePath + ,argsTesting :: Bool + ,argsExamplePlugin :: Bool + -- These next two are for compatibility with existing hie clients, allowing + -- them to just change the name of the exe and still work. + , argsDebugOn :: Bool + , argsLogFile :: Maybe String + , argsThreads :: Int + , argsProjectGhcVersion :: Bool + } deriving Show + +data PrintVersion + = PrintVersion + | PrintNumericVersion + deriving (Show, Eq, Ord) + +getArguments :: String -> IO Arguments +getArguments exeName = execParser opts + where + opts = info (( + VersionMode <$> printVersionParser exeName + <|> probeToolsParser exeName + <|> LspMode <$> arguments) + <**> helper) + ( fullDesc + <> progDesc "Used as a test bed to check your IDE Client will work" + <> header (exeName ++ " - GHC Haskell LSP server")) + +printVersionParser :: String -> Parser PrintVersion +printVersionParser exeName = + flag' PrintVersion + (long "version" <> help ("Show " ++ exeName ++ " and GHC versions")) + <|> + flag' PrintNumericVersion + (long "numeric-version" <> help ("Show numeric version of " ++ exeName)) + +probeToolsParser :: String -> Parser Arguments +probeToolsParser exeName = + flag' ProbeToolsMode + (long "probe-tools" <> help ("Show " ++ exeName ++ " version and other tools of interest")) + +arguments :: Parser LspArguments +arguments = LspArguments + <$> switch (long "lsp" <> help "Start talking to an LSP server") + <*> optional (strOption $ long "cwd" <> metavar "DIR" + <> help "Change to this directory") + <*> many (argument str (metavar "FILES/DIRS...")) + <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" + <> help "Dump profiling reports to this directory") + <*> switch (long "test" + <> help "Enable additional lsp messages used by the testsuite") + <*> switch (long "example" + <> help "Include the Example Plugin. For Plugin devs only") + + <*> switch + ( long "debug" + <> short 'd' + <> help "Generate debug output" + ) + <*> optional (strOption + ( long "logfile" + <> short 'l' + <> metavar "LOGFILE" + <> help "File to log to, defaults to stdout" + )) + <*> option auto + (short 'j' + <> help "Number of threads (0: automatic)" + <> metavar "NUM" + <> value 0 + <> showDefault + ) + <*> switch (long "project-ghc-version" + <> help "Work out the project GHC version and print it") + +-- --------------------------------------------------------------------- + +haskellLanguageServerNumericVersion :: String +haskellLanguageServerNumericVersion = showVersion version + +haskellLanguageServerVersion :: IO String +haskellLanguageServerVersion = do + path <- getExecutablePath + let gitHashSection = case $(gitHash) of + x | x == "UNKNOWN" -> "" + x -> " (GIT hash: " <> x <> ")" + return $ "haskell-language-server version: " <> haskellLanguageServerNumericVersion + <> " (GHC: " <> VERSION_ghc + <> ") (PATH: " <> path <> ")" + <> gitHashSection + diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Main.hs @@ -0,0 +1,203 @@ +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} -- To get precise GHC version +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Main(defaultMain, runLspMode) where + +import Control.Concurrent.Extra +import Control.Monad.Extra +import Data.Default +import Data.List.Extra +import qualified Data.Map.Strict as Map +import qualified Data.HashMap.Strict as HashMap +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Development.IDE.Core.Debouncer +import Development.IDE.Core.FileStore +import Development.IDE.Core.OfInterest +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Rules +import Development.IDE.Core.Service +import Development.IDE.Core.Shake +import Development.IDE.LSP.LanguageServer +import Development.IDE.LSP.Protocol +import Development.IDE.Plugin +import Development.IDE.Plugin.HLS +import Development.IDE.Session (loadSession, findCradle, defaultLoadingOptions) +import Development.IDE.Types.Diagnostics +import Development.IDE.Types.Location +import Development.IDE.Types.Logger as G +import Development.IDE.Types.Options +import qualified Language.Haskell.LSP.Core as LSP +import Ide.Arguments +import Ide.Logger +import Ide.Version +import Ide.Plugin.Config +import Ide.PluginUtils +import Ide.Types (IdePlugins, ipMap) +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types +import qualified System.Directory.Extra as IO +import System.Exit +import System.FilePath +import System.IO +import qualified System.Log.Logger as L +import System.Time.Extra +import Development.Shake (action) + +ghcIdePlugins :: T.Text -> IdePlugins IdeState -> (Plugin Config, [T.Text]) +ghcIdePlugins pid ps = (asGhcIdePlugin ps, allLspCmdIds' pid ps) + +defaultMain :: Arguments -> IdePlugins IdeState -> IO () +defaultMain args idePlugins = do + -- WARNING: If you write to stdout before runLanguageServer + -- then the language server will not work + + hlsVer <- haskellLanguageServerVersion + case args of + ProbeToolsMode -> do + programsOfInterest <- findProgramVersions + putStrLn hlsVer + putStrLn "Tool versions found on the $PATH" + putStrLn $ showProgramVersionOfInterest programsOfInterest + + VersionMode PrintVersion -> + putStrLn hlsVer + + VersionMode PrintNumericVersion -> + putStrLn haskellLanguageServerNumericVersion + + LspMode lspArgs -> do + {- see WARNING above -} + hPutStrLn stderr hlsVer + runLspMode lspArgs idePlugins + +-- --------------------------------------------------------------------- + +hlsLogger :: G.Logger +hlsLogger = G.Logger $ \pri txt -> + case pri of + G.Telemetry -> logm (T.unpack txt) + G.Debug -> debugm (T.unpack txt) + G.Info -> logm (T.unpack txt) + G.Warning -> warningm (T.unpack txt) + G.Error -> errorm (T.unpack txt) + +-- --------------------------------------------------------------------- + +runLspMode :: LspArguments -> IdePlugins IdeState -> IO () +runLspMode lspArgs@LspArguments{..} idePlugins = do + LSP.setupLogger argsLogFile ["hls", "hie-bios"] + $ if argsDebugOn then L.DEBUG else L.INFO + + -- lock to avoid overlapping output on stdout + lock <- newLock + let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $ + T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg + + whenJust argsCwd IO.setCurrentDirectory + + dir <- IO.getCurrentDirectory + + pid <- T.pack . show <$> getProcessID + let + (plugins, commandIds) = ghcIdePlugins pid idePlugins + options = def { LSP.executeCommandCommands = Just commandIds + , LSP.completionTriggerCharacters = Just "." + } + + if argLSP then do + t <- offsetTime + hPutStrLn stderr "Starting (haskell-language-server)LSP server..." + hPutStrLn stderr $ " with arguments: " <> show lspArgs + hPutStrLn stderr $ " with plugins: " <> show (Map.keys $ ipMap idePlugins) + hPutStrLn stderr $ " in directory: " <> dir + hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" + + runLanguageServer options (pluginHandler plugins) getInitialConfig getConfigFromNotification $ \getLspId event vfs caps wProg wIndefProg _getConfig _rootPath -> do + t <- t + hPutStrLn stderr $ "Started LSP server in " ++ showDuration t + sessionLoader <- loadSession dir + -- config <- fromMaybe defaultLspConfig <$> getConfig + let options = (defaultIdeOptions sessionLoader) + { optReportProgress = clientSupportsProgress caps + , optShakeProfiling = argsShakeProfiling + , optTesting = IdeTesting argsTesting + , optThreads = argsThreads + -- , optCheckParents = checkParents config + -- , optCheckProject = checkProject config + } + debouncer <- newAsyncDebouncer + initialise caps (mainRule >> pluginRules plugins >> action kick) + getLspId event wProg wIndefProg hlsLogger debouncer options vfs + else do + -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 + + putStrLn $ "(haskell-language-server)Ghcide setup tester in " ++ dir ++ "." + putStrLn "Report bugs at https://github.com/haskell/haskell-language-server/issues" + programsOfInterest <- findProgramVersions + putStrLn "" + putStrLn "Tool versions found on the $PATH" + putStrLn $ showProgramVersionOfInterest programsOfInterest + + putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir + files <- expandFiles (argFiles ++ ["." | null argFiles]) + -- LSP works with absolute file paths, so try and behave similarly + files <- nubOrd <$> mapM IO.canonicalizePath files + putStrLn $ "Found " ++ show (length files) ++ " files" + + putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup" + cradles <- mapM (findCradle defaultLoadingOptions) files + let ucradles = nubOrd cradles + let n = length ucradles + putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1] + putStrLn "\nStep 3/4: Initializing the IDE" + vfs <- makeVFSHandle + debouncer <- newAsyncDebouncer + let dummyWithProg _ _ f = f (const (pure ())) + sessionLoader <- loadSession dir + ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger Info) debouncer (defaultIdeOptions sessionLoader) vfs + + putStrLn "\nStep 4/4: Type checking the files" + setFilesOfInterest ide $ HashMap.fromList $ map ((, OnDisk) . toNormalizedFilePath') files + results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files) + let (worked, failed) = partition fst $ zip (map isJust results) files + when (failed /= []) $ + putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed + + let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files" + putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)" + unless (null failed) (exitWith $ ExitFailure (length failed)) + +expandFiles :: [FilePath] -> IO [FilePath] +expandFiles = concatMapM $ \x -> do + b <- IO.doesFileExist x + if b then return [x] else do + let recurse "." = True + recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc + recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories + files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x + when (null files) $ + fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x + return files + +-- | Print an LSP event. +showEvent :: Lock -> FromServerMessage -> IO () +showEvent _ (EventFileDiagnostics _ []) = return () +showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) = + withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags +showEvent lock e = withLock lock $ print e diff --git a/src/Ide/Version.hs b/src/Ide/Version.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Version.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Information and display strings for HIE's version +-- and the current project's version +module Ide.Version where + +import Development.GitRev (gitCommitCount) +import Options.Applicative.Simple (simpleVersion) +import qualified Paths_haskell_language_server as Meta +import System.Info +import Data.Version +import Data.Maybe (listToMaybe) +import System.Directory +import System.Process +import System.Exit +import Text.ParserCombinators.ReadP + +-- >>> hlsVersion +hlsVersion :: String +hlsVersion = + let commitCount = $gitCommitCount + in concat $ concat + [ [$(simpleVersion Meta.version)] + -- Leave out number of commits for --depth=1 clone + -- See https://github.com/commercialhaskell/stack/issues/792 + , [" (" ++ commitCount ++ " commits)" | commitCount /= ("1"::String) && + commitCount /= ("UNKNOWN" :: String)] + , [" ", arch] + , [" ", hlsGhcDisplayVersion] + ] + where + hlsGhcDisplayVersion = compilerName ++ "-" ++ VERSION_ghc + +data ProgramsOfInterest = ProgramsOfInterest + { cabalVersion :: Maybe Version + , stackVersion :: Maybe Version + , ghcVersion :: Maybe Version + } + +showProgramVersionOfInterest :: ProgramsOfInterest -> String +showProgramVersionOfInterest ProgramsOfInterest {..} = + unlines + [ concat ["cabal:\t\t", showVersionWithDefault cabalVersion] + , concat ["stack:\t\t", showVersionWithDefault stackVersion] + , concat ["ghc:\t\t", showVersionWithDefault ghcVersion] + ] + where + showVersionWithDefault :: Maybe Version -> String + showVersionWithDefault = maybe ("Not found") showVersion + +findProgramVersions :: IO ProgramsOfInterest +findProgramVersions = ProgramsOfInterest + <$> findVersionOf "cabal" + <*> findVersionOf "stack" + <*> findVersionOf "ghc" + +-- | Find the version of the given program. +-- Assumes the program accepts the cli argument "--numeric-version". +-- If the invocation has a non-zero exit-code, we return 'Nothing' +findVersionOf :: FilePath -> IO (Maybe Version) +findVersionOf tool = + findExecutable tool >>= \case + Nothing -> pure Nothing + Just path -> + readProcessWithExitCode path ["--numeric-version"] "" >>= \case + (ExitSuccess, sout, _) -> pure $ consumeParser myVersionParser sout + _ -> pure $ Nothing + where + myVersionParser = do + skipSpaces + version <- parseVersion + skipSpaces + pure version + + consumeParser :: ReadP a -> String -> Maybe a + consumeParser p input = listToMaybe $ map fst . filter (null . snd) $ readP_to_S p input diff --git a/test/functional/Class.hs b/test/functional/Class.hs new file mode 100644 --- /dev/null +++ b/test/functional/Class.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE LambdaCase #-} +-- {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Class + ( tests + ) +where + +import Control.Lens hiding ((<.>)) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import qualified Data.ByteString.Lazy as BS +import qualified Data.Text.Encoding as T +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Types hiding (_title, _command) +import qualified Language.Haskell.LSP.Types.Lens as J +import System.FilePath +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.Golden +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup + "class" + [ testCase "Produces addMinimalMethodPlaceholders code actions for one instance" $ do + runSession hlsCommand fullCaps classPath $ do + doc <- openDoc "T1.hs" "haskell" + _ <- waitForDiagnosticsFromSource doc "typecheck" + caResults <- getAllCodeActions doc + liftIO $ map (^? _CACodeAction . J.title) caResults + @?= + [ Just "Add placeholders for '=='" + , Just "Add placeholders for '/='" + ] + , glodenTest "Creates a placeholder for '=='" "T1" "eq" + $ \(eqAction:_) -> do + executeCodeAction eqAction + , glodenTest "Creates a placeholder for '/='" "T1" "ne" + $ \(_:neAction:_) -> do + executeCodeAction neAction + , glodenTest "Creates a placeholder for 'fmap'" "T2" "fmap" + $ \(_:_:fmapAction:_) -> do + executeCodeAction fmapAction + , glodenTest "Creates a placeholder for multiple methods 1" "T3" "1" + $ \(mmAction:_) -> do + executeCodeAction mmAction + , glodenTest "Creates a placeholder for multiple methods 2" "T3" "2" + $ \(_:mmAction:_) -> do + executeCodeAction mmAction + ] + +_CACodeAction :: Prism' CAResult CodeAction +_CACodeAction = prism' CACodeAction $ \case + CACodeAction action -> Just action + _ -> Nothing + +classPath :: FilePath +classPath = "test" "testdata" "class" + +glodenTest :: String -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree +glodenTest name fp deco execute + = goldenVsStringDiff name goldenGitDiff (classPath fp <.> deco <.> "expected" <.> "hs") + $ runSession hlsCommand fullCaps classPath + $ do + doc <- openDoc (fp <.> "hs") "haskell" + _ <- waitForDiagnosticsFromSource doc "typecheck" + actions <- concatMap (^.. _CACodeAction) <$> getAllCodeActions doc + execute actions + BS.fromStrict . T.encodeUtf8 <$> getDocumentEdit doc + +goldenGitDiff :: FilePath -> FilePath -> [String] +goldenGitDiff fRef fNew = ["git", "diff", "--no-index", "--text", "--exit-code", fRef, fNew] diff --git a/test/functional/Command.hs b/test/functional/Command.hs new file mode 100644 --- /dev/null +++ b/test/functional/Command.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} +module Command (tests) where + +import Control.Lens hiding (List) +import Control.Monad.IO.Class +import qualified Data.Text as T +import Data.Char +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Types as LSP +import Language.Haskell.LSP.Types.Lens as LSP +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.ExpectedFailure (ignoreTestBecause) + + +--TODO : Response Message no longer has 4 inputs +tests :: TestTree +tests = testGroup "commands" [ + testCase "are prefixed" $ + 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) + liftIO $ do + all f cmds @? "All prefixed" + not (null cmds) @? "Commands aren't empty" + , ignoreTestBecause "Broken: Plugin package doesn't exist" $ + testCase "get de-prefixed" $ + runSession hlsCommand fullCaps "test/testdata/" $ do + ResponseMessage _ _ (Left err) <- request + WorkspaceExecuteCommand + (ExecuteCommandParams "1234:package:add" (Just (List [])) Nothing) :: Session ExecuteCommandResponse + let ResponseError _ msg _ = err + -- We expect an error message about the dud arguments, but should pickup "add" and "package" + liftIO $ (msg `T.isInfixOf` "while parsing args for add in plugin package") @? "Has error message" + ] diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs new file mode 100644 --- /dev/null +++ b/test/functional/Completion.hs @@ -0,0 +1,376 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Completion(tests) where + +import Control.Monad.IO.Class +import Control.Lens hiding ((.=)) +import Data.Aeson (object, (.=)) +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Lens hiding (applyEdit) +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.ExpectedFailure (ignoreTestBecause) +import Test.Tasty.HUnit +import qualified Data.Text as T +import System.Time.Extra (sleep) + +tests :: TestTree +tests = testGroup "completions" [ + testCase "works" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "put" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 9) + let item = head $ filter ((== "putStrLn") . (^. label)) compls + liftIO $ do + item ^. label @?= "putStrLn" + item ^. kind @?= Just CiFunction + item ^. detail @?= Just ":: String -> IO ()" + item ^. insertTextFormat @?= Just Snippet + item ^. insertText @?= Just "putStrLn ${1:String}" + + , ignoreTestBecause "no support for itemCompletion/resolve requests" + $ testCase "itemCompletion/resolve works" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "put" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 9) + let item = head $ filter ((== "putStrLn") . (^. label)) compls + resolvedRes <- request CompletionItemResolve item + let Right (resolved :: CompletionItem) = resolvedRes ^. result + liftIO $ print resolved + liftIO $ do + resolved ^. label @?= "putStrLn" + resolved ^. kind @?= Just CiFunction + resolved ^. detail @?= Just "String -> IO ()\nPrelude" + resolved ^. insertTextFormat @?= Just Snippet + resolved ^. insertText @?= Just "putStrLn ${1:String}" + + , testCase "completes imports" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + liftIO $ sleep 4 + + let te = TextEdit (Range (Position 1 17) (Position 1 26)) "Data.M" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 1 22) + let item = head $ filter ((== "Maybe") . (^. label)) compls + liftIO $ do + item ^. label @?= "Maybe" + item ^. detail @?= Just "Data.Maybe" + item ^. kind @?= Just CiModule + + , testCase "completes qualified imports" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + liftIO $ sleep 4 + + let te = TextEdit (Range (Position 2 17) (Position 1 25)) "Dat" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 1 19) + let item = head $ filter ((== "Data.List") . (^. label)) compls + liftIO $ do + item ^. label @?= "Data.List" + item ^. detail @?= Just "Data.List" + item ^. kind @?= Just CiModule + + , testCase "completes language extensions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + liftIO $ sleep 4 + + let te = TextEdit (Range (Position 0 24) (Position 0 31)) "" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 0 24) + let item = head $ filter ((== "OverloadedStrings") . (^. label)) compls + liftIO $ do + item ^. label @?= "OverloadedStrings" + item ^. kind @?= Just CiKeyword + + , testCase "completes pragmas" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + liftIO $ sleep 4 + + let te = TextEdit (Range (Position 0 4) (Position 0 34)) "" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 0 4) + let item = head $ filter ((== "LANGUAGE") . (^. label)) compls + liftIO $ do + item ^. label @?= "LANGUAGE" + item ^. kind @?= Just CiKeyword + item ^. insertTextFormat @?= Just Snippet + item ^. insertText @?= Just "LANGUAGE ${1:extension} #-}" + + , testCase "completes pragmas no close" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + let te = TextEdit (Range (Position 0 4) (Position 0 24)) "" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 0 4) + let item = head $ filter ((== "LANGUAGE") . (^. label)) compls + liftIO $ do + item ^. label @?= "LANGUAGE" + item ^. kind @?= Just CiKeyword + item ^. insertTextFormat @?= Just Snippet + item ^. insertText @?= Just "LANGUAGE ${1:extension}" + + , testCase "completes options pragma" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + liftIO $ sleep 4 + + let te = TextEdit (Range (Position 0 4) (Position 0 34)) "OPTIONS" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 0 4) + let item = head $ filter ((== "OPTIONS_GHC") . (^. label)) compls + liftIO $ do + item ^. label @?= "OPTIONS_GHC" + item ^. kind @?= Just CiKeyword + item ^. insertTextFormat @?= Just Snippet + item ^. insertText @?= Just "OPTIONS_GHC -${1:option} #-}" + + , testCase "completes ghc options pragma values" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + let te = TextEdit (Range (Position 0 0) (Position 0 0)) "{-# OPTIONS_GHC -Wno-red #-}\n" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 0 24) + let item = head $ filter ((== "Wno-redundant-constraints") . (^. label)) compls + liftIO $ do + item ^. label @?= "Wno-redundant-constraints" + item ^. kind @?= Just CiKeyword + item ^. insertTextFormat @?= Nothing + item ^. insertText @?= Nothing + + , testCase "completes with no prefix" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + compls <- getCompletions doc (Position 5 7) + liftIO $ any ((== "!!") . (^. label)) compls @? "" + + -- See https://github.com/haskell/haskell-ide-engine/issues/903 + , testCase "strips compiler generated stuff from completions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "DupRecFields.hs" "haskell" + + let te = TextEdit (Range (Position 5 0) (Position 5 2)) "acc" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 4) + let item = head $ filter (\c -> c^.label == "accessor") compls + liftIO $ do + item ^. label @?= "accessor" + item ^. kind @?= Just CiFunction + + , testCase "have implicit foralls on basic polymorphic types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + let te = TextEdit (Range (Position 5 7) (Position 5 9)) "id" + _ <- applyEdit doc te + compls <- getCompletions doc (Position 5 9) + let item = head $ filter ((== "id") . (^. label)) compls + liftIO $ do + item ^. detail @?= Just ":: a -> a" + + , testCase "have implicit foralls with multiple type variables" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "flip" + _ <- applyEdit doc te + compls <- getCompletions doc (Position 5 11) + let item = head $ filter ((== "flip") . (^. label)) compls + liftIO $ + item ^. detail @?= Just ":: (a -> b -> c) -> b -> a -> c" + + , contextTests + , snippetTests + ] + +snippetTests :: TestTree +snippetTests = testGroup "snippets" [ + testCase "work for argumentless constructors" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "Nothing" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 14) + let item = head $ filter ((== "Nothing") . (^. label)) compls + liftIO $ do + item ^. insertTextFormat @?= Just Snippet + item ^. insertText @?= Just "Nothing " + + , testCase "work for polymorphic types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "fold" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 11) + let item = head $ filter ((== "foldl") . (^. label)) compls + liftIO $ do + item ^. label @?= "foldl" + item ^. kind @?= Just CiFunction + item ^. insertTextFormat @?= Just Snippet + item ^. insertText @?= Just "foldl ${1:b -> a -> b} ${2:b} ${3:t a}" + + , testCase "work for complex types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "mapM" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 11) + let item = head $ filter ((== "mapM") . (^. label)) compls + liftIO $ do + item ^. label @?= "mapM" + item ^. kind @?= Just CiFunction + item ^. insertTextFormat @?= Just Snippet + item ^. insertText @?= Just "mapM ${1:a -> m b} ${2:t a}" + + , testCase "work for infix functions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "even `filte" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 18) + let item = head $ filter ((== "filter") . (^. label)) compls + liftIO $ do + item ^. label @?= "filter" + item ^. kind @?= Just CiFunction + item ^. insertTextFormat @?= Just Snippet + item ^. insertText @?= Just "filter ${1:a -> Bool} ${2:[a]}" + + , testCase "work for infix functions in backticks" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "even `filte`" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 18) + let item = head $ filter ((== "filter") . (^. label)) compls + liftIO $ do + item ^. label @?= "filter" + item ^. kind @?= Just CiFunction + item ^. insertTextFormat @?= Just Snippet + item ^. insertText @?= Just "filter ${1:a -> Bool} ${2:[a]}" + + , testCase "work for qualified infix functions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "\"\" `Data.List.interspe" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 29) + let item = head $ filter ((== "intersperse") . (^. label)) compls + liftIO $ do + item ^. label @?= "intersperse" + item ^. kind @?= Just CiFunction + item ^. insertTextFormat @?= Just Snippet + item ^. insertText @?= Just "intersperse ${1:a} ${2:[a]}" + + , testCase "work for qualified infix functions in backticks" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "\"\" `Data.List.interspe`" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 29) + let item = head $ filter ((== "intersperse") . (^. label)) compls + liftIO $ do + item ^. label @?= "intersperse" + item ^. kind @?= Just CiFunction + item ^. insertTextFormat @?= Just Snippet + item ^. insertText @?= Just "intersperse ${1:a} ${2:[a]}" + + , ignoreTestBecause "ghcide does not support the completionSnippetsOn option" $ + testCase "respects lsp configuration" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + let config = object [ "haskell" .= (object ["completionSnippetsOn" .= False])] + + sendNotification WorkspaceDidChangeConfiguration + (DidChangeConfigurationParams config) + + checkNoSnippets doc + + , testCase "respects client capabilities" $ runSession hlsCommand noSnippetsCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + checkNoSnippets doc + ] + where + checkNoSnippets doc = do + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "fold" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 11) + let item = head $ filter ((== "foldl") . (^. label)) compls + liftIO $ do + item ^. label @?= "foldl" + item ^. kind @?= Just CiFunction + item ^. insertTextFormat @?= Just PlainText + item ^. insertText @?= Nothing + + noSnippetsCaps = + ( textDocument + . _Just + . completion + . _Just + . completionItem + . _Just + . snippetSupport + ?~ False + ) + fullCaps + +contextTests :: TestTree +contextTests = testGroup "contexts" [ + testCase "only provides type suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Context.hs" "haskell" + + compls <- getCompletions doc (Position 2 17) + liftIO $ do + compls `shouldContainCompl` "Integer" + compls `shouldNotContainCompl` "interact" + + , testCase "only provides value suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Context.hs" "haskell" + + compls <- getCompletions doc (Position 3 9) + liftIO $ do + compls `shouldContainCompl` "abs" + compls `shouldNotContainCompl` "Applicative" + + , testCase "completes qualified type suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Context.hs" "haskell" + + compls <- getCompletions doc (Position 2 26) + liftIO $ do + compls `shouldNotContainCompl` "forkOn" + compls `shouldContainCompl` "MVar" + compls `shouldContainCompl` "Chan" + ] + +shouldContainCompl :: [CompletionItem] -> T.Text -> Assertion +compls `shouldContainCompl` x = + any ((== x) . (^. label)) compls + @? "Should contain completion: " ++ show x + +shouldNotContainCompl :: [CompletionItem] -> T.Text -> Assertion +compls `shouldNotContainCompl` x = + all ((/= x) . (^. label)) compls + @? "Should not contain completion: " ++ show x diff --git a/test/functional/Config.hs b/test/functional/Config.hs new file mode 100644 --- /dev/null +++ b/test/functional/Config.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Config (tests) where + +import Control.Lens hiding (List) +import Control.Monad.IO.Class +import Data.Aeson +import Data.Default +import qualified Data.Map as Map +import qualified Data.Text as T +import Ide.Plugin.Config +import Language.Haskell.LSP.Test as Test +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types.Lens as L +import System.FilePath (()) +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.HUnit + +{-# ANN module ("HLint: ignore Reduce duplication"::String) #-} + +tests :: TestTree +tests = testGroup "plugin config" [ + -- Note: because the flag is treated generically in the plugin handler, we + -- do not have to test each individual plugin + hlintTests + ] + +hlintTests :: TestTree +hlintTests = testGroup "hlint plugin enables" [ + + testCase "changing hlintOn configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do + let config = def { hlintOn = True } + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + + doc <- openDoc "ApplyRefact2.hs" "haskell" + testHlintDiagnostics doc + + let config' = def { hlintOn = False } + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) + + diags' <- waitForDiagnosticsFrom doc + + liftIO $ noHlintDiagnostics diags' + + , testCase "changing hlint plugin configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do + let config = def { hlintOn = True } + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + + doc <- openDoc "ApplyRefact2.hs" "haskell" + testHlintDiagnostics doc + + let config' = pluginGlobalOn config "hlint" False + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) + + diags' <- waitForDiagnosticsFrom doc + + liftIO $ noHlintDiagnostics diags' + + ] + where + runHlintSession :: FilePath -> Session a -> IO a + runHlintSession subdir = + failIfSessionTimeout . runSession hlsCommand fullCaps ("test/testdata/hlint" subdir) + + noHlintDiagnostics :: [Diagnostic] -> Assertion + noHlintDiagnostics diags = + Just "hlint" `notElem` map (^. L.source) diags @? "There are no hlint diagnostics" + + testHlintDiagnostics doc = do + diags <- waitForDiagnosticsFromSource doc "hlint" + liftIO $ length diags > 0 @? "There are hlint diagnostics" + +pluginGlobalOn :: Config -> T.Text -> Bool -> Config +pluginGlobalOn config pid state = config' + where + pluginConfig = def { plcGlobalOn = state } + config' = def { plugins = Map.insert pid pluginConfig (plugins config) } diff --git a/test/functional/Deferred.hs b/test/functional/Deferred.hs new file mode 100644 --- /dev/null +++ b/test/functional/Deferred.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +module Deferred(tests) where + +import Control.Applicative.Combinators +import Control.Monad.IO.Class +import Control.Lens hiding (List) +-- import Control.Monad +-- import Data.Maybe +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Lens hiding (id, message) +-- import qualified Language.Haskell.LSP.Types.Lens as LSP +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.ExpectedFailure (ignoreTestBecause) +import Test.Tasty.HUnit + + +tests :: TestTree +tests = testGroup "deferred responses" [ + + --TODO: DOes not compile + -- 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) + + -- skipMany anyNotification + -- hoverRsp <- message :: Session HoverResponse + -- liftIO $ hoverRsp ^? result . _Just . _Just . contents @?= Nothing + -- liftIO $ hoverRsp ^. LSP.id @?= responseId id1 + + -- id2 <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) + -- symbolsRsp <- skipManyTill anyNotification message :: Session DocumentSymbolsResponse + -- liftIO $ symbolsRsp ^. LSP.id @?= responseId id2 + + -- id3 <- sendRequest TextDocumentHover (TextDocumentPositionParams doc (Position 4 2) Nothing) + -- hoverRsp2 <- skipManyTill anyNotification message :: Session HoverResponse + -- liftIO $ hoverRsp2 ^. LSP.id @?= responseId id3 + + -- let contents2 = hoverRsp2 ^? result . _Just . _Just . contents + -- liftIO $ contents2 `shouldNotSatisfy` null + + -- -- Now that we have cache the following request should be instant + -- let highlightParams = TextDocumentPositionParams doc (Position 7 0) Nothing + -- highlightRsp <- request TextDocumentDocumentHighlight highlightParams + -- let (Just (List locations)) = highlightRsp ^. result + -- liftIO $ locations @?= [ DocumentHighlight + -- { _range = Range + -- { _start = Position {_line = 7, _character = 0} + -- , _end = Position {_line = 7, _character = 2} + -- } + -- , _kind = Just HkWrite + -- } + -- , DocumentHighlight + -- { _range = Range + -- { _start = Position {_line = 7, _character = 0} + -- , _end = Position {_line = 7, _character = 2} + -- } + -- , _kind = Just HkWrite + -- } + -- , DocumentHighlight + -- { _range = Range + -- { _start = Position {_line = 5, _character = 6} + -- , _end = Position {_line = 5, _character = 8} + -- } + -- , _kind = Just HkRead + -- } + -- , DocumentHighlight + -- { _range = Range + -- { _start = Position {_line = 7, _character = 0} + -- , _end = Position {_line = 7, _character = 2} + -- } + -- , _kind = Just HkWrite + -- } + -- , DocumentHighlight + -- { _range = Range + -- { _start = Position {_line = 7, _character = 0} + -- , _end = Position {_line = 7, _character = 2} + -- } + -- , _kind = Just HkWrite + -- } + -- , DocumentHighlight + -- { _range = Range + -- { _start = Position {_line = 5, _character = 6} + -- , _end = Position {_line = 5, _character = 8} + -- } + -- , _kind = Just HkRead + -- } + -- ] + + 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 @?= [] + + -- TODO: the benefits of caching parsed modules is doubted. + -- TODO: add issue link + -- , testCase "respond to untypecheckable modules with parsed module cache" $ + -- 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 hlsCommand fullCaps "test/testdata" $ do + -- _ <- openDoc "FuncTest.hs" "haskell" + + -- cwd <- liftIO getCurrentDirectory + -- let testUri = filePathToUri $ cwd "test/testdata/FuncTest.hs" + + -- diags <- skipManyTill loggingNotification publishDiagnosticsNotification + -- liftIO $ diags ^? params @?= (Just $ PublishDiagnosticsParams + -- { _uri = testUri + -- , _diagnostics = List + -- [ Diagnostic + -- (Range (Position 9 6) (Position 10 18)) + -- (Just DsInfo) + -- (Just (StringValue "Redundant do")) + -- (Just "hlint") + -- "Redundant do\nFound:\n do putStrLn \"hello\"\nWhy not:\n putStrLn \"hello\"\n" + -- Nothing + -- ] + -- } + -- ) + -- let args' = H.fromList [("pos", toJSON (Position 7 0)), ("file", toJSON testUri)] + -- args = List [Object args'] + -- + -- executeRsp <- request WorkspaceExecuteCommand (ExecuteCommandParams "hare:demote" (Just args) Nothing) + -- liftIO $ executeRsp ^. result @?= Just (Object H.empty) + + -- editReq <- message :: Session ApplyWorkspaceEditRequest + -- let expectedTextEdits = List [TextEdit (Range (Position 6 0) (Position 7 6)) " where\n bb = 5"] + -- expectedTextDocEdits = List [TextDocumentEdit (VersionedTextDocumentIdentifier testUri (Just 0)) expectedTextEdits] + -- liftIO $ editReq ^. params . edit @?= WorkspaceEdit + -- Nothing + -- (Just expectedTextDocEdits) + -- , multiServerTests + , multiMainTests + ] + +--TODO: Does not compile +-- multiServerTests :: TestTree +-- multiServerTests = testGroup "multi-server setup" [ +-- testCase "doesn't have clashing commands on two servers" $ do +-- let getCommands = runSession hlsCommand fullCaps "test/testdata" $ do +-- rsp <- initializeResponse +-- let uuids = rsp ^? result . _Just . capabilities . executeCommandProvider . _Just . commands +-- return $ fromJust uuids +-- List uuids1 <- getCommands +-- List uuids2 <- getCommands +-- liftIO $ forM_ (zip uuids1 uuids2) (uncurry shouldNotBe) +-- ] + +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 hlsCommand fullCaps "test/testdata" $ do + _doc <- openDoc "ApplyRefact2.hs" "haskell" + _diagsRspHlint <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification + diagsRspGhc <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification + let (List diags) = diagsRspGhc ^. params . diagnostics + + liftIO $ length diags @?= 2 + + _doc2 <- openDoc "HaReRename.hs" "haskell" + _diagsRspHlint2 <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification + -- errMsg <- skipManyTill anyNotification notification :: Session ShowMessageNotification + diagsRsp2 <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification + let (List diags2) = diagsRsp2 ^. params . diagnostics + + liftIO $ show diags2 @?= "[]" + ] diff --git a/test/functional/Definition.hs b/test/functional/Definition.hs new file mode 100644 --- /dev/null +++ b/test/functional/Definition.hs @@ -0,0 +1,69 @@ +module Definition (tests) where + +import Control.Lens +import Control.Monad.IO.Class +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Lens +import System.Directory +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.ExpectedFailure (ignoreTestBecause) +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "definitions" [ + + ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/References.hs" $ + 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) + liftIO $ defs @?= [Location (doc ^. uri) expRange] + + -- ----------------------------------- + + , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ + 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 + fp <- canonicalizePath "test/testdata/definition/Bar.hs" + defs @?= [Location (filePathToUri fp) zeroRange] + + , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ + 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 + fp <- canonicalizePath "test/testdata/definition/Bar.hs" + 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 hlsCommand fullCaps "test/testdata/definition" $ do + doc <- openDoc "Foo.hs" "haskell" + _ <- openDoc "Bar.hs" "haskell" + defs <- getDefinitions doc (Position 2 8) + liftIO $ do + fp <- canonicalizePath "test/testdata/definition/Bar.hs" + 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, and then closed" $ + runSession hlsCommand fullCaps "test/testdata/definition" $ do + doc <- openDoc "Foo.hs" "haskell" + otherDoc <- openDoc "Bar.hs" "haskell" + closeDoc otherDoc + defs <- getDefinitions doc (Position 2 8) + _ <- waitForDiagnostics + liftIO $ putStrLn "D" + liftIO $ do + fp <- canonicalizePath "test/testdata/definition/Bar.hs" + defs @?= [Location (filePathToUri fp) zeroRange] + liftIO $ putStrLn "E" -- AZ + + noDiagnostics + ] + +zeroRange :: Range +zeroRange = Range (Position 0 0) (Position 0 0) diff --git a/test/functional/Diagnostic.hs b/test/functional/Diagnostic.hs new file mode 100644 --- /dev/null +++ b/test/functional/Diagnostic.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Diagnostic (tests) where + +import Control.Applicative.Combinators +import Control.Lens hiding (List) +import Control.Monad.IO.Class +import Data.Aeson (toJSON) +import qualified Data.Text as T +import qualified Data.Default +import Ide.Logger +import Ide.Plugin.Config +import Language.Haskell.LSP.Test hiding (message) +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types.Lens as LSP +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.ExpectedFailure (ignoreTestBecause) +import Test.Tasty.HUnit + +-- --------------------------------------------------------------------- + +tests :: TestTree +tests = testGroup "diagnostics providers" [ + saveTests + , triggerTests + , errorTests + , warningTests + ] + + +triggerTests :: TestTree +triggerTests = testGroup "diagnostics triggers" [ + ignoreTestBecause "Broken" $ + ignoreTestBecause "Broken" $ testCase "runs diagnostics on save" $ + runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do + logm "starting DiagnosticSpec.runs diagnostic on save" + doc <- openDoc "ApplyRefact2.hs" "haskell" + + diags@(reduceDiag:_) <- waitForDiagnostics + + liftIO $ do + length diags @?= 2 + reduceDiag ^. LSP.range @?= Range (Position 1 0) (Position 1 12) + reduceDiag ^. LSP.severity @?= Just DsInfo + reduceDiag ^. LSP.code @?= Just (StringValue "Eta reduce") + reduceDiag ^. LSP.source @?= Just "hlint" + + diags2a <- waitForDiagnostics + + liftIO $ length diags2a @?= 2 + + sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) + + diags3@(d:_) <- waitForDiagnosticsSource "eg2" + + liftIO $ do + length diags3 @?= 1 + d ^. LSP.range @?= Range (Position 0 0) (Position 1 0) + d ^. LSP.severity @?= Nothing + d ^. LSP.code @?= Nothing + d ^. LSP.message @?= T.pack "Example plugin diagnostic, triggered byDiagnosticOnSave" + ] + +errorTests :: TestTree +errorTests = testGroup "typed hole errors" [ + ignoreTestBecause "Broken" $ testCase "is deferred" $ + runSession hlsCommand fullCaps "test/testdata" $ do + _ <- openDoc "TypedHoles.hs" "haskell" + [diag] <- waitForDiagnosticsSource "bios" + liftIO $ diag ^. LSP.severity @?= Just DsWarning + ] + +warningTests :: TestTree +warningTests = testGroup "Warnings are warnings" [ + ignoreTestBecause "Broken" $ testCase "Overrides -Werror" $ + runSession hlsCommand fullCaps "test/testdata/wErrorTest" $ do + _ <- openDoc "src/WError.hs" "haskell" + [diag] <- waitForDiagnosticsSource "bios" + liftIO $ diag ^. LSP.severity @?= Just DsWarning + ] + +saveTests :: TestTree +saveTests = testGroup "only diagnostics on save" [ + ignoreTestBecause "Broken" $ testCase "Respects diagnosticsOnChange setting" $ + runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do + let config = Data.Default.def { diagnosticsOnChange = False } :: Config + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + doc <- openDoc "Hover.hs" "haskell" + diags <- waitForDiagnostics + + liftIO $ do + length diags @?= 0 + + let te = TextEdit (Range (Position 0 0) (Position 0 13)) "" + _ <- applyEdit doc te + skipManyTill loggingNotification noDiagnostics + + sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) + diags2 <- waitForDiagnostics + liftIO $ + length diags2 @?= 1 + ] diff --git a/test/functional/Format.hs b/test/functional/Format.hs new file mode 100644 --- /dev/null +++ b/test/functional/Format.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE OverloadedStrings, CPP #-} +module Format (tests) where + +import Control.Monad.IO.Class +import Data.Aeson +import qualified Data.ByteString.Lazy as BS +import qualified Data.Text.Encoding as T +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Types +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.Golden +import Test.Tasty.HUnit + +#if AGPL +import qualified Data.Text.IO as T +#endif + +tests :: TestTree +tests = testGroup "format document" [ + goldenVsStringDiff "works" goldenGitDiff "test/testdata/format/Format.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ 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/Format.formatted_document_with_tabsize.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do + doc <- openDoc "Format.hs" "haskell" + formatDoc doc (FormattingOptions 5 True) + BS.fromStrict . T.encodeUtf8 <$> documentContents doc + , rangeTests + , providerTests + , stylishHaskellTests +#if AGPL + , brittanyTests +#endif + , ormoluTests + , fourmoluTests + ] + +rangeTests :: TestTree +rangeTests = testGroup "format range" [ + goldenVsStringDiff "works" goldenGitDiff "test/testdata/format/Format.formatted_range.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ 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/Format.formatted_range_with_tabsize.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do + doc <- openDoc "Format.hs" "haskell" + formatRange doc (FormattingOptions 5 True) (Range (Position 8 0) (Position 11 19)) + BS.fromStrict . T.encodeUtf8 <$> documentContents doc + ] + +providerTests :: TestTree +providerTests = testGroup "formatting provider" [ + testCase "respects none" $ runSessionWithConfig (formatConfig "none") hlsCommand fullCaps "test/testdata/format" $ do + doc <- openDoc "Format.hs" "haskell" + orig <- documentContents doc + + formatDoc doc (FormattingOptions 2 True) + documentContents doc >>= liftIO . (@?= orig) + + formatRange doc (FormattingOptions 2 True) (Range (Position 1 0) (Position 3 10)) + documentContents doc >>= liftIO . (@?= orig) + +#if AGPL + , testCase "can change on the fly" $ runSession hlsCommand fullCaps "test/testdata/format" $ do + formattedBrittany <- liftIO $ T.readFile "test/testdata/format/Format.brittany.formatted.hs" + formattedFloskell <- liftIO $ T.readFile "test/testdata/format/Format.floskell.formatted.hs" + formattedBrittanyPostFloskell <- liftIO $ T.readFile "test/testdata/format/Format.brittany_post_floskell.formatted.hs" + + doc <- openDoc "Format.hs" "haskell" + + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) + formatDoc doc (FormattingOptions 2 True) + documentContents doc >>= liftIO . (@?= formattedBrittany) + + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "floskell")) + formatDoc doc (FormattingOptions 2 True) + documentContents doc >>= liftIO . (@?= formattedFloskell) + + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) + formatDoc doc (FormattingOptions 2 True) + documentContents doc >>= liftIO . (@?= formattedBrittanyPostFloskell) + , testCase "supports both new and old configuration sections" $ runSession hlsCommand fullCaps "test/testdata/format" $ do + formattedBrittany <- liftIO $ T.readFile "test/testdata/format/Format.brittany.formatted.hs" + formattedFloskell <- liftIO $ T.readFile "test/testdata/format/Format.floskell.formatted.hs" + + doc <- openDoc "Format.hs" "haskell" + + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfigOld "brittany")) + formatDoc doc (FormattingOptions 2 True) + documentContents doc >>= liftIO . (@?= formattedBrittany) + + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfigOld "floskell")) + formatDoc doc (FormattingOptions 2 True) + documentContents doc >>= liftIO . (@?= formattedFloskell) +#endif + ] + +stylishHaskellTests :: TestTree +stylishHaskellTests = testGroup "stylish-haskell" [ + goldenVsStringDiff "formats a document" goldenGitDiff "test/testdata/format/StylishHaskell.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ 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/format/StylishHaskell.formatted_range.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "stylish-haskell")) + doc <- openDoc "StylishHaskell.hs" "haskell" + formatRange doc (FormattingOptions 2 True) (Range (Position 0 0) (Position 2 21)) + BS.fromStrict . T.encodeUtf8 <$> documentContents doc + ] + +#if AGPL +brittanyTests :: TestTree +brittanyTests = testGroup "brittany" [ + goldenVsStringDiff "formats a document with LF endings" goldenGitDiff "test/testdata/format/BrittanyLF.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ 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/format/BrittanyCRLF.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ 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/format/BrittanyLF.formatted_range.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ 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/format/BrittanyCRLF.formatted_range.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) + doc <- openDoc "BrittanyCRLF.hs" "haskell" + let range = Range (Position 1 0) (Position 2 22) + formatRange doc (FormattingOptions 4 True) range + BS.fromStrict . T.encodeUtf8 <$> documentContents doc + ] +#endif + +ormoluTests :: TestTree +ormoluTests = testGroup "ormolu" + [ goldenVsStringDiff "formats correctly" goldenGitDiff "test/testdata/format/Format.ormolu.formatted.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ 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/format/Format2.ormolu.formatted.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) + doc <- openDoc "Format2.hs" "haskell" + formatDoc doc (FormattingOptions 2 True) + BS.fromStrict . T.encodeUtf8 <$> documentContents doc + ] + +fourmoluTests :: TestTree +fourmoluTests = testGroup "fourmolu" + [ goldenVsStringDiff "formats correctly" goldenGitDiff "test/testdata/format/Format.fourmolu.formatted.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ 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/format/Format2.fourmolu.formatted.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) + doc <- openDoc "Format2.hs" "haskell" + formatDoc doc (FormattingOptions 4 True) + BS.fromStrict . T.encodeUtf8 <$> documentContents doc + ] + +formatLspConfig :: Value -> Value +formatLspConfig provider = object [ "haskell" .= object ["formattingProvider" .= (provider :: Value)] ] + +#if AGPL +-- | The same as 'formatLspConfig' but using the legacy section name +formatLspConfigOld :: Value -> Value +formatLspConfigOld provider = object [ "languageServerHaskell" .= object ["formattingProvider" .= (provider :: Value)] ] +#endif + +formatConfig :: Value -> SessionConfig +formatConfig provider = defaultConfig { lspConfig = Just (formatLspConfig provider) } + +goldenGitDiff :: FilePath -> FilePath -> [String] +goldenGitDiff fRef fNew = ["git", "diff", "--no-index", "--text", "--exit-code", fRef, fNew] diff --git a/test/functional/FunctionalBadProject.hs b/test/functional/FunctionalBadProject.hs new file mode 100644 --- /dev/null +++ b/test/functional/FunctionalBadProject.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} + +module FunctionalBadProject (tests) where + +-- import Control.Lens hiding (List) +-- import Control.Monad.IO.Class +-- import qualified Data.Text as T +-- import Language.Haskell.LSP.Test hiding (message) +-- import Language.Haskell.LSP.Types as LSP +-- import Language.Haskell.LSP.Types.Lens as LSP hiding (contents, error ) +-- import Test.Hls.Util +import Test.Tasty +import Test.Tasty.HUnit + +-- --------------------------------------------------------------------- +-- TODO: Currently this can not succeed, since such an error is thrown in "runActionWithContext" which +-- can produce diagnostics at the moment. Needs more investigation +-- TODO: @fendor: Add issue link here +-- +tests :: TestTree +tests = testGroup "behaviour on malformed projects" [ + testCase "no test executed" $ True @?= True + ] + + -- testCase "deals with cabal file with unsatisfiable dependency" $ + -- runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata/badProjects/cabal" $ do + -- -- runSessionWithConfig logConfig hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do + -- _doc <- openDoc "Foo.hs" "haskell" + + -- diags@(d:_) <- waitForDiagnosticsSource "bios" + -- -- liftIO $ show diags @?= "" + -- -- liftIO $ putStrLn $ show diags + -- -- liftIO $ putStrLn "a" + -- liftIO $ do + -- length diags @?= 1 + -- d ^. range @?= Range (Position 0 0) (Position 1 0) + -- d ^. severity @?= (Just DsError) + -- d ^. code @?= Nothing + -- d ^. source @?= Just "bios" + -- d ^. message @?= + -- (T.pack "readCreateProcess: stack \"build\" \"--only-configure\" \".\" (exit 1): failed\n") diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs new file mode 100644 --- /dev/null +++ b/test/functional/FunctionalCodeAction.hs @@ -0,0 +1,494 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module FunctionalCodeAction (tests) where + +import Control.Applicative.Combinators +import Control.Lens hiding (List) +import Control.Monad +import Control.Monad.IO.Class +import Data.Aeson +import Data.Default +import qualified Data.HashMap.Strict as HM +import Data.List +import Data.Maybe +import qualified Data.Text as T +import Ide.Plugin.Config +import Language.Haskell.LSP.Test as Test +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types.Lens as L +import qualified Language.Haskell.LSP.Types.Capabilities as C +import Test.Hls.Util +import Test.Hspec.Expectations + +import Test.Tasty +import Test.Tasty.ExpectedFailure (ignoreTestBecause, expectFailBecause) +import Test.Tasty.HUnit +import System.FilePath (()) + +{-# ANN module ("HLint: ignore Reduce duplication"::String) #-} + +tests :: TestTree +tests = testGroup "code actions" [ + hlintTests + , importTests + , missingPragmaTests + , packageTests + , redundantImportTests + , renameTests + , signatureTests + , typedHoleTests + , unusedTermTests + ] + + +hlintTests :: TestTree +hlintTests = testGroup "hlint suggestions" [ + testCase "provides 3.8 code actions including apply all" $ runHlintSession "" $ do + doc <- openDoc "ApplyRefact2.hs" "haskell" + diags@(reduceDiag:_) <- waitForDiagnosticsFromSource doc "hlint" + + liftIO $ do + 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 "refact:Eta reduce") + reduceDiag ^. L.source @?= Just "hlint" + + cas <- map fromAction <$> getAllCodeActions doc + + 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 + + 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 <- skipManyTill anyMessage $ getDocumentEdit doc + liftIO $ contents @?= "main = undefined\nfoo x = x\n" + + , testCase "falls back to pre 3.8 code actions" $ runSession hlsCommand noLiteralCaps "test/testdata/hlint" $ do + doc <- openDoc "ApplyRefact2.hs" "haskell" + + _ <- waitForDiagnosticsFromSource doc "hlint" + + cars <- getAllCodeActions doc + etaReduce <- liftIO $ inspectCommand cars ["Eta reduce"] + + executeCommand etaReduce + + contents <- skipManyTill anyMessage $ getDocumentEdit doc + liftIO $ contents @?= "main = undefined\nfoo = id\n" + + , knownBrokenForGhcVersions [GHC88, GHC86] "hlint doesn't take in account cpp flag as ghc -D argument" $ + testCase "hlint diagnostics works with CPP via ghc -XCPP argument (#554)" $ runHlintSession "cpp" $ do + doc <- openDoc "ApplyRefact3.hs" "haskell" + testHlintDiagnostics doc + + , knownBrokenForGhcVersions [GHC88, GHC86] "hlint doesn't take in account cpp flag as ghc -D argument" $ + testCase "hlint diagnostics works with CPP via language pragma (#554)" $ runHlintSession "" $ do + doc <- openDoc "ApplyRefact3.hs" "haskell" + testHlintDiagnostics doc + + , testCase "hlint diagnostics works with CPP via -XCPP argument and flag via #include header (#554)" $ runHlintSession "cpp" $ do + doc <- openDoc "ApplyRefact2.hs" "haskell" + testHlintDiagnostics doc + + , knownBrokenForGhcVersions [GHC88, GHC86] "apply-refact doesn't take in account the -X argument" $ + testCase "apply-refact works with LambdaCase via ghc -XLambdaCase argument (#590)" $ runHlintSession "lambdacase" $ do + testRefactor "ApplyRefact1.hs" "Redundant bracket" + expectedLambdaCase + + , testCase "apply hints works with LambdaCase via language pragma" $ runHlintSession "" $ do + testRefactor "ApplyRefact1.hs" "Redundant bracket" + ("{-# LANGUAGE LambdaCase #-}" : expectedLambdaCase) + + , expectFailBecause "apply-refact doesn't work with cpp" $ + testCase "apply hints works with CPP via -XCPP argument" $ runHlintSession "cpp" $ do + testRefactor "ApplyRefact3.hs" "Redundant bracket" + expectedCPP + + , expectFailBecause "apply-refact doesn't work with cpp" $ + testCase "apply hints works with CPP via language pragma" $ runHlintSession "" $ do + testRefactor "ApplyRefact3.hs" "Redundant bracket" + ("{-# LANGUAGE CPP #-}" : expectedCPP) + + , testCase "hlint diagnostics ignore hints honouring .hlint.yaml" $ runHlintSession "ignore" $ do + doc <- openDoc "ApplyRefact.hs" "haskell" + expectNoMoreDiagnostics 3 doc "hlint" + + , testCase "hlint diagnostics ignore hints honouring ANN annotations" $ runHlintSession "" $ do + doc <- openDoc "ApplyRefact4.hs" "haskell" + expectNoMoreDiagnostics 3 doc "hlint" + + , knownBrokenForGhcVersions [GHC810] "hlint plugin doesn't honour HLINT annotations (#838)" $ + testCase "hlint diagnostics ignore hints honouring HLINT annotations" $ runHlintSession "" $ do + doc <- openDoc "ApplyRefact5.hs" "haskell" + expectNoMoreDiagnostics 3 doc "hlint" + ] + where + runHlintSession :: FilePath -> Session a -> IO a + runHlintSession subdir = + failIfSessionTimeout . runSession hlsCommand fullCaps ("test/testdata/hlint" subdir) + + testHlintDiagnostics doc = do + diags <- waitForDiagnosticsFromSource doc "hlint" + liftIO $ length diags > 0 @? "There are hlint diagnostics" + + testRefactor file caTitle expected = do + doc <- openDoc file "haskell" + testHlintDiagnostics doc + + cas <- map fromAction <$> getAllCodeActions doc + let ca = find (\ca -> caTitle `T.isSuffixOf` (ca ^. L.title)) cas + liftIO $ isJust ca @? ("There is '" ++ T.unpack caTitle ++"' code action") + + executeCodeAction (fromJust ca) + + contents <- getDocumentEdit doc + liftIO $ contents @?= T.unlines expected + + expectedLambdaCase = [ "module ApplyRefact1 where", "" + , "f = \\case \"true\" -> True" + , " _ -> False" + ] + expectedCPP = [ "module ApplyRefact3 where", "" + , "#ifdef FLAG" + , "f = 1" + , "#else" + , "g = 2" + , "#endif", "" + ] + +renameTests :: TestTree +renameTests = testGroup "rename suggestions" [ + testCase "works" $ runSession hlsCommand noLiteralCaps "test/testdata" $ do + doc <- openDoc "CodeActionRename.hs" "haskell" + + _ <- waitForDiagnosticsFromSource doc "typecheck" + + cars <- getAllCodeActions doc + replaceButStrLn <- liftIO $ inspectCommand cars ["Replace with", "putStrLn"] + executeCommand replaceButStrLn + + x:_ <- T.lines <$> documentContents doc + liftIO $ x @?= "main = putStrLn \"hello\"" + + , testCase "doesn't give both documentChanges and changes" + $ runSession hlsCommand noLiteralCaps "test/testdata" $ do + doc <- openDoc "CodeActionRename.hs" "haskell" + + _ <- waitForDiagnosticsFromSource doc "typecheck" + + cars <- getAllCodeActions doc + cmd <- liftIO $ inspectCommand cars ["Replace with", "putStrLn"] + let Just (List [Object args]) = cmd ^. L.arguments + Object editParams = args HM.! "fallbackWorkspaceEdit" + liftIO $ do + "changes" `HM.member` editParams @? "Contains changes" + not ("documentChanges" `HM.member` editParams) @? "Doesn't contain documentChanges" + + executeCommand cmd + + x1:x2:_ <- T.lines <$> documentContents doc + liftIO $ + x1 == "main = putStrLn \"hello\"" + || x2 == "foo = putStrLn \"world\"" + @? "One of the typos got fixed" + ] + +importTests :: TestTree +importTests = testGroup "import suggestions" [ + 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" } + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + + (diag:_) <- waitForDiagnosticsFrom doc + liftIO $ diag ^. L.message @?= "Variable not in scope: when :: Bool -> IO () -> IO ()" + + actionsOrCommands <- getAllCodeActions doc + let actns = map fromAction actionsOrCommands + + importControlMonad <- liftIO $ inspectCodeAction actionsOrCommands ["import Control.Monad"] + liftIO $ do + expectCodeAction actionsOrCommands ["import Control.Monad (when)"] + forM_ actns $ \a -> do + a ^. L.kind @?= Just CodeActionQuickFix + length actns >= 10 @? "There are some actions" + + executeCodeAction importControlMonad + + contents <- documentContents doc + liftIO $ contents @?= "import Control.Monad\nmain :: IO ()\nmain = when True $ putStrLn \"hello\"" + ] + +packageTests :: TestTree +packageTests = testGroup "add package suggestions" [ + ignoreTestBecause "no support for adding dependent packages via code action" $ testCase "adds to .cabal files" $ do + flushStackEnvironment + runSession hlsCommand fullCaps "test/testdata/addPackageTest/cabal-exe" $ do + doc <- openDoc "AddPackage.hs" "haskell" + + -- ignore the first empty hlint diagnostic publish + [_,diag:_] <- count 2 $ waitForDiagnosticsFrom doc + + let prefixes = [ "Could not load module `Data.Text'" -- Windows && GHC >= 8.6 + , "Could not find module `Data.Text'" -- Windows + , "Could not load module ‘Data.Text’" -- GHC >= 8.6 + , "Could not find module ‘Data.Text’" + ] + in liftIO $ any (`T.isPrefixOf` (diag ^. L.message)) prefixes @? "Contains prefix" + + acts <- getAllCodeActions doc + let (CACodeAction action:_) = acts + + liftIO $ do + action ^. L.title @?= "Add text as a dependency" + action ^. L.kind @?= Just CodeActionQuickFix + "package:add" `T.isSuffixOf` (action ^. L.command . _Just . L.command) @? "Command contains package:add" + + executeCodeAction action + + contents <- skipManyTill anyMessage $ getDocumentEdit . TextDocumentIdentifier =<< getDocUri "add-package-test.cabal" + liftIO $ + any (\l -> "text -any" `T.isSuffixOf` l || "text : {} -any" `T.isSuffixOf` l) (T.lines contents) @? "Contains text package" + + , ignoreTestBecause "no support for adding dependent packages via code action" $ testCase "adds to hpack package.yaml files" $ + runSession hlsCommand fullCaps "test/testdata/addPackageTest/hpack-exe" $ do + doc <- openDoc "app/Asdf.hs" "haskell" + + -- ignore the first empty hlint diagnostic publish + [_,_:diag:_] <- count 2 $ waitForDiagnosticsFrom doc + + let prefixes = [ "Could not load module `Codec.Compression.GZip'" -- Windows && GHC >= 8.6 + , "Could not find module `Codec.Compression.GZip'" -- Windows + , "Could not load module ‘Codec.Compression.GZip’" -- GHC >= 8.6 + , "Could not find module ‘Codec.Compression.GZip’" + ] + in liftIO $ any (`T.isPrefixOf` (diag ^. L.message)) prefixes @? "Diagnostic contains message" + + mActions <- getAllCodeActions doc + let allActions = map fromAction mActions + action = head allActions + + liftIO $ do + action ^. L.title @?= "Add zlib as a dependency" + forM_ allActions $ \a -> a ^. L.kind @?= Just CodeActionQuickFix + forM_ allActions $ \a -> "package:add" `T.isSuffixOf` (a ^. L.command . _Just . L.command) @? "Command contains package:add" + + executeCodeAction action + + contents <- skipManyTill anyMessage $ getDocumentEdit . TextDocumentIdentifier =<< getDocUri "package.yaml" + liftIO $ do + "zlib" `T.isSuffixOf` (T.lines contents !! 3) @? "Contains zlib" + "zlib" `T.isSuffixOf` (T.lines contents !! 21) @? "Does not contain zlib in unrelated component" + ] + +redundantImportTests :: TestTree +redundantImportTests = testGroup "redundant import code actions" [ + testCase "remove solitary redundant imports" $ + runSession hlsCommand fullCaps "test/testdata/redundantImportTest/" $ do + doc <- openDoc "src/CodeActionRedundant.hs" "haskell" + + diags <- waitForDiagnosticsFromSource doc "typecheck" + liftIO $ expectDiagnostic diags ["The import of", "Data.List", "is redundant"] + + mActions <- getAllCodeActions doc + + let allActions = map fromAction mActions + actionTitles = map (view L.title) allActions + + liftIO $ actionTitles `shouldContain` ["Remove import", "Remove all redundant imports"] + + let Just removeAction = find (\x -> x ^. L.title == "Remove import") allActions + + liftIO $ do + forM_ allActions $ \a -> a ^. L.kind @?= Just CodeActionQuickFix + forM_ allActions $ \a -> a ^. L.command @?= Nothing + forM_ allActions $ \a -> isJust (a ^. L.edit) @? "Has edit" + + executeCodeAction removeAction + + -- No command/applyworkspaceedit should be here, since action + -- provides workspace edit property which skips round trip to + -- the server + contents <- documentContents doc + liftIO $ contents @?= "{-# OPTIONS_GHC -Wunused-imports #-}\nmodule CodeActionRedundant where\nmain :: IO ()\nmain = putStrLn \"hello\"\n" + + , testCase "doesn't touch other imports" $ runSession hlsCommand noLiteralCaps "test/testdata/redundantImportTest/" $ do + doc <- openDoc "src/MultipleImports.hs" "haskell" + _ <- waitForDiagnosticsFromSource doc "typecheck" + CACommand cmd : _ <- getAllCodeActions doc + executeCommand cmd + contents <- documentContents doc + liftIO $ (T.lines contents) @?= + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module MultipleImports where" + , "import Data.Maybe" + , "foo :: Int" + , "foo = fromJust (Just 3)" + ] + ] + +typedHoleTests :: TestTree +typedHoleTests = testGroup "typed hole code actions" [ + testCase "works" $ + runSession hlsCommand fullCaps "test/testdata" $ do + doc <- openDoc "TypedHoles.hs" "haskell" + _ <- waitForDiagnosticsFromSource doc "typecheck" + cas <- getAllCodeActions doc + liftIO $ do + expectCodeAction cas ["replace _ with minBound"] + expectCodeAction cas ["replace _ with foo _"] + replaceWithMaxBound <- liftIO $ inspectCodeAction cas ["replace _ with maxBound"] + + executeCodeAction replaceWithMaxBound + + contents <- documentContents doc + + liftIO $ contents @?= T.concat + [ "module TypedHoles where\n" + , "foo :: [Int] -> Int\n" + , "foo x = maxBound" + ] + + , testCase "shows more suggestions" $ + runSession hlsCommand fullCaps "test/testdata" $ do + doc <- openDoc "TypedHoles2.hs" "haskell" + _ <- waitForDiagnosticsFromSource doc "typecheck" + cas <- getAllCodeActions doc + + liftIO $ do + expectCodeAction cas ["replace _ with foo2 _"] + expectCodeAction cas ["replace _ with A _"] + replaceWithStuff <- liftIO $ inspectCodeAction cas ["replace _ with stuff _"] + + executeCodeAction replaceWithStuff + + contents <- documentContents doc + + liftIO $ T.lines contents @?= + [ "module TypedHoles2 (foo2) where" + , "newtype A = A Int" + , "foo2 :: [A] -> A" + , "foo2 x = (stuff _)" + , " where" + , " stuff (A a) = A (a + 1)" + ] + ] + +signatureTests :: TestTree +signatureTests = testGroup "missing top level signature code actions" [ + testCase "Adds top level signature" $ + runSession hlsCommand fullCaps "test/testdata/" $ do + doc <- openDoc "TopLevelSignature.hs" "haskell" + + _ <- waitForDiagnosticsFromSource doc "typecheck" + cas <- map fromAction <$> getAllCodeActions doc + + liftIO $ "add signature: main :: IO ()" `elem` (map (^. L.title) cas) @? "Contains code action" + + executeCodeAction $ head cas + + contents <- documentContents doc + + let expected = [ "{-# OPTIONS_GHC -Wall #-}" + , "module TopLevelSignature where" + , "main :: IO ()" + , "main = do" + , " putStrLn \"Hello\"" + , " return ()" + ] + + liftIO $ (T.lines contents) @?= expected + ] + +missingPragmaTests :: TestTree +missingPragmaTests = testGroup "missing pragma warning code actions" [ + testCase "Adds TypeSynonymInstances pragma" $ do + runSession hlsCommand fullCaps "test/testdata/addPragmas" $ do + doc <- openDoc "NeedsPragmas.hs" "haskell" + + _ <- waitForDiagnosticsFromSource doc "typecheck" + cas <- map fromAction <$> getAllCodeActions doc + + liftIO $ "Add \"TypeSynonymInstances\"" `elem` map (^. L.title) cas @? "Contains TypeSynonymInstances code action" + liftIO $ "Add \"FlexibleInstances\"" `elem` map (^. L.title) cas @? "Contains FlexibleInstances code action" + + executeCodeAction $ head cas + + contents <- documentContents doc + + let expected = [ "{-# LANGUAGE TypeSynonymInstances #-}" + , "" + , "import GHC.Generics" + , "" + , "main = putStrLn \"hello\"" + , "" + , "type Foo = Int" + , "" + , "instance Show Foo where" + , " show x = undefined" + , "" + , "instance Show (Int,String) where" + , " show = undefined" + , "" + , "data FFF a = FFF Int String a" + , " deriving (Generic,Functor,Traversable)" + ] + + liftIO $ (T.lines contents) @?= expected + ] + +unusedTermTests :: TestTree +unusedTermTests = testGroup "unused term code actions" [ + ignoreTestBecause "no support for prefixing unused names with _" $ testCase "Prefixes with '_'" $ + runSession hlsCommand fullCaps "test/testdata/" $ do + doc <- openDoc "UnusedTerm.hs" "haskell" + + _ <- waitForDiagnosticsFromSource doc "typecheck" + cars <- getAllCodeActions doc + prefixImUnused <- liftIO $ inspectCodeAction cars ["Prefix imUnused with _"] + + executeCodeAction prefixImUnused + + edit <- skipManyTill anyMessage $ getDocumentEdit doc + + let expected = [ "{-# OPTIONS_GHC -Wall #-}" + , "module UnusedTerm () where" + , "_imUnused :: Int -> Int" + , "_imUnused 1 = 1" + , "_imUnused 2 = 2" + , "_imUnused _ = 3" + ] + + liftIO $ edit @?= T.unlines expected + + -- See https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#textDocument_codeAction + -- `CodeActionContext` + , testCase "respect 'only' parameter" $ runSession hlsCommand fullCaps "test/testdata" $ do + doc <- openDoc "CodeActionOnly.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + diags <- getCurrentDiagnostics doc + let params = CodeActionParams doc (Range (Position 2 10) (Position 4 0)) caContext Nothing + caContext = CodeActionContext (List diags) (Just (List [CodeActionRefactorInline])) + ResponseMessage _ _ (Right (List res)) <- request TextDocumentCodeAction params + let cas = map fromAction res + kinds = map (^. L.kind) cas + liftIO $ do + -- TODO: When HaRe is back this should be uncommented + -- kinds `shouldNotSatisfy` null + not (any (Just CodeActionRefactorInline /=) kinds) @? "None not CodeActionRefactorInline" + all (Just CodeActionRefactorInline ==) kinds @? "All CodeActionRefactorInline" + ] + +noLiteralCaps :: C.ClientCapabilities +noLiteralCaps = def { C._textDocument = Just textDocumentCaps } + where + textDocumentCaps = def { C._codeAction = Just codeActionCaps } + codeActionCaps = C.CodeActionClientCapabilities (Just True) Nothing diff --git a/test/functional/FunctionalLiquid.hs b/test/functional/FunctionalLiquid.hs new file mode 100644 --- /dev/null +++ b/test/functional/FunctionalLiquid.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} + +module FunctionalLiquid (tests) where + +import Control.Lens hiding (List) +import Control.Monad.IO.Class +import Data.Aeson +import Data.Default +import qualified Data.Text as T +import Language.Haskell.LSP.Test hiding (message) +import Language.Haskell.LSP.Types as LSP +import Language.Haskell.LSP.Types.Lens as LSP hiding (contents) +import Ide.Plugin.Config +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.ExpectedFailure (ignoreTestBecause) +import Test.Tasty.HUnit + +-- --------------------------------------------------------------------- + +tests :: TestTree +tests = testGroup "liquid haskell diagnostics" [ + ignoreTestBecause "Broken" $ testCase "runs diagnostics on save, no liquid" $ + runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do + doc <- openDoc "liquid/Evens.hs" "haskell" + + diags@(reduceDiag:_) <- waitForDiagnostics + + liftIO $ do + length diags @?= 2 + reduceDiag ^. range @?= Range (Position 5 18) (Position 5 22) + reduceDiag ^. severity @?= Just DsHint + reduceDiag ^. code @?= Just (StringValue "Use negate") + reduceDiag ^. source @?= Just "hlint" + + diags2hlint <- waitForDiagnostics + + liftIO $ length diags2hlint @?= 2 + + sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) + + diags3@(d:_) <- waitForDiagnosticsSource "eg2" + + liftIO $ do + length diags3 @?= 1 + d ^. LSP.range @?= Range (Position 0 0) (Position 1 0) + d ^. LSP.severity @?= Nothing + d ^. LSP.code @?= Nothing + d ^. LSP.message @?= T.pack "Example plugin diagnostic, triggered byDiagnosticOnSave" + + -- --------------------------------- + + , ignoreTestBecause "Broken" $ testCase "runs diagnostics on save, with liquid haskell" $ + runSession hlsCommand codeActionSupportCaps "test/testdata" $ do + -- runSessionWithConfig logConfig hlsCommand codeActionSupportCaps "test/testdata" $ do + doc <- openDoc "liquid/Evens.hs" "haskell" + + diags@(reduceDiag:_) <- waitForDiagnostics + + -- liftIO $ show diags @?= "" + + liftIO $ do + length diags @?= 2 + reduceDiag ^. range @?= Range (Position 5 18) (Position 5 22) + reduceDiag ^. severity @?= Just DsHint + reduceDiag ^. code @?= Just (StringValue "Use negate") + reduceDiag ^. source @?= Just "hlint" + + -- Enable liquid haskell plugin and disable hlint + let config = def { liquidOn = True, hlintOn = False } + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + + -- docItem <- getDocItem file languageId + sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) + -- TODO: what does that test? + -- TODO: whether hlint is really disbabled? + -- TODO: @fendor, document or remove + -- diags2hlint <- waitForDiagnostics + -- -- liftIO $ show diags2hlint @?= "" + + -- -- We turned hlint diagnostics off + -- liftIO $ length diags2hlint @?= 0 + -- diags2liquid <- waitForDiagnostics + -- liftIO $ length diags2liquid @?= 0 + -- liftIO $ show diags2liquid @?= "" + diags3@(d:_) <- waitForDiagnosticsSource "liquid" + -- liftIO $ show diags3 @?= "" + liftIO $ do + length diags3 @?= 1 + d ^. range @?= Range (Position 8 0) (Position 8 11) + d ^. severity @?= Just DsError + d ^. code @?= Nothing + d ^. source @?= Just "liquid" + (d ^. message) `T.isPrefixOf` + ("Error: Liquid Type Mismatch\n" <> + " Inferred type\n" <> + " VV : {v : GHC.Types.Int | v == 7}\n" <> + " \n" <> + " not a subtype of Required type\n" <> + " VV : {VV : GHC.Types.Int | VV mod 2 == 0}\n ") + @? "Contains error message" + ] diff --git a/test/functional/HieBios.hs b/test/functional/HieBios.hs new file mode 100644 --- /dev/null +++ b/test/functional/HieBios.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} +module HieBios (tests) where + +import Control.Applicative.Combinators +import qualified Data.Text as T +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Messages +import System.FilePath (()) +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.ExpectedFailure (ignoreTestBecause) +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "hie-bios" [ + ignoreTestBecause "Broken" $ testCase "loads modules inside main-is" $ do + writeFile (hieBiosErrorPath "hie.yaml") "" + 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 hlsCommand fullCaps hieBiosErrorPath $ do + _ <- openDoc "Foo.hs" "haskell" + _ <- skipManyTill loggingNotification (satisfy isMessage) + return () + ] + where + hieBiosErrorPath = "test/testdata/hieBiosError" + + isMessage (NotShowMessage (NotificationMessage _ _ (ShowMessageParams MtError s))) = + "Couldn't parse hie.yaml" `T.isInfixOf` s + isMessage _ = False diff --git a/test/functional/Highlight.hs b/test/functional/Highlight.hs new file mode 100644 --- /dev/null +++ b/test/functional/Highlight.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} +module Highlight (tests) where + +import Control.Monad.IO.Class +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Types +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "highlight" [ + testCase "works" $ runSession hlsCommand fullCaps "test/testdata" $ do + doc <- openDoc "Highlight.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + highlights <- getHighlights doc (Position 2 2) + liftIO $ do + let hls = + [ DocumentHighlight (mkRange 2 0 2 3) (Just HkWrite) + , DocumentHighlight (mkRange 4 22 4 25) (Just HkRead) + , DocumentHighlight (mkRange 3 6 3 9) (Just HkRead) + , DocumentHighlight (mkRange 1 0 1 3) (Just HkRead)] + mapM_ (\x -> x `elem` highlights @? "Contains highlight") hls + ] + where + mkRange sl sc el ec = Range (Position sl sc) (Position el ec) diff --git a/test/functional/Main.hs b/test/functional/Main.hs new file mode 100644 --- /dev/null +++ b/test/functional/Main.hs @@ -0,0 +1,61 @@ +module Main where + +import Class +import Command +import Completion +import Config +import Deferred +import Definition +import Diagnostic +import Eval +import Format +import FunctionalBadProject +import FunctionalCodeAction +import FunctionalLiquid +import HieBios +import Highlight +import ModuleName +import Progress +import Reference +import Rename +import Symbol +import Tactic +import Test.Tasty +import Test.Tasty.Ingredients.Rerun +import Test.Tasty.Runners ( + consoleTestReporter, + listingTests, + ) +import Test.Tasty.Runners.AntXML +import TypeDefinition + +main :: IO () +main = + -- ingredient: xml runner writes json file of test results (https://github.com/ocharles/tasty-ant-xml/blob/master/Test/Tasty/Runners/AntXML.hs) + -- rerunningTests allow rerun of failed tests (https://github.com/ocharles/tasty-rerun/blob/master/src/Test/Tasty/Ingredients/Rerun.hs) + defaultMainWithIngredients + [antXMLRunner, rerunningTests [listingTests, consoleTestReporter]] + $ testGroup + "haskell-language-server" + [ Class.tests + , Command.tests + , Completion.tests + , Config.tests + , Deferred.tests + , Definition.tests + , Diagnostic.tests + , Eval.tests + , Format.tests + , FunctionalBadProject.tests + , FunctionalCodeAction.tests + , FunctionalLiquid.tests + , HieBios.tests + , Highlight.tests + , ModuleName.tests + , Progress.tests + , Reference.tests + , Rename.tests + , Symbol.tests + , Tactic.tests + , TypeDefinition.tests + ] diff --git a/test/functional/ModuleName.hs b/test/functional/ModuleName.hs new file mode 100644 --- /dev/null +++ b/test/functional/ModuleName.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module ModuleName + ( tests + ) +where + +import Control.Applicative.Combinators (skipManyTill) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.Text.IO as T +import Language.Haskell.LSP.Test (anyMessage, documentContents, + executeCommand, fullCaps, + getCodeLenses, message, + openDoc, runSession) +import Language.Haskell.LSP.Types (ApplyWorkspaceEditRequest, + CodeLens (..)) +import System.FilePath ((<.>), ()) +import Test.Hls.Util (hlsCommand) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +tests :: TestTree +tests = testGroup + "moduleName" + [ testCase "Add module header to empty module" $ goldenTest "TEmptyModule.hs" + , testCase "Fix wrong module name" $ goldenTest "TWrongModuleName.hs" + , testCase "Must infer module name as Main, if the file name starts with a lowercase" $ goldenTest "mainlike.hs" + ] + +goldenTest :: FilePath -> IO () +goldenTest input = runSession hlsCommand fullCaps testdataPath $ do + doc <- openDoc input "haskell" + -- getCodeLenses doc >>= liftIO . print . length + [CodeLens { _command = Just c }] <- getCodeLenses doc + executeCommand c + _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + edited <- documentContents doc + -- liftIO $ T.writeFile (testdataPath input <.> "expected") edited + expected <- liftIO $ T.readFile $ testdataPath input <.> "expected" + liftIO $ edited @?= expected + +testdataPath :: FilePath +testdataPath = "test/testdata/moduleName" diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs new file mode 100644 --- /dev/null +++ b/test/functional/Progress.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Progress (tests) where + +import Control.Applicative.Combinators +import Control.Lens hiding ((.=)) +import Control.Monad.IO.Class +import Data.Aeson (Value, decode, encode, object, toJSON, (.=)) +import Data.Default +import Data.List (delete) +import Data.Maybe (fromJust) +import Data.Text (Text, pack) +import Ide.Plugin.Config +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Capabilities +import qualified Language.Haskell.LSP.Types.Lens as L +import System.FilePath (()) +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.ExpectedFailure (ignoreTestBecause) +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "window/workDoneProgress" + [ testCase "sends indefinite progress notifications" $ + runSession hlsCommand progressCaps "test/testdata" $ do + let path = "hlint" "ApplyRefact2.hs" + _ <- openDoc path "haskell" + expectProgressReports [pack ("Setting up hlint (for " ++ path ++ ")"), "Processing"] + , testCase "eval plugin sends progress reports" $ + runSession hlsCommand progressCaps "plugins/hls-eval-plugin/test/testdata" $ do + doc <- openDoc "T1.hs" "haskell" + expectProgressReports ["Setting up testdata (for T1.hs)", "Processing"] + [evalLens] <- getCodeLenses doc + let cmd = evalLens ^?! L.command . _Just + _ <- sendRequest WorkspaceExecuteCommand $ ExecuteCommandParams (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments) Nothing + expectProgressReports ["Evaluating"] + , testCase "ormolu plugin sends progress notifications" $ do + runSession hlsCommand progressCaps "test/testdata/format" $ do + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) + doc <- openDoc "Format.hs" "haskell" + expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"] + _ <- sendRequest TextDocumentFormatting $ DocumentFormattingParams doc (FormattingOptions 2 True) Nothing + expectProgressReports ["Formatting Format.hs"] + , testCase "fourmolu plugin sends progress notifications" $ do + runSession hlsCommand progressCaps "test/testdata/format" $ do + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) + doc <- openDoc "Format.hs" "haskell" + expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"] + _ <- sendRequest TextDocumentFormatting $ DocumentFormattingParams doc (FormattingOptions 2 True) Nothing + expectProgressReports ["Formatting Format.hs"] + , ignoreTestBecause "no liquid Haskell support" $ + testCase "liquid haskell plugin sends progress notifications" $ do + runSession hlsCommand progressCaps "test/testdata" $ do + doc <- openDoc "liquid/Evens.hs" "haskell" + let config = def{liquidOn = True, hlintOn = False} + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) + expectProgressReports ["Running Liquid Haskell on Evens.hs"] + ] + +formatLspConfig :: Value -> Value +formatLspConfig provider = object ["haskell" .= object ["formattingProvider" .= (provider :: Value)]] + +progressCaps :: ClientCapabilities +progressCaps = fullCaps{_window = Just (WindowClientCapabilities (Just True))} + +data CollectedProgressNotification + = CreateM WorkDoneProgressCreateRequest + | BeginM WorkDoneProgressBeginNotification + | ProgressM WorkDoneProgressReportNotification + | EndM WorkDoneProgressEndNotification + +{- | Test that the server is correctly producing a sequence of progress related + messages. Each create must be pair with a corresponding begin and end, + optionally with some progress in between. Tokens must match. The begin + messages have titles describing the work that is in-progress, we check that + the titles we see are those we expect. +-} +expectProgressReports :: [Text] -> Session () +expectProgressReports = expectProgressReports' [] + where + expectProgressReports' [] [] = return () + expectProgressReports' tokens expectedTitles = + do + skipManyTill anyMessage (create <|> begin <|> progress <|> end) + >>= \case + CreateM msg -> + expectProgressReports' (token msg : tokens) expectedTitles + BeginM msg -> do + liftIO $ title msg `expectElem` expectedTitles + liftIO $ token msg `expectElem` tokens + expectProgressReports' tokens (delete (title msg) expectedTitles) + ProgressM msg -> do + liftIO $ token msg `expectElem` tokens + expectProgressReports' tokens expectedTitles + EndM msg -> do + liftIO $ token msg `expectElem` tokens + expectProgressReports' (delete (token msg) tokens) expectedTitles + title msg = msg ^. L.params ^. L.value ^. L.title + token msg = msg ^. L.params ^. L.token + create = CreateM <$> message + begin = BeginM <$> message + progress = ProgressM <$> message + end = EndM <$> message + expectElem a as = a `elem` as @? "Unexpected " ++ show a diff --git a/test/functional/Reference.hs b/test/functional/Reference.hs new file mode 100644 --- /dev/null +++ b/test/functional/Reference.hs @@ -0,0 +1,35 @@ +module Reference (tests) where + +import Control.Lens +import Control.Monad.IO.Class +import Data.List +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Lens +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.ExpectedFailure (ignoreTestBecause) +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "references" [ + 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 + liftIO $ map (Location (doc ^. uri)) [ + mkRange 4 0 4 3 + , mkRange 8 11 8 14 + , mkRange 7 7 7 10 + , mkRange 4 14 4 17 + , mkRange 4 0 4 3 + , mkRange 2 6 2 9 + ] `isInfixOf` refs @? "Contains references" + -- TODO: Respect withDeclaration parameter + -- 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 + -- liftIO $ refs `shouldNotContain` [Location (doc ^. uri) (mkRange 4 0 4 3)] + ] + where mkRange sl sc el ec = Range (Position sl sc) (Position el ec) diff --git a/test/functional/Rename.hs b/test/functional/Rename.hs new file mode 100644 --- /dev/null +++ b/test/functional/Rename.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} +module Rename (tests) where + +-- import Control.Monad.IO.Class +-- import Language.Haskell.LSP.Test +-- import Language.Haskell.LSP.Types +-- import Test.Hls.Util +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "rename" [ + testCase "works" $ True @?= True + -- pendingWith "removed because of HaRe" + -- 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 + -- where + -- expected = + -- "main = do\n\ + -- \ x <- return $ baz 42\n\ + -- \ return (baz x)\n\ + -- \baz :: Int -> Int\n\ + -- \baz x = x + 1\n\ + -- \bar = (+ 1) . baz\n" + ] diff --git a/test/functional/Symbol.hs b/test/functional/Symbol.hs new file mode 100644 --- /dev/null +++ b/test/functional/Symbol.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedStrings #-} +module Symbol (tests) where + +import Control.Lens (to, ix, (^?), _Just) +import Control.Monad.IO.Class +import Data.List +import Language.Haskell.LSP.Test as Test +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types.Lens as L +import Language.Haskell.LSP.Types.Capabilities +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.ExpectedFailure (ignoreTestBecause) +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "document symbols" [ + pre310Tests + , v310Tests + ] + +v310Tests :: TestTree +v310Tests = testGroup "3.10 hierarchical document symbols" [ + testCase "provides nested data types and constructors" $ runSession hlsCommand fullCaps "test/testdata" $ do + doc <- openDoc "Symbols.hs" "haskell" + Left symbs <- getDocumentSymbols doc + + let myData = DocumentSymbol "MyData" Nothing SkStruct Nothing myDataR myDataSR (Just (List [a, b])) + a = DocumentSymbol "A" Nothing SkConstructor Nothing aR aSR Nothing + b = DocumentSymbol "B" Nothing SkConstructor Nothing bR bSR Nothing + let myData' = symbs ^? ix 0 . L.children . _Just .to fromList . ix 2 + + liftIO $ Just myData == myData' @? "Contains symbol" + + , ignoreTestBecause "extracting symbols from nested wheres not supported" $ testCase "provides nested where functions" $ runSession hlsCommand fullCaps "test/testdata" $ do + doc <- openDoc "Symbols.hs" "haskell" + Left symbs <- getDocumentSymbols doc + + let foo = DocumentSymbol "foo" Nothing SkFunction Nothing fooR fooSR (Just (List [bar])) + bar = DocumentSymbol "bar" Nothing SkFunction Nothing barR barSR (Just (List [dog, cat])) + dog = DocumentSymbol "dog" Nothing SkVariable Nothing dogR dogSR (Just mempty) + cat = DocumentSymbol "cat" Nothing SkVariable Nothing catR catSR (Just mempty) + let foo' = symbs ^? ix 0 . L.children . _Just .to fromList . ix 1 + + liftIO $ Just foo == foo' @? "Contains symbol" + + , ignoreTestBecause "extracting pattern synonym symbols not supported" $ testCase "provides pattern synonyms" $ runSession hlsCommand fullCaps "test/testdata" $ do + doc <- openDoc "Symbols.hs" "haskell" + Left symbs <- getDocumentSymbols doc + + let testPattern = DocumentSymbol "TestPattern" + Nothing SkFunction Nothing testPatternR testPatternSR (Just mempty) + let testPattern' = symbs ^? ix 0 . L.children . _Just .to fromList . ix 3 + + liftIO $ Just testPattern == testPattern' @? "Contains symbol" + + , testCase "provides imports" $ runSession hlsCommand fullCaps "test/testdata" $ do + doc <- openDoc "Symbols.hs" "haskell" + Left symbs <- getDocumentSymbols doc + + let imports = DocumentSymbol "imports" Nothing SkModule Nothing importsR importsSR (Just (List [importDataMaybe])) + importDataMaybe = DocumentSymbol "import Data.Maybe" Nothing SkModule Nothing importDataMaybeR importDataMaybeSR Nothing + let imports' = symbs ^? ix 0 . L.children . _Just .to fromList . ix 0 + + liftIO $ Just imports == imports' @? "Contains symbol" + ] + +pre310Tests :: TestTree +pre310Tests = testGroup "pre 3.10 symbol information" [ + testCase "provides nested data types and constructors" $ runSession hlsCommand oldCaps "test/testdata" $ do + doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell" + Right symbs <- getDocumentSymbols doc + + let myData = SymbolInformation "MyData" SkStruct Nothing (Location testUri myDataR) (Just "Symbols") + a = SymbolInformation "A" SkConstructor Nothing (Location testUri aR) (Just "MyData") + b = SymbolInformation "B" SkConstructor Nothing (Location testUri bR) (Just "MyData") + + liftIO $ [myData, a, b] `isInfixOf` symbs @? "Contains symbols" + + , ignoreTestBecause "extracting symbols from nested wheres not supported" $ testCase "provides nested where functions" $ runSession hlsCommand oldCaps "test/testdata" $ do + doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell" + Right symbs <- getDocumentSymbols doc + + let foo = SymbolInformation "foo" SkFunction Nothing (Location testUri fooR) (Just "Symbols") + bar = SymbolInformation "bar" SkFunction Nothing (Location testUri barR) (Just "foo") + dog = SymbolInformation "dog" SkVariable Nothing (Location testUri dogR) (Just "bar") + cat = SymbolInformation "cat" SkVariable Nothing (Location testUri catR) (Just "bar") + + -- Order is important! + liftIO $ [foo, bar, dog, cat] `isInfixOf` symbs @? "Contains symbols" + + , ignoreTestBecause "extracting pattern synonym symbols not supported" $ testCase "provides pattern synonyms" $ runSession hlsCommand oldCaps "test/testdata" $ do + doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell" + Right symbs <- getDocumentSymbols doc + + let testPattern = SymbolInformation "TestPattern" + SkFunction Nothing (Location testUri testPatternR) (Just "Symbols") + + liftIO $ testPattern `elem` symbs @? "Contains symbols" + + , testCase "provides imports" $ runSession hlsCommand oldCaps "test/testdata" $ do + doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell" + Right symbs <- getDocumentSymbols doc + + let imports = SymbolInformation "imports" SkModule Nothing (Location testUri importsR) (Just "Symbols") + importDataMaybe = SymbolInformation "import Data.Maybe" SkModule Nothing (Location testUri importDataMaybeR) (Just "imports") + + liftIO $ [imports, importDataMaybe] `isInfixOf` symbs @? "Contains symbol" + ] + +oldCaps :: ClientCapabilities +oldCaps = capsForVersion (LSPVersion 3 9) + +fromList :: List a -> [a] +fromList (List a) = a + +-- Some common ranges and selection ranges in Symbols.hs +importsR :: Range +importsR = Range (Position 3 0) (Position 3 17) +importsSR :: Range +importsSR = Range (Position 3 0) (Position 3 17) +importDataMaybeR :: Range +importDataMaybeR = Range (Position 3 0) (Position 3 17) +importDataMaybeSR :: Range +importDataMaybeSR = Range (Position 3 0) (Position 3 17) +fooSR :: Range +fooSR = Range (Position 5 0) (Position 7 43) +fooR :: Range +fooR = Range (Position 5 0) (Position 7 43) +barSR :: Range +barSR = Range (Position 6 8) (Position 6 11) +barR :: Range +barR = Range (Position 6 8) (Position 7 43) +dogSR :: Range +dogSR = Range (Position 7 17) (Position 7 20) +dogR :: Range +dogR = Range (Position 7 16) (Position 7 43) +catSR :: Range +catSR = Range (Position 7 22) (Position 7 25) +catR :: Range +catR = Range (Position 7 16) (Position 7 43) +myDataSR :: Range +myDataSR = Range (Position 9 0) (Position 10 22) +myDataR :: Range +myDataR = Range (Position 9 0) (Position 10 22) +aSR :: Range +aSR = Range (Position 9 14) (Position 9 15) +aR :: Range +aR = Range (Position 9 14) (Position 9 19) +bSR :: Range +bSR = Range (Position 10 14) (Position 10 15) +bR :: Range +bR = Range (Position 10 14) (Position 10 22) +testPatternSR :: Range +testPatternSR = Range (Position 13 8) (Position 13 19) +testPatternR :: Range +testPatternR = Range (Position 13 0) (Position 13 27) diff --git a/test/functional/Tactic.hs b/test/functional/Tactic.hs new file mode 100644 --- /dev/null +++ b/test/functional/Tactic.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module Tactic + ( tests + ) +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) +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 (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 + + +------------------------------------------------------------------------------ +-- | Get a range at the given line and column corresponding to having nothing +-- selected. +-- +-- NB: These coordinates are in "file space", ie, 1-indexed. +pointRange :: Int -> Int -> Range +pointRange + (subtract 1 -> line) + (subtract 1 -> col) = + Range (Position line col) (Position line $ col + 1) + + +------------------------------------------------------------------------------ +-- | Get the title of a code action. +codeActionTitle :: CAResult -> Maybe Text +codeActionTitle CACommand{} = Nothing +codeActionTitle (CACodeAction(CodeAction title _ _ _ _)) = Just title + + +tests :: TestTree +tests = testGroup + "tactic" + [ mkTest + "Produces intros code action" + "T1.hs" 2 14 + [ (id, Intros, "") + ] + , mkTest + "Produces destruct and homomorphism code actions" + "T2.hs" 2 21 + [ (id, Destruct, "eab") + , (id, Homomorphism, "eab") + ] + , mkTest + "Won't suggest homomorphism on the wrong type" + "T2.hs" 8 8 + [ (not, Homomorphism, "global") + ] + , mkTest + "Won't suggest intros on the wrong type" + "T2.hs" 8 8 + [ (not, Intros, "") + ] + , mkTest + "Produces (homomorphic) lambdacase code actions" + "T3.hs" 4 24 + [ (id, HomomorphismLambdaCase, "") + , (id, DestructLambdaCase, "") + ] + , mkTest + "Produces lambdacase code actions" + "T3.hs" 7 13 + [ (id, DestructLambdaCase, "") + ] + , mkTest + "Doesn't suggest lambdacase without -XLambdaCase" + "T2.hs" 11 25 + [ (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 "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 "" + , goldenTest "GoldenArbitrary.hs" 25 13 Auto "" + ] + + +------------------------------------------------------------------------------ +-- | Make a tactic unit test. +mkTest + :: Foldable t + => String -- ^ The test name + -> FilePath -- ^ The file to load + -> Int -- ^ Cursor line + -> Int -- ^ Cursor columnn + -> t ( Bool -> Bool -- Use 'not' for actions that shouldnt be present + , TacticCommand -- An expected command ... + , Text -- ... for this variable + ) -- ^ A collection of (un)expected code actions. + -> TestTree +mkTest name fp line col ts = + testCase name $ 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 + let title = tacticTitle tc var + liftIO $ + f (elem title titles) + @? ("Expected a code action with title " <> T.unpack title) + + +goldenTest :: FilePath -> Int -> Int -> TacticCommand -> Text -> TestTree +goldenTest 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 + executeCommand c + _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + edited <- documentContents doc + let expected_name = tacticPath input <.> "expected" + -- Write golden tests if they don't already exist + liftIO $ (doesFileExist expected_name >>=) $ flip unless $ do + T.writeFile expected_name edited + expected <- liftIO $ T.readFile expected_name + 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 + diff --git a/test/functional/TypeDefinition.hs b/test/functional/TypeDefinition.hs new file mode 100644 --- /dev/null +++ b/test/functional/TypeDefinition.hs @@ -0,0 +1,55 @@ +module TypeDefinition (tests) where + +import Control.Lens ((^.)) +import Control.Monad.IO.Class +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types.Lens as L +import System.Directory +import System.FilePath (()) +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "type definitions" [ + testCase "finds local definition of record variable" + $ getTypeDefinitionTest' (11, 23) 8 + , testCase "finds local definition of newtype variable" + $ getTypeDefinitionTest' (16, 21) 13 + , testCase "finds local definition of sum type variable" + $ getTypeDefinitionTest' (21, 13) 18 + , knownBrokenForGhcVersions [GHC88] "Definition of sum type not found from data constructor in GHC 8.8.x" $ + testCase "finds local definition of sum type constructor" + $ getTypeDefinitionTest' (24, 7) 18 + , testCase "finds non-local definition of type def" + $ getTypeDefinitionTest' (30, 17) 27 + , testCase "find local definition of type def" + $ getTypeDefinitionTest' (35, 16) 32 + , testCase "find type-definition of type def in component" + $ getTypeDefinitionTest "src/Lib2.hs" (13, 20) "src/Lib.hs" 8 + , testCase "find definition of parameterized data type" + $ getTypeDefinitionTest' (40, 19) 37 + ] + +getTypeDefinitionTest :: String -> (Int, Int) -> String -> Int -> Assertion +getTypeDefinitionTest symbolFile symbolPosition definitionFile definitionLine = + failIfSessionTimeout . runSession hlsCommand fullCaps "test/testdata/gototest" $ do + doc <- openDoc symbolFile "haskell" + _ <- openDoc definitionFile "haskell" + defs <- getTypeDefinitions doc $ toPos symbolPosition + fp <- liftIO $ canonicalizePath $ "test/testdata/gototest" definitionFile + liftIO $ do + length defs == 1 @? "Expecting a list containing one location, but got: " ++ show defs + let [def] = defs + def ^. L.uri @?= filePathToUri fp + def ^. L.range . L.start . L.line @?= definitionLine - 1 + def ^. L.range . L.end . L.line @?= definitionLine - 1 + +getTypeDefinitionTest' :: (Int, Int) -> Int -> Assertion +getTypeDefinitionTest' symbolPosition definitionLine = + getTypeDefinitionTest "src/Lib.hs" symbolPosition "src/Lib.hs" definitionLine + +--NOTE: copied from Haskell.Ide.Engine.ArtifactMap +toPos :: (Int,Int) -> Position +toPos (l,c) = Position (l-1) (c-1) diff --git a/test/utils/Test/Hls/Util.hs b/test/utils/Test/Hls/Util.hs new file mode 100644 --- /dev/null +++ b/test/utils/Test/Hls/Util.hs @@ -0,0 +1,425 @@ +{-# LANGUAGE CPP, OverloadedStrings, NamedFieldPuns, MultiParamTypeClasses #-} +module Test.Hls.Util + ( + codeActionSupportCaps + , dummyLspFuncs + , expectCodeAction + , expectDiagnostic + , expectNoMoreDiagnostics + , failIfSessionTimeout + , flushStackEnvironment + , fromAction + , fromCommand + , getHspecFormattedConfig + , ghcVersion, GhcVersion(..) + , hlsCommand + , hlsCommandExamplePlugin + , hlsCommandVomit + , ignoreForGhcVersions + , inspectCodeAction + , inspectCommand + , inspectDiagnostic + , knownBrokenForGhcVersions + , logConfig + , logFilePath + , noLogConfig + , setupBuildToolFiles + , waitForDiagnosticsFrom + , waitForDiagnosticsFromSource + , waitForDiagnosticsFromSourceWithTimeout + , withFileLogging + , withCurrentDirectoryInTmp + ) +where + +import Control.Exception (throwIO, catch) +import Control.Monad +import Control.Monad.IO.Class +import Control.Applicative.Combinators (skipManyTill, (<|>)) +import Control.Lens ((^.)) +import Data.Default +import Data.List (intercalate) +import Data.List.Extra (find) +import Data.Maybe +import qualified Data.Text as T +import Language.Haskell.LSP.Core +import Language.Haskell.LSP.Messages (FromServerMessage(NotLogMessage)) +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Test as Test +import qualified Language.Haskell.LSP.Types.Lens as L +import qualified Language.Haskell.LSP.Types.Capabilities as C +import System.Directory +import System.Environment +import System.Time.Extra (Seconds, sleep) +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 hiding (Seconds) +import Test.Tasty (TestTree) +import Test.Tasty.ExpectedFailure (ignoreTestBecause, expectFailBecause) +import Test.Tasty.HUnit (assertFailure) +import Text.Blaze.Renderer.String (renderMarkup) +import Text.Blaze.Internal hiding (null) + + +noLogConfig :: Test.SessionConfig +noLogConfig = Test.defaultConfig { Test.logMessages = False } + +logConfig :: Test.SessionConfig +logConfig = Test.defaultConfig { Test.logMessages = True } + +codeActionSupportCaps :: C.ClientCapabilities +codeActionSupportCaps = def { C._textDocument = Just textDocumentCaps } + where + textDocumentCaps = def { C._codeAction = Just codeActionCaps } + codeActionCaps = C.CodeActionClientCapabilities (Just True) (Just literalSupport) + literalSupport = C.CodeActionLiteralSupport def + +withFileLogging :: FilePath -> IO a -> IO a +withFileLogging logFile f = do + let logDir = "./test-logs" + logPath = logDir logFile + + dirExists <- doesDirectoryExist logDir + unless dirExists $ createDirectory logDir + + exists <- doesFileExist logPath + when exists $ removeFile logPath + + setupLogger (Just logPath) ["hie"] L.DEBUG + + f + +-- --------------------------------------------------------------------- + +setupBuildToolFiles :: IO () +setupBuildToolFiles = do + forM_ files setupDirectFilesIn + +setupDirectFilesIn :: FilePath -> IO () +setupDirectFilesIn f = + writeFile (f ++ "hie.yaml") hieYamlCradleDirectContents + + +-- --------------------------------------------------------------------- + +files :: [FilePath] +files = + [ "./test/testdata/" + -- , "./test/testdata/addPackageTest/cabal-exe/" + -- , "./test/testdata/addPackageTest/hpack-exe/" + -- , "./test/testdata/addPackageTest/cabal-lib/" + -- , "./test/testdata/addPackageTest/hpack-lib/" + -- , "./test/testdata/addPragmas/" + -- , "./test/testdata/badProjects/cabal/" + -- , "./test/testdata/completion/" + -- , "./test/testdata/definition/" + -- , "./test/testdata/gototest/" + -- , "./test/testdata/redundantImportTest/" + -- , "./test/testdata/wErrorTest/" + ] + +data GhcVersion + = GHC810 + | GHC88 + | GHC86 + | GHC84 + deriving (Eq,Show) + +ghcVersion :: GhcVersion +#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 +#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,0,0))) +ghcVersion = GHC84 +#endif + +knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree +knownBrokenForGhcVersions vers reason + | ghcVersion `elem` vers = expectFailBecause reason + | otherwise = id + +ignoreForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree +ignoreForGhcVersions vers reason + | ghcVersion `elem` vers = ignoreTestBecause reason + | otherwise = id + +logFilePath :: String +logFilePath = "hls-" ++ show ghcVersion ++ ".log" + +-- | The command to execute the version of hls for the current compiler. +-- +-- Both @stack test@ and @cabal new-test@ setup the environment so @hls@ is +-- on PATH. Cabal seems to respond to @build-tool-depends@ specifically while +-- stack just puts all project executables on PATH. +hlsCommand :: String +hlsCommand = unsafePerformIO $ do + testExe <- fromMaybe "haskell-language-server" <$> lookupEnv "HLS_TEST_EXE" + pure $ testExe ++ " --lsp -d -j2 -l test-logs/" ++ logFilePath + +hlsCommandVomit :: String +hlsCommandVomit = hlsCommand ++ " --vomit" + +hlsCommandExamplePlugin :: String +hlsCommandExamplePlugin = hlsCommand ++ " --example" + +-- --------------------------------------------------------------------- + +hieYamlCradleDirectContents :: String +hieYamlCradleDirectContents = unlines + [ "# WARNING: THIS FILE IS AUTOGENERATED IN test/utils/TestUtils.hs. IT WILL BE OVERWRITTEN ON EVERY TEST RUN" + , "cradle:" + , " direct:" + , " arguments:" + , " - -i." + ] + + +-- --------------------------------------------------------------------- + +getHspecFormattedConfig :: String -> IO Config +getHspecFormattedConfig name = do + -- https://circleci.com/docs/2.0/env-vars/#built-in-environment-variables + isCI <- isJust <$> lookupEnv "CI" + + -- Only use the xml formatter on CI since it hides console output + if isCI + then do + let subdir = "test-results" name + createDirectoryIfMissing True subdir + + return $ defaultConfig { configFormatter = Just xmlFormatter + , configOutputFile = Right $ subdir "results.xml" + } + else return defaultConfig + +-- | A Hspec formatter for CircleCI. +-- Originally from https://github.com/LeastAuthority/hspec-jenkins +xmlFormatter :: Formatter +xmlFormatter = silent { + headerFormatter = do + writeLine "" + writeLine "" + , exampleSucceeded + , exampleFailed + , examplePending + , footerFormatter = writeLine "" + } + where + +#if MIN_VERSION_hspec(2,5,0) + exampleSucceeded path _ = +#else + exampleSucceeded path = +#endif + writeLine $ renderMarkup $ testcase path "" + +#if MIN_VERSION_hspec(2,5,0) + exampleFailed path _ err = +#else + exampleFailed path (Left err) = + writeLine $ renderMarkup $ testcase path $ + failure ! message (show err) $ "" + exampleFailed path (Right err) = +#endif + writeLine $ renderMarkup $ testcase path $ + failure ! message (reasonAsString err) $ "" + +#if MIN_VERSION_hspec(2,5,0) + examplePending path _ reason = +#else + examplePending path reason = +#endif + writeLine $ renderMarkup $ testcase path $ + case reason of + Just desc -> skipped ! message desc $ "" + Nothing -> skipped "" + + failure, skipped :: Markup -> Markup + failure = customParent "failure" + skipped = customParent "skipped" + + name, className, message :: String -> Attribute + name = customAttribute "name" . stringValue + className = customAttribute "classname" . stringValue + message = customAttribute "message" . stringValue + + testcase :: Path -> Markup -> Markup + testcase (xs,x) = customParent "testcase" ! name x ! className (intercalate "." xs) + + reasonAsString :: FailureReason -> String + reasonAsString NoReason = "no reason given" + reasonAsString (Reason x) = x + reasonAsString (ExpectedButGot Nothing expected got) = "Expected " ++ expected ++ " but got " ++ got + reasonAsString (ExpectedButGot (Just src) expected got) = src ++ " expected " ++ expected ++ " but got " ++ got +#if MIN_VERSION_hspec(2,5,0) + reasonAsString (Error Nothing err ) = show err + reasonAsString (Error (Just s) err) = s ++ show err +#endif + +-- --------------------------------------------------------------------- + +flushStackEnvironment :: IO () +flushStackEnvironment = do + -- We need to clear these environment variables to prevent + -- collisions with stack usages + -- See https://github.com/commercialhaskell/stack/issues/4875 + unsetEnv "GHC_PACKAGE_PATH" + unsetEnv "GHC_ENVIRONMENT" + unsetEnv "HASKELL_PACKAGE_SANDBOX" + unsetEnv "HASKELL_PACKAGE_SANDBOXES" + +-- --------------------------------------------------------------------- + +dummyLspFuncs :: Default a => LspFuncs a +dummyLspFuncs = LspFuncs { clientCapabilities = def + , config = return (Just def) + , sendFunc = const (return ()) + , getVirtualFileFunc = const (return Nothing) + , persistVirtualFileFunc = \uri -> return (uriToFilePath (fromNormalizedUri uri)) + , reverseFileMapFunc = return id + , publishDiagnosticsFunc = mempty + , flushDiagnosticsBySourceFunc = mempty + , getNextReqId = pure (IdInt 0) + , rootPath = Nothing + , getWorkspaceFolders = return Nothing + , withProgress = \_ _ f -> f (const (return ())) + , withIndefiniteProgress = \_ _ f -> f + } + +-- | Like 'withCurrentDirectory', but will copy the directory over to the system +-- temporary directory first to avoid haskell-language-server's source tree from +-- interfering with the cradle +withCurrentDirectoryInTmp :: FilePath -> IO a -> IO a +withCurrentDirectoryInTmp dir f = + withTempCopy dir $ \newDir -> + withCurrentDirectory newDir f + +withTempCopy :: FilePath -> (FilePath -> IO a) -> IO a +withTempCopy srcDir f = do + withSystemTempDirectory "hls-test" $ \newDir -> do + copyDir srcDir newDir + f newDir + +copyDir :: FilePath -> FilePath -> IO () +copyDir src dst = do + cnts <- listDirectory src + forM_ cnts $ \file -> do + unless (file `elem` ignored) $ do + let srcFp = src file + dstFp = dst file + isDir <- doesDirectoryExist srcFp + if isDir + then createDirectory dstFp >> copyDir srcFp dstFp + else copyFile srcFp dstFp + where ignored = ["dist", "dist-newstyle", ".stack-work"] + +fromAction :: CAResult -> CodeAction +fromAction (CACodeAction action) = action +fromAction _ = error "Not a code action" + +fromCommand :: CAResult -> Command +fromCommand (CACommand command) = command +fromCommand _ = error "Not a command" + +onMatch :: [a] -> (a -> Bool) -> String -> IO a +onMatch as predicate err = maybe (fail err) return (find predicate as) + +inspectDiagnostic :: [Diagnostic] -> [T.Text] -> IO Diagnostic +inspectDiagnostic diags s = onMatch diags (\ca -> all (`T.isInfixOf` (ca ^. L.message)) s) err + where err = "expected diagnostic matching '" ++ show s ++ "' but did not find one" + +expectDiagnostic :: [Diagnostic] -> [T.Text] -> IO () +expectDiagnostic diags s = void $ inspectDiagnostic diags s + +inspectCodeAction :: [CAResult] -> [T.Text] -> IO CodeAction +inspectCodeAction cars s = fromAction <$> onMatch cars predicate err + where predicate (CACodeAction ca) = all (`T.isInfixOf` (ca ^. L.title)) s + predicate _ = False + err = "expected code action matching '" ++ show s ++ "' but did not find one" + +expectCodeAction :: [CAResult] -> [T.Text] -> IO () +expectCodeAction cars s = void $ inspectCodeAction cars s + +inspectCommand :: [CAResult] -> [T.Text] -> IO Command +inspectCommand cars s = fromCommand <$> onMatch cars predicate err + where predicate (CACommand command) = all (`T.isInfixOf` (command ^. L.title)) s + predicate _ = False + err = "expected code action matching '" ++ show s ++ "' but did not find one" + +waitForDiagnosticsFrom :: TextDocumentIdentifier -> Test.Session [Diagnostic] +waitForDiagnosticsFrom doc = do + diagsNot <- skipManyTill Test.anyMessage Test.message :: Test.Session PublishDiagnosticsNotification + let (List diags) = diagsNot ^. L.params . L.diagnostics + if doc ^. L.uri /= diagsNot ^. L.params . L.uri + then waitForDiagnosticsFrom doc + else return diags + +waitForDiagnosticsFromSource :: TextDocumentIdentifier -> String -> Test.Session [Diagnostic] +waitForDiagnosticsFromSource doc src = do + diagsNot <- skipManyTill Test.anyMessage Test.message :: Test.Session PublishDiagnosticsNotification + let (List diags) = diagsNot ^. L.params . L.diagnostics + let res = filter matches diags + if doc ^. L.uri /= diagsNot ^. L.params . L.uri || null res + then waitForDiagnosticsFromSource doc src + else return res + where + matches :: Diagnostic -> Bool + matches d = d ^. L.source == Just (T.pack src) + +-- | wait for @timeout@ seconds and report an assertion failure +-- if any diagnostic messages arrive in that period +expectNoMoreDiagnostics :: Seconds -> TextDocumentIdentifier -> String -> Test.Session () +expectNoMoreDiagnostics timeout doc src = do + diags <- waitForDiagnosticsFromSourceWithTimeout timeout doc src + unless (null diags) $ + liftIO $ assertFailure $ + "Got unexpected diagnostics for " <> show (doc ^. L.uri) <> + " got " <> show diags + +-- | wait for @timeout@ seconds and return diagnostics for the given @document and @source. +-- If timeout is 0 it will wait until the session timeout +waitForDiagnosticsFromSourceWithTimeout :: Seconds -> TextDocumentIdentifier -> String -> Test.Session [Diagnostic] +waitForDiagnosticsFromSourceWithTimeout timeout document source = do + when (timeout > 0) $ do + -- Give any further diagnostic messages time to arrive. + liftIO $ sleep timeout + -- Send a dummy message to provoke a response from the server. + -- This guarantees that we have at least one message to + -- process, so message won't block or timeout. + void $ Test.sendRequest (CustomClientMethod "non-existent-method") () + handleMessages + where + matches :: Diagnostic -> Bool + matches d = d ^. L.source == Just (T.pack source) + + handleMessages = handleDiagnostic <|> handleCustomMethodResponse <|> ignoreOthers + handleDiagnostic = do + diagsNot <- Test.message :: Test.Session PublishDiagnosticsNotification + let fileUri = diagsNot ^. L.params . L.uri + (List diags) = diagsNot ^. L.params . L.diagnostics + res = filter matches diags + if fileUri == document ^. L.uri && not (null res) + then return diags else handleMessages + handleCustomMethodResponse = + -- the CustomClientMethod triggers a RspCustomServer + -- handle that and then exit + void (Test.satisfyMaybe responseForNonExistentMethod) >> return [] + + responseForNonExistentMethod notif + | NotLogMessage logMsg <- notif, + "non-existent-method" `T.isInfixOf` (logMsg ^. L.params . L.message) = Just notif + | otherwise = Nothing + + ignoreOthers = void Test.anyMessage >> handleMessages + +failIfSessionTimeout :: IO a -> IO a +failIfSessionTimeout action = action `catch` errorHandler + where errorHandler :: Test.SessionException -> IO a + errorHandler e@(Test.Timeout _) = assertFailure $ show e + errorHandler e = throwIO e diff --git a/test/wrapper/Main.hs b/test/wrapper/Main.hs new file mode 100644 --- /dev/null +++ b/test/wrapper/Main.hs @@ -0,0 +1,39 @@ +import Data.Char +import Data.List +import Data.Maybe +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Ingredients.Rerun +import Test.Tasty.Runners ( listingTests, consoleTestReporter) +import System.Process +import System.Environment + +main :: IO () +main = do + flushStackEnvironment + defaultMainWithIngredients + [rerunningTests [listingTests, consoleTestReporter]] $ + testGroup "haskell-language-server-wrapper" [projectGhcVersionTests] + +projectGhcVersionTests :: TestTree +projectGhcVersionTests = testGroup "--project-ghc-version" + [ testCase "stack with ghc 8.10.1" $ + testDir "test/wrapper/testdata/stack-8.10.1" "8.10.1" + , testCase "stack with ghc 8.8.3" $ + testDir "test/wrapper/testdata/stack-8.8.3" "8.8.3" + , testCase "cabal with global ghc" $ do + ghcVer <- trim <$> readProcess "ghc" ["--numeric-version"] "" + testDir "test/wrapper/testdata/cabal-cur-ver" ghcVer + ] + +testDir :: FilePath -> String -> Assertion +testDir dir expectedVer = + withCurrentDirectoryInTmp dir $ do + testExe <- fromMaybe "haskell-language-server-wrapper" + <$> lookupEnv "HLS_WRAPPER_TEST_EXE" + actualVer <- trim <$> readProcess testExe ["--project-ghc-version"] "" + actualVer @?= expectedVer + +trim :: String -> String +trim = dropWhileEnd isSpace