diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,265 +1,288 @@ -### 0.7.5 (2021-02-??) -* Tone down some logInfos to logDebug (#1385) - Pepe Iborra -* Show window message when auto extending import lists (#1371) - Potato Hatsue -* Catch GHC errors in listing module names (#1367) - Potato Hatsue -* Upgrade to lsp-1.0 (#1284) - wz1000 -* Added Development.IDE.Main (#1338) - Pepe Iborra -* Fix completion snippets on DuplicateRecordFields (#1360) - Potato Hatsue -* Add code action for hiding shadowed identifiers from imports (#1322) - Potato Hatsue -* Make find-definition work better with multi-components (#1357) - wz1000 -* Index files on first open (#1358) - wz1000 -* Fix code actions regression (#1349) - Pepe Iborra - -### 0.7.4 (2021-02-08) -* Support for references via hiedb (#704) - wz1000 -* Fix space leak on cradle reloads (#1316) - Pepe Iborra -* Trigger extending import only when the item is not in scope (#1309) - Potato Hatsue -* Don't extend the import list with child if the parent has already been imported as (..) (#1302) - Potato Hatsue -* FindImports typo (minor) (#1291) - Andy -* Reenable auto extend imports and drop snippets for infix completions (#1266) - Pepe Iborra -* ghcide: Implements a CodeAction to disambiguate ambiguous symbols (#1264) - Hiromi Ishii -* Restore code actions order (#1273) - Pepe Iborra - -### 0.7.3 (2021-02-04) -* Add custom cache layer for session loading (#1197) - (fendor) -* Remove invalid exports (#1193) - (Kostas Dermentzis) -* Use exact print to suggestExtendImport - (Potato Hatsue) -* Add code actions for disabling a warning in the current file (#1235) - (George Thomas) -* Limit completions to top 40 (#1218) - (Pepe Iborra) -* Add traces for HLS providers (#1222) - (Pepe Iborra) -* Use exact print for suggest missing constraint code actions (#1221) - (Pepe Iborra) -* Parenthesise type operators when extending import lists (#1212) - (Thomas Winant) - -### 0.7.2 (2021-01-14) -* Expose shakeOptions used - (Pepe Iborra) - -### 0.7.1 (2021-01-13) -* Fix sticky diagnostics bug (#1188) - (Pepe Iborra) -* Use completionSnippetsOn flag (#1195) - (Yuya Kono) -* Update tested-with GHC in cabal config - (jneira) -* Do not disable parallel GC by default (#1190) - (Pepe Iborra) -* Fix module outline becoming stale after switching branches (#1189) - (Pepe Iborra) -* Make adding missing constraint work in presence of 'forall' (fixes #1164) (#1177) - (Jan Hrcek) -* Bump haskell-lsp to 0.23 (#1146) - (Potato Hatsue) -* Fix #723 (Instance declarations in hs-boot files result in GHC errors) (#781) - (Ben Simms) -* Also suggest importing methods without parent class (#766) - (Thomas Winant) -* Update links to issues/PRs in ghcide tests. (#1142) - (Peter Wicks Stringfield) -* fix suggestAddTypeAnnotation regex (#760) - (Kostas Dermentzis) - -### 0.7.0 (2021-01-03) -* Ghcide now loads HLS plugins internally - (Pepe Iborra) -* Retry a failed cradle if the cradle descriptor changes (#762) - (Pepe Iborra) -* Fix extend imports regression (#769) - (Pepe Iborra) -* Perform memory measurement on SIGUSR1 (#761) - (Pepe Iborra) - -### 0.6.0.2 (2020-12-26) -* Fix disappearing diagnostics bug (#959) - (Pepe Iborra) -* Deduplicate module not found diagnostics (#952) - (Pepe Iborra) -* Use qualified module name from diagnostics in suggestNewImport (#945) - (Potato Hatsue) -* Disable auto extend import snippets in completions (these need a bit more work) - -### 0.6.0.1 (2020-12-13) -* Fix build with GHC 8.8.2 and 8.8.3 - (Javier Neira) -* Update old URLs still pointing to digital-asset - (Jan Hrcek) - -### 0.6.0 (2020-12-06) -* Completions: extend explicit import list automatically (#930) - (Guru Devanla) -* Completions for identifiers not in explicit import lists (#919) - (Guru Devanla) -* Completions for record fields (#900) - (Guru Devanla) -* Bugfix: add constructors to import lists correctly (#916) - (Potato Hatsue) -* Bugfix: respect qualified identifiers (#938) - (Pepe Iborra) -* Bugfix: partial `pathToId` (#926) - (Samuel Ainsworth) -* Bugfix: import suggestions when there's more than one option (#913) - (Guru Devanla) -* Bugfix: parenthesize operators when exporting (#906) - (Potato Hatsue) -* Opentelemetry traces and heapsize memory analysis (#922) - (Michalis Pardalos / Pepe Iborra) -* Make Filetargets absolute before continue using them (#914) - (fendor) -* Do not enable every "unnecessary" warning by default (#907) - (Alejandro Serrano) -* Update implicit-hie to 0.3.0 (#905) - (Avi Dessauer) - -### 0.5.0 (2020-11-07) -* Use implicit-hie-0.1.2.0 (#880) - (Javier Neira) -* Clarify and downgrade implicit-hie message (#883) - (Avi Dessauer) -* Switch back to bytecode (#873) - (wz1000) -* Add code action for remove all redundant imports (#867) - (Potato Hatsue) -* Fix pretty printer for diagnostic ranges (#871) - (Martin Huschenbett) -* Canonicalize import dirs (#870) - (Pepe Iborra) -* Do not show internal hole names (#852) - (Alejandro Serrano) -* Downgrade file watch debug log to logDebug from logInfo (#848) - (Matthew Pickering) -* Pull in local bindings (#845) - (Sandy Maguire) -* Use object code for Template Haskell, emit desugarer warnings (#836) - (wz1000) -* Fix code action for adding missing constraints to type signatures (#839) - (Jan Hrcek) -* Fix duplicated completions (#837) - (Vitalii) -* FileExists: set one watcher instead of thousands (#831) - (Michael Peyton Jones) -* Drop 8.4 support (#834) - (wz1000) -* Add GetHieAsts rule, Replace SpanInfo, add support for DocumentHighlight and scope-aware completions for local variables (#784) - (wz1000) -* Tag unused warning as such (#815) - (Alejandro Serrano) -* Update instructions for stty error in windows (#825) - (Javier Neira) -* Fix docs tooltip for base libraries on Windows (#814) - (Nick Dunets) -* Fix documentation (or source) link when html file is less specific than module (#766) - (Nick Dunets) -* Add completion tests for records. (#804) - (Guru Devanla) -* Restore identifiers missing from hi file (#741) - (maralorn) -* Fix import suggestions when dot is typed (#800) - (Marcelo Lazaroni) - -### 0.4.0 (2020-09-15) -* Fixes for GHC source plugins: dotpreprocessor works now - (srid) -* Use implicit-hie when no explicit hie.yaml (#782) - (Javier Neira) -* Extend position mapping with fuzzy ranges (#785) - (wz1000) -* Sort import suggestions (#793) - (Pepe Iborra) -* Save source files with HIE files (#701) - (fendor) -* Fully asynchronous request handling (#767) - (Pepe Iborra) -* Refinement holes (#748) - (Pepe Iborra) -* Fix haddock to markdown conversion (#757) - (George Thomas) -* Expose `getCompletionsLSP` to allow completions in hls (#756) - (wz1000) -* Suggestions for missing imports from local modules (#739) - (Pepe Iborra) -* Dynamically load libm on Linux for each new session (#723) - (Luke Lau) -* Use InitializeParams.rootUri for initial session setup (#713) - (shaurya gupta) -* Show documentation on hover for symbols defined in the same module (#691) - (wz1000) -* Suggest open imports (#740) - (Pepe Iborra) -* module Development.IDE (#724) - (Pepe Iborra) -* Ignore -Werror (#738) - (Pepe Iborra) -* Fix issue #710: fix suggest delete binding (#728) - (Ray Shih) -* Generate doc file URL via LSP (to fix it for Windows) (#721) - (Nick Dunets) -* Fix `.hie` file location for `.hs-boot` files (#690) - (wz1000) -* Use argsVerbose to determine log level in test mode (#717) - (Ziyang Liu) -* output which cradle files were found (#716) - (Adam Sandberg Eriksson) -* Typecheck entire project on Initial Load and typecheck reverse dependencies of a file on saving (#688) - (wz1000) - -### 0.3.0 (2020-09-02) - -* CI: remove (internal) DA Slack notifications (#750) - (Gary Verhaegen) -* Add session-loader to hie.yaml (#714) - (Luke Lau) -* Codeaction for exporting unused top-level bindings (#711) - (shaurya gupta) -* Add links to haddock and hscolour pages in documentation (#699) - (Luke Lau) -* Expose GHC.Compat module (#709) - (Pepe Iborra) -* Move session loading logic into ghcide library (#697) - (Luke Lau) -* Code action: remove redundant constraints for type signature (#692) - (Denis Frezzato) -* Fix Binary instance of Q to handle empty file paths (#707) - (Moritz Kiefer) -* Populate ms_hs_date in GetModSummary rule (#694) - (Pepe Iborra) -* Allow GHC plugins to be called with an updated StringBuffer (#698) - (Alfredo Di Napoli) -* Relax upper bounds for GHC 8.10.1 (#705) - (Pepe Iborra) -* Obtain the GHC libdir at runtime (#696) - (Luke Lau) -* Expect bench experiments to fail with Cabal (#704) - (Pepe Iborra) -* Bump lodash from 4.17.15 to 4.17.19 in /extension (#702) - (dependabot[bot]) -* Update to hie-bios 0.6.1 (#693) - (fendor) -* Backport HIE files to GHC 8.6 (#689) - (wz1000) -* Performance improvements for GetSpanInfo (#681) - (Pepe Iborra) -* Code action add default type annotation to remove `-Wtype-defaults` warning (#680) - (Serhii) -* Use a global namecache to read `.hie` files (#677) - (wz1000) -* Completions need not depend on typecheck of the current file (#670) - (Pepe Iborra) -* Fix spaninfo Haddocks for local modules (#678) - (Pepe Iborra) -* Avoid excessive retypechecking of TH codebases (#673) - (Pepe Iborra) -* Use stale information if it's available to answer requests quickly (#624) - (Matthew Pickering) -* Code action: add constraint (#653) - (Denis Frezzato) -* Make BenchHist non buildable by default and save logs (#666) - (Pepe Iborra) -* Delete unused top level binding code action (#657) - (Serhii) -* stack810.yaml: bump (#651) - (Domen Kozar) -* Fix debouncer for 0 delay (#662) - (Pepe Iborra) -* Interface file fixes (#645) - (Pepe Iborra) -* Retry GHC 8.10 on Windows (#661) - (Moritz Kiefer) -* Finer dependencies for GhcSessionFun (#643) - (Pepe Iborra) -* Send WorkDoneProgressEnd only when work is done (#649) - (Pepe Iborra) -* Add a note on differential benchmarks (#647) - (Pepe Iborra) -* Cache a ghc session per file of interest (#630) - (Pepe Iborra) -* Remove `Strict` from the language extensions used for code actions (#638) - (Torsten Schmits) -* Report progress when setting up cradle (#644) - (Luke Lau) -* Fix crash when writing to a Barrier more than once (#637) - (Pepe Iborra) -* Write a cabal.project file in the benchmark example (#640) - (Pepe Iborra) -* Performance analysis over time (#629) - (Pepe Iborra) -* More benchmarks (#625) - (Pepe Iborra) -* Canonicalize the locations in the cradle tests (#628) - (Luke Lau) -* Add hie.yaml.stack and use none cradle for test data (#626) - (Javier Neira) -* Fix a bug in getHiFileRule (#623) - (Pepe Iborra) -* ghc initialization error handling (#609) - (Pepe Iborra) -* Fix regression in getSpanInfoRule (#622) - (Pepe Iborra) -* Restore Shake profiling (#621) - (Pepe Iborra) -* Use a better noRange (#612) - (Neil Mitchell) -* Add back a .ghci file (#607) - (Neil Mitchell) -* #573, make haddock errors warnings with the word Haddock in front (#608) - (Neil Mitchell) -* Implement Goto Type Definition (#533) - (Matthew Pickering) -* remove unnecessary FileExists dependency in GetHiFile (#589) - (Pepe Iborra) -* ShakeSession and shakeEnqueue (#554) - (Pepe Iborra) -* Benchmark suite (#590) - (Pepe Iborra) - -### 0.2.0 (2020-06-02) - -* Multi-component support (thanks @mpickering) -* Support for GHC 8.10 (thanks @sheaf and @chshersh) -* Fix some TH issues (thanks @mpickering) -* Automatically pick up changes to cradle dependencies (e.g. cabal - files) (thanks @jinwoo) -* Track dependencies when using `qAddDependentFile` (thanks @mpickering) -* Add record fields to document symbols outline (thanks @bubba) -* Fix some space leaks (thanks @mpickering) -* Strip redundant path information from diagnostics (thanks @tek) -* Fix import suggestions for operators (thanks @eddiemundo) -* Significant reductions in memory usage by using interfaces and `.hie` files (thanks - @pepeiborra) -* Minor improvements to completions -* More comprehensive suggestions for missing imports (thanks @pepeiborra) -* Group imports in document outline (thanks @fendor) -* Upgrade to haskell-lsp-0.22 (thanks @bubba) -* Upgrade to hie-bios 0.5 (thanks @fendor) - -### 0.1.0 (2020-02-04) - -* Code action for inserting new definitions (see #309). -* Better default GC settings (see #329 and #333). -* Various performance improvements (see #322 and #384). -* Improvements to hover information (see #317 and #338). -* Support GHC 8.8.2 (see #355). -* Include keywords in completions (see #351). -* Fix some issues with aborted requests (see #353). -* Use hie-bios 0.4.0 (see #382). -* Avoid stuck progress reporting (see #400). -* Only show progress notifications after 0.1s (see #392). -* Progress reporting is now in terms of the number of files rather - than the number of shake rules (see #379). - -### 0.0.6 (2020-01-10) - -* Fix type in hover information for do-notation and list - comprehensions (see #243). -* Fix hover and goto-definition for multi-clause definitions (see #252). -* Upgrade to `hie-bios-0.3` (see #257) -* Upgrade to `haskell-lsp-0.19` (see #254) -* Code lenses for missing signatures are displayed even if the warning - has not been enabled. The warning itself will not be shown if it is - not enabled. (see #232) -* Define `__GHCIDE__` when running CPP to allow for `ghcide`-specific - workarounds. (see #264) -* Fix some filepath normalization issues. (see #266) -* Fix build with `shake-0.18.4` (see #272) -* Fix hover for type constructors and type classes. (see #267) -* Support custom preprocessors (see #282) -* Add support for code completions (see #227) -* Code action for removing redundant symbols from imports (see #290) -* Support document symbol requests (see #293) -* Show CPP errors as diagnostics (see #296) -* Code action for adding suggested imports (see #295) - -### 0.0.5 (2019-12-12) - -* Support for GHC plugins (see #192) -* Update to haskell-lsp 0.18 (see #203) -* Initial support for `TemplateHaskell` (see #222) -* Code lenses for missing signatures. These are only shown if - `-Wmissing-signatures` is enabled. (see #224) -* Fix path normalisation on Windows (see #225) -* Fix flickering of the progress indicator (see #230) - -### 0.0.4 (2019-10-20) - -* Add a ``--version`` cli option (thanks @jacg) -* Update to use progress reporting as defined in LSP 3.15. The VSCode - extension has also been updated and should now be making use of - this. -* Properly declare that we should support code actions. This helps - with some clients that rely on this information to enable code - actions (thanks @jacg). -* Fix a race condition caused by sharing the finder cache between - concurrent compilations. -* Avoid normalizing include dirs. This avoids issues where the same - file ends up twice in the module graph, e.g., with different casing - for drive letters. - -### 0.0.3 (2019-09-21) +### 1.1.0 (2021-03-09) +* Add an option to control progress reporting (#1513) - Pepe Iborra +* Fix missing parens of auto extending imports (#1526) - Potato Hatsue +* Avoid redundant work in diagnostics pass (#1514) - Pepe Iborra +* Avoid always rerunning GetModificationTime for interface files too (#1506) - Pepe Iborra +* Demote implicit cradle warn to logging (#1511) - Javier Neira +* Drive GetModificationTime using watched file events (#1487) - Pepe Iborra +* Make type lenses plugin configurable (#1491) - Potato Hatsue +* Context-aware ExactPrint grafting for HsExpr (#1489) - Sandy Maguire +* Register IDE configuration when called via the command line (#1495) - wz1000 +* Faster ModSummary fingerprints (#1485) - Pepe Iborra +* Make sure to give the correct DynFlags to the recompilation checker (#1459) - Pepe Iborra +* Customize the unitId used for the fake internal component (#1435) - Pepe Iborra +* Extract the qualified name from already imported module (#1445) - Potato Hatsue +* Add code action for importing class methods (#1428) - Potato Hatsue +* Reformat all files (#1439) - Junyoung/Clare Jang +* Minor performance optimizations (#1432) - Pepe Iborra + +### 1.0.0 (2021-03-04) +* Fix the handling of default HLS config again (#1419) - Pepe Iborra +* Hlint hints. (#1227) - Peter Wicks Stringfield +* Use object code for TH+UnboxedTuples/Sums (#1382) - wz1000 +* Add a pre commit hook for code formatting (#1384) - Junyoung/Clare Jang +### 0.7.5 (2021-02-17) +* Tone down some logInfos to logDebug (#1385) - Pepe Iborra +* Show window message when auto extending import lists (#1371) - Potato Hatsue +* Catch GHC errors in listing module names (#1367) - Potato Hatsue +* Upgrade to lsp-1.0 (#1284) - wz1000 +* Added Development.IDE.Main (#1338) - Pepe Iborra +* Fix completion snippets on DuplicateRecordFields (#1360) - Potato Hatsue +* Add code action for hiding shadowed identifiers from imports (#1322) - Potato Hatsue +* Make find-definition work better with multi-components (#1357) - wz1000 +* Index files on first open (#1358) - wz1000 +* Fix code actions regression (#1349) - Pepe Iborra + +### 0.7.4 (2021-02-08) +* Support for references via hiedb (#704) - wz1000 +* Fix space leak on cradle reloads (#1316) - Pepe Iborra +* Trigger extending import only when the item is not in scope (#1309) - Potato Hatsue +* Don't extend the import list with child if the parent has already been imported as (..) (#1302) - Potato Hatsue +* FindImports typo (minor) (#1291) - Andy +* Reenable auto extend imports and drop snippets for infix completions (#1266) - Pepe Iborra +* ghcide: Implements a CodeAction to disambiguate ambiguous symbols (#1264) - Hiromi Ishii +* Restore code actions order (#1273) - Pepe Iborra + +### 0.7.3 (2021-02-04) +* Add custom cache layer for session loading (#1197) - (fendor) +* Remove invalid exports (#1193) - (Kostas Dermentzis) +* Use exact print to suggestExtendImport - (Potato Hatsue) +* Add code actions for disabling a warning in the current file (#1235) - (George Thomas) +* Limit completions to top 40 (#1218) - (Pepe Iborra) +* Add traces for HLS providers (#1222) - (Pepe Iborra) +* Use exact print for suggest missing constraint code actions (#1221) - (Pepe Iborra) +* Parenthesise type operators when extending import lists (#1212) - (Thomas Winant) + +### 0.7.2 (2021-01-14) +* Expose shakeOptions used - (Pepe Iborra) + +### 0.7.1 (2021-01-13) +* Fix sticky diagnostics bug (#1188) - (Pepe Iborra) +* Use completionSnippetsOn flag (#1195) - (Yuya Kono) +* Update tested-with GHC in cabal config - (jneira) +* Do not disable parallel GC by default (#1190) - (Pepe Iborra) +* Fix module outline becoming stale after switching branches (#1189) - (Pepe Iborra) +* Make adding missing constraint work in presence of 'forall' (fixes #1164) (#1177) - (Jan Hrcek) +* Bump haskell-lsp to 0.23 (#1146) - (Potato Hatsue) +* Fix #723 (Instance declarations in hs-boot files result in GHC errors) (#781) - (Ben Simms) +* Also suggest importing methods without parent class (#766) - (Thomas Winant) +* Update links to issues/PRs in ghcide tests. (#1142) - (Peter Wicks Stringfield) +* fix suggestAddTypeAnnotation regex (#760) - (Kostas Dermentzis) + +### 0.7.0 (2021-01-03) +* Ghcide now loads HLS plugins internally - (Pepe Iborra) +* Retry a failed cradle if the cradle descriptor changes (#762) - (Pepe Iborra) +* Fix extend imports regression (#769) - (Pepe Iborra) +* Perform memory measurement on SIGUSR1 (#761) - (Pepe Iborra) + +### 0.6.0.2 (2020-12-26) +* Fix disappearing diagnostics bug (#959) - (Pepe Iborra) +* Deduplicate module not found diagnostics (#952) - (Pepe Iborra) +* Use qualified module name from diagnostics in suggestNewImport (#945) - (Potato Hatsue) +* Disable auto extend import snippets in completions (these need a bit more work) + +### 0.6.0.1 (2020-12-13) +* Fix build with GHC 8.8.2 and 8.8.3 - (Javier Neira) +* Update old URLs still pointing to digital-asset - (Jan Hrcek) + +### 0.6.0 (2020-12-06) +* Completions: extend explicit import list automatically (#930) - (Guru Devanla) +* Completions for identifiers not in explicit import lists (#919) - (Guru Devanla) +* Completions for record fields (#900) - (Guru Devanla) +* Bugfix: add constructors to import lists correctly (#916) - (Potato Hatsue) +* Bugfix: respect qualified identifiers (#938) - (Pepe Iborra) +* Bugfix: partial `pathToId` (#926) - (Samuel Ainsworth) +* Bugfix: import suggestions when there's more than one option (#913) - (Guru Devanla) +* Bugfix: parenthesize operators when exporting (#906) - (Potato Hatsue) +* Opentelemetry traces and heapsize memory analysis (#922) - (Michalis Pardalos / Pepe Iborra) +* Make Filetargets absolute before continue using them (#914) - (fendor) +* Do not enable every "unnecessary" warning by default (#907) - (Alejandro Serrano) +* Update implicit-hie to 0.3.0 (#905) - (Avi Dessauer) + +### 0.5.0 (2020-11-07) +* Use implicit-hie-0.1.2.0 (#880) - (Javier Neira) +* Clarify and downgrade implicit-hie message (#883) - (Avi Dessauer) +* Switch back to bytecode (#873) - (wz1000) +* Add code action for remove all redundant imports (#867) - (Potato Hatsue) +* Fix pretty printer for diagnostic ranges (#871) - (Martin Huschenbett) +* Canonicalize import dirs (#870) - (Pepe Iborra) +* Do not show internal hole names (#852) - (Alejandro Serrano) +* Downgrade file watch debug log to logDebug from logInfo (#848) - (Matthew Pickering) +* Pull in local bindings (#845) - (Sandy Maguire) +* Use object code for Template Haskell, emit desugarer warnings (#836) - (wz1000) +* Fix code action for adding missing constraints to type signatures (#839) - (Jan Hrcek) +* Fix duplicated completions (#837) - (Vitalii) +* FileExists: set one watcher instead of thousands (#831) - (Michael Peyton Jones) +* Drop 8.4 support (#834) - (wz1000) +* Add GetHieAsts rule, Replace SpanInfo, add support for DocumentHighlight and scope-aware completions for local variables (#784) - (wz1000) +* Tag unused warning as such (#815) - (Alejandro Serrano) +* Update instructions for stty error in windows (#825) - (Javier Neira) +* Fix docs tooltip for base libraries on Windows (#814) - (Nick Dunets) +* Fix documentation (or source) link when html file is less specific than module (#766) - (Nick Dunets) +* Add completion tests for records. (#804) - (Guru Devanla) +* Restore identifiers missing from hi file (#741) - (maralorn) +* Fix import suggestions when dot is typed (#800) - (Marcelo Lazaroni) + +### 0.4.0 (2020-09-15) +* Fixes for GHC source plugins: dotpreprocessor works now - (srid) +* Use implicit-hie when no explicit hie.yaml (#782) - (Javier Neira) +* Extend position mapping with fuzzy ranges (#785) - (wz1000) +* Sort import suggestions (#793) - (Pepe Iborra) +* Save source files with HIE files (#701) - (fendor) +* Fully asynchronous request handling (#767) - (Pepe Iborra) +* Refinement holes (#748) - (Pepe Iborra) +* Fix haddock to markdown conversion (#757) - (George Thomas) +* Expose `getCompletionsLSP` to allow completions in hls (#756) - (wz1000) +* Suggestions for missing imports from local modules (#739) - (Pepe Iborra) +* Dynamically load libm on Linux for each new session (#723) - (Luke Lau) +* Use InitializeParams.rootUri for initial session setup (#713) - (shaurya gupta) +* Show documentation on hover for symbols defined in the same module (#691) - (wz1000) +* Suggest open imports (#740) - (Pepe Iborra) +* module Development.IDE (#724) - (Pepe Iborra) +* Ignore -Werror (#738) - (Pepe Iborra) +* Fix issue #710: fix suggest delete binding (#728) - (Ray Shih) +* Generate doc file URL via LSP (to fix it for Windows) (#721) - (Nick Dunets) +* Fix `.hie` file location for `.hs-boot` files (#690) - (wz1000) +* Use argsVerbose to determine log level in test mode (#717) - (Ziyang Liu) +* output which cradle files were found (#716) - (Adam Sandberg Eriksson) +* Typecheck entire project on Initial Load and typecheck reverse dependencies of a file on saving (#688) - (wz1000) + +### 0.3.0 (2020-09-02) + +* CI: remove (internal) DA Slack notifications (#750) - (Gary Verhaegen) +* Add session-loader to hie.yaml (#714) - (Luke Lau) +* Codeaction for exporting unused top-level bindings (#711) - (shaurya gupta) +* Add links to haddock and hscolour pages in documentation (#699) - (Luke Lau) +* Expose GHC.Compat module (#709) - (Pepe Iborra) +* Move session loading logic into ghcide library (#697) - (Luke Lau) +* Code action: remove redundant constraints for type signature (#692) - (Denis Frezzato) +* Fix Binary instance of Q to handle empty file paths (#707) - (Moritz Kiefer) +* Populate ms_hs_date in GetModSummary rule (#694) - (Pepe Iborra) +* Allow GHC plugins to be called with an updated StringBuffer (#698) - (Alfredo Di Napoli) +* Relax upper bounds for GHC 8.10.1 (#705) - (Pepe Iborra) +* Obtain the GHC libdir at runtime (#696) - (Luke Lau) +* Expect bench experiments to fail with Cabal (#704) - (Pepe Iborra) +* Bump lodash from 4.17.15 to 4.17.19 in /extension (#702) - (dependabot[bot]) +* Update to hie-bios 0.6.1 (#693) - (fendor) +* Backport HIE files to GHC 8.6 (#689) - (wz1000) +* Performance improvements for GetSpanInfo (#681) - (Pepe Iborra) +* Code action add default type annotation to remove `-Wtype-defaults` warning (#680) - (Serhii) +* Use a global namecache to read `.hie` files (#677) - (wz1000) +* Completions need not depend on typecheck of the current file (#670) - (Pepe Iborra) +* Fix spaninfo Haddocks for local modules (#678) - (Pepe Iborra) +* Avoid excessive retypechecking of TH codebases (#673) - (Pepe Iborra) +* Use stale information if it's available to answer requests quickly (#624) - (Matthew Pickering) +* Code action: add constraint (#653) - (Denis Frezzato) +* Make BenchHist non buildable by default and save logs (#666) - (Pepe Iborra) +* Delete unused top level binding code action (#657) - (Serhii) +* stack810.yaml: bump (#651) - (Domen Kozar) +* Fix debouncer for 0 delay (#662) - (Pepe Iborra) +* Interface file fixes (#645) - (Pepe Iborra) +* Retry GHC 8.10 on Windows (#661) - (Moritz Kiefer) +* Finer dependencies for GhcSessionFun (#643) - (Pepe Iborra) +* Send WorkDoneProgressEnd only when work is done (#649) - (Pepe Iborra) +* Add a note on differential benchmarks (#647) - (Pepe Iborra) +* Cache a ghc session per file of interest (#630) - (Pepe Iborra) +* Remove `Strict` from the language extensions used for code actions (#638) - (Torsten Schmits) +* Report progress when setting up cradle (#644) - (Luke Lau) +* Fix crash when writing to a Barrier more than once (#637) - (Pepe Iborra) +* Write a cabal.project file in the benchmark example (#640) - (Pepe Iborra) +* Performance analysis over time (#629) - (Pepe Iborra) +* More benchmarks (#625) - (Pepe Iborra) +* Canonicalize the locations in the cradle tests (#628) - (Luke Lau) +* Add hie.yaml.stack and use none cradle for test data (#626) - (Javier Neira) +* Fix a bug in getHiFileRule (#623) - (Pepe Iborra) +* ghc initialization error handling (#609) - (Pepe Iborra) +* Fix regression in getSpanInfoRule (#622) - (Pepe Iborra) +* Restore Shake profiling (#621) - (Pepe Iborra) +* Use a better noRange (#612) - (Neil Mitchell) +* Add back a .ghci file (#607) - (Neil Mitchell) +* #573, make haddock errors warnings with the word Haddock in front (#608) - (Neil Mitchell) +* Implement Goto Type Definition (#533) - (Matthew Pickering) +* remove unnecessary FileExists dependency in GetHiFile (#589) - (Pepe Iborra) +* ShakeSession and shakeEnqueue (#554) - (Pepe Iborra) +* Benchmark suite (#590) - (Pepe Iborra) + +### 0.2.0 (2020-06-02) + +* Multi-component support (thanks @mpickering) +* Support for GHC 8.10 (thanks @sheaf and @chshersh) +* Fix some TH issues (thanks @mpickering) +* Automatically pick up changes to cradle dependencies (e.g. cabal + files) (thanks @jinwoo) +* Track dependencies when using `qAddDependentFile` (thanks @mpickering) +* Add record fields to document symbols outline (thanks @bubba) +* Fix some space leaks (thanks @mpickering) +* Strip redundant path information from diagnostics (thanks @tek) +* Fix import suggestions for operators (thanks @eddiemundo) +* Significant reductions in memory usage by using interfaces and `.hie` files (thanks + @pepeiborra) +* Minor improvements to completions +* More comprehensive suggestions for missing imports (thanks @pepeiborra) +* Group imports in document outline (thanks @fendor) +* Upgrade to haskell-lsp-0.22 (thanks @bubba) +* Upgrade to hie-bios 0.5 (thanks @fendor) + +### 0.1.0 (2020-02-04) + +* Code action for inserting new definitions (see #309). +* Better default GC settings (see #329 and #333). +* Various performance improvements (see #322 and #384). +* Improvements to hover information (see #317 and #338). +* Support GHC 8.8.2 (see #355). +* Include keywords in completions (see #351). +* Fix some issues with aborted requests (see #353). +* Use hie-bios 0.4.0 (see #382). +* Avoid stuck progress reporting (see #400). +* Only show progress notifications after 0.1s (see #392). +* Progress reporting is now in terms of the number of files rather + than the number of shake rules (see #379). + +### 0.0.6 (2020-01-10) + +* Fix type in hover information for do-notation and list + comprehensions (see #243). +* Fix hover and goto-definition for multi-clause definitions (see #252). +* Upgrade to `hie-bios-0.3` (see #257) +* Upgrade to `haskell-lsp-0.19` (see #254) +* Code lenses for missing signatures are displayed even if the warning + has not been enabled. The warning itself will not be shown if it is + not enabled. (see #232) +* Define `__GHCIDE__` when running CPP to allow for `ghcide`-specific + workarounds. (see #264) +* Fix some filepath normalization issues. (see #266) +* Fix build with `shake-0.18.4` (see #272) +* Fix hover for type constructors and type classes. (see #267) +* Support custom preprocessors (see #282) +* Add support for code completions (see #227) +* Code action for removing redundant symbols from imports (see #290) +* Support document symbol requests (see #293) +* Show CPP errors as diagnostics (see #296) +* Code action for adding suggested imports (see #295) + +### 0.0.5 (2019-12-12) + +* Support for GHC plugins (see #192) +* Update to haskell-lsp 0.18 (see #203) +* Initial support for `TemplateHaskell` (see #222) +* Code lenses for missing signatures. These are only shown if + `-Wmissing-signatures` is enabled. (see #224) +* Fix path normalisation on Windows (see #225) +* Fix flickering of the progress indicator (see #230) + +### 0.0.4 (2019-10-20) + +* Add a ``--version`` cli option (thanks @jacg) +* Update to use progress reporting as defined in LSP 3.15. The VSCode + extension has also been updated and should now be making use of + this. +* Properly declare that we should support code actions. This helps + with some clients that rely on this information to enable code + actions (thanks @jacg). +* Fix a race condition caused by sharing the finder cache between + concurrent compilations. +* Avoid normalizing include dirs. This avoids issues where the same + file ends up twice in the module graph, e.g., with different casing + for drive letters. + +### 0.0.3 (2019-09-21) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,201 +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 2019 Digital Asset (Switzerland) GmbH and/or its affiliates - - 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. + 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 2019 Digital Asset (Switzerland) GmbH and/or its affiliates + + 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 --- a/README.md +++ b/README.md @@ -1,358 +1,358 @@ -# `ghcide` - A library for building Haskell IDE tooling - -Our vision is that you should build an IDE by combining: - -![vscode](https://raw.githubusercontent.com/haskell/ghcide/master/img/vscode2.png) - -* [`hie-bios`](https://github.com/mpickering/hie-bios) for determining where your files are, what are their dependencies, what extensions are enabled and so on; -* `ghcide` (i.e. this library) for defining how to type check, when to type check, and producing diagnostic messages; -* A bunch of plugins that haven't yet been written, e.g. [`hie-hlint`](https://github.com/ndmitchell/hlint) and [`hie-ormolu`](https://github.com/tweag/ormolu), to choose which features you want; -* [`haskell-lsp`](https://github.com/alanz/haskell-lsp) for sending those messages to a [Language Server Protocol (LSP)](https://microsoft.github.io/language-server-protocol/) server; -* An LSP client for your editor. - -There are more details about our approach [in this blog post](https://4ta.uk/p/shaking-up-the-ide). - -## Features - -`ghcide` already exports the following features via the lsp protocol: - -| Feature | LSP name | -| - | - | -| Display error messages (parse errors, typecheck errors, etc.) and enabled warnings. | diagnostics | -| Go to definition in local package | definition | -| Display type and source module of values | hover | -| Remove redundant imports, replace suggested typos for values and module imports, fill type holes, insert missing type signatures, add suggested ghc extensions | codeAction (quickfix) | - - -## Limitations to Multi-Component support - -`ghcide` supports loading multiple components into the same session so that -features such as go-to definition work across components. However, there are -some limitations to this. - -1. You will get much better results currently manually specifying the hie.yaml file. -Until tools like cabal and stack provide the right interface to support multi-component -projects, it is always advised to specify explicitly how your project partitions. -2. Cross-component features only work if you have loaded at least one file -from each component. -3. There is a known issue where if you have three components, such that A depends on B which depends on C -then if you load A and C into the session but not B then under certain situations you -can get strange errors about a type coming from two different places. See [this repo](https://github.com/fendor/ghcide-bad-interface-files) for -a simple reproduction of the bug. - -## Using it - -`ghcide` is not an end-user tool, [don't use `ghcide`](https://neilmitchell.blogspot.com/2020/09/dont-use-ghcide-anymore-directly.html) directly (more about the rationale [here](https://github.com/haskell/ghcide/pull/939)). - - [`haskell-language-server`](http://github.com/haskell/haskell-language-server) is an LSP server built on top of `ghcide` with additional features and a user friendly deployment model. To get it, simply install the [Haskell extension](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) in VS Code, or download prebuilt binaries from the [haskell-language-server](https://github.com/haskell/haskell-language-server) project page. - - -The instructions below are meant for developers interested in setting up ghcide as an LSP server for testing purposes. - -### Install `ghcide` - -#### With Nix - -Note that you need to compile `ghcide` with the same `ghc` as the project you are working on. - -1. If the `ghc` you are using matches the version (or better is) from `nixpkgs` it‘s easiest to use the `ghcide` from `nixpkgs`. You can do so via - ``` - nix-env -iA haskellPackages.ghcide - ``` - or e.g. including `pkgs.haskellPackages.ghcide` in your projects `shell.nix`. - Depending on your `nixpkgs` channel that might not be the newest `ghcide`, though. - -2. If your `ghc` does not match nixpkgs you should try the [ghcide-nix repository](https://github.com/cachix/ghcide-nix) - which provides a `ghcide` via the `haskell.nix` infrastructure. - -#### With Cabal or Stack - -First install the `ghcide` binary using `stack` or `cabal`, e.g. - -1. `git clone https://github.com/haskell/ghcide.git` -2. `cd ghcide` -3. `cabal install` or `stack install` (and make sure `~/.local/bin` is on your `$PATH`) - -It's important that `ghcide` is compiled with the same compiler you use to build your projects. - -### Test `ghcide` - -Next, check that `ghcide` is capable of loading your code. Change to the project directory and run `ghcide`, which will try and load everything using the same code as the IDE, but in a way that's much easier to understand. For example, taking the example of [`shake`](https://github.com/ndmitchell/shake), running `ghcide` gives some error messages and warnings before reporting at the end: - -```console -Files that failed: - * .\model\Main.hs - * .\model\Model.hs - * .\model\Test.hs - * .\model\Util.hs - * .\output\docs\Main.hs - * .\output\docs\Part_Architecture_md.hs -Completed (152 worked, 6 failed) -``` - -Of the 158 files in Shake, as of this moment, 152 can be loaded by the IDE, but 6 can't (error messages for the reasons they can't be loaded are given earlier). The failing files are all prototype work or test output, meaning I can confidently use Shake. - -The `ghcide` executable mostly relies on [`hie-bios`](https://github.com/mpickering/hie-bios) to do the difficult work of setting up your GHC environment. If it doesn't work, see [the `hie-bios` manual](https://github.com/mpickering/hie-bios#readme) to get it working. My default fallback is to figure it out by hand and create a `direct` style [`hie.yaml`](https://github.com/ndmitchell/shake/blob/master/hie.yaml) listing the command line arguments to load the project. - -If you can't get `ghcide` working outside the editor, see [this setup troubleshooting guide](docs/Setup.md). Once you have got `ghcide` working outside the editor, the next step is to pick which editor to integrate with. - -### Optimal project setup - -`ghcide` has been designed to handle projects with hundreds or thousands of modules. If `ghci` can handle it, then `ghcide` should be able to handle it. The only caveat is that this currently requires GHC >= 8.6, and that the first time a module is loaded in the editor will trigger generation of support files in the background if those do not already exist. - -### Configuration - -`ghcide` accepts the following lsp configuration options: - -```typescript -{ - // When to check the dependents of a module - // AlwaysCheck means retypechecking them on every change - // CheckOnSave means dependent/parent modules will only be checked when you save - // "CheckOnSaveAndClose" by default - checkParents : "NeverCheck" | "CheckOnClose" | "CheckOnSaveAndClose" | "AlwaysCheck" | , - // Whether to check the entire project on initial load - // true by default - checkProject : boolean - -} -``` - -### Using with VS Code - -The [Haskell](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) extension has a setting for ghcide. - -### Using with Atom - -You can follow the [instructions](https://github.com/moodmosaic/ide-haskell-ghcide#readme) to install with `apm`. - -### Using with Sublime Text - -* Install [LSP](https://packagecontrol.io/packages/LSP) -* Press Ctrl+Shift+P or Cmd+Shift+P in Sublime Text and search for *Preferences: LSP Settings*, then paste these settings -``` -{ - "clients": - { - "ghcide": - { - "enabled" : true, - "languageId": "haskell", - "command" : ["ghcide", "--lsp"], - "scopes" : ["source.haskell"], - "syntaxes" : ["Packages/Haskell/Haskell.sublime-syntax"] - } - } -} -``` - -### Using with Emacs - -If you don't already have [MELPA](https://melpa.org/#/) package installation configured, visit MELPA [getting started](https://melpa.org/#/getting-started) page to get set up. Then, install [`use-package`](https://melpa.org/#/use-package). - -Now you have a choice of two different Emacs packages which can be used to communicate with the `ghcide` LSP server: - -+ `lsp-ui` -+ `eglot` (requires Emacs 26.1+) - -In each case, you can enable support by adding the shown lines to your `.emacs`: - -#### lsp-ui - -```elisp -;; LSP -(use-package flycheck - :ensure t - :init - (global-flycheck-mode t)) -(use-package yasnippet - :ensure t) -(use-package lsp-mode - :ensure t - :hook (haskell-mode . lsp) - :commands lsp) -(use-package lsp-ui - :ensure t - :commands lsp-ui-mode) -(use-package lsp-haskell - :ensure t - :config - (setq lsp-haskell-process-path-hie "ghcide") - (setq lsp-haskell-process-args-hie '()) - ;; Comment/uncomment this line to see interactions between lsp client/server. - ;;(setq lsp-log-io t) -) -``` - -#### eglot - -````elisp -(use-package eglot - :ensure t - :config - (add-to-list 'eglot-server-programs '(haskell-mode . ("ghcide" "--lsp")))) -```` - -### Using with Vim/Neovim - -#### LanguageClient-neovim -Install [LanguageClient-neovim](https://github.com/autozimu/LanguageClient-neovim) - -Add this to your vim config: -```vim -let g:LanguageClient_rootMarkers = ['*.cabal', 'stack.yaml'] -let g:LanguageClient_serverCommands = { - \ 'rust': ['rls'], - \ 'haskell': ['ghcide', '--lsp'], - \ } -``` - -Refer to `:he LanguageClient` for more details on usage and configuration. - -#### vim-lsp -Install [vim-lsp](https://github.com/prabirshrestha/vim-lsp). - -Add this to your vim config: - -```vim -au User lsp_setup call lsp#register_server({ - \ 'name': 'ghcide', - \ 'cmd': {server_info->['/your/path/to/ghcide', '--lsp']}, - \ 'whitelist': ['haskell'], - \ }) -``` - -To verify it works move your cursor over a symbol and run `:LspHover`. - -### coc.nvim - -Install [coc.nvim](https://github.com/neoclide/coc.nvim) - -Add this to your coc-settings.json (which you can edit with :CocConfig): - -```json -{ - "languageserver": { - "haskell": { - "command": "ghcide", - "args": [ - "--lsp" - ], - "rootPatterns": [ - ".stack.yaml", - ".hie-bios", - "BUILD.bazel", - "cabal.config", - "package.yaml" - ], - "filetypes": [ - "hs", - "lhs", - "haskell" - ] - } - } -} -``` - -Here's a nice article on setting up neovim and coc: [Vim and Haskell in -2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/) (this is actually for haskell-ide, not ghcide) - -Here is a Docker container that pins down the build and configuration for -Neovim and ghcide on a minimal Debian 10 base system: -[docker-ghcide-neovim](https://github.com/carlohamalainen/docker-ghcide-neovim/). - -### SpaceVim - -In the `autocomplete` layer, add the `autocomplete_method` option to force the use of `coc`: - -```toml -[[layers]] - name = 'autocomplete' - auto-completion-return-key-behavior = "complete" - auto-completion-tab-key-behavior = "smart" - [options] - autocomplete_method = "coc" -``` - -Add this to your coc-settings.json (which you can edit with :CocConfig): - -```json -{ - "languageserver": { - "haskell": { - "command": "ghcide", - "args": [ - "--lsp" - ], - "rootPatterns": [ - ".stack.yaml", - ".hie-bios", - "BUILD.bazel", - "cabal.config", - "package.yaml" - ], - "filetypes": [ - "hs", - "lhs", - "haskell" - ] - } - } -} -``` - -This example above describes a setup in which `ghcide` is installed -using `stack install ghcide` within a project. - -### Using with Kakoune - -Install [kak-lsp](https://github.com/ul/kak-lsp). - -Change `kak-lsp.toml` to include this: - -```toml -[language.haskell] -filetypes = ["haskell"] -roots = ["Setup.hs", "stack.yaml", "*.cabal", "cabal.project", "hie.yaml"] -command = "ghcide" -args = ["--lsp"] -``` - -## Hacking on ghcide - -To build and work on `ghcide` itself, you should use cabal, e.g., -running `cabal test` will execute the test suite. You can use `stack test` too, but -note that some tests will fail, and none of the maintainers are currently using `stack`. - -If you are using Nix, there is a Cachix nix-shell cache for all the supported platforms: `cachix use haskell-ghcide`. - -If you are using Windows, you should disable the `auto.crlf` setting and configure your editor to use LF line endings, directly or making it use the existing `.editor-config`. - -If you are chasing down test failures, you can use the tasty-rerun feature by running tests as - - cabal test --test-options"--rerun" - -This writes a log file called `.tasty-rerun-log` of the failures, and only runs those. -See the [tasty-rerun](https://hackage.haskell.org/package/tasty-rerun-1.1.17/docs/Test-Tasty-Ingredients-Rerun.html) documentation for other options. - -If you are touching performance sensitive code, take the time to run a differential -benchmark between HEAD and master using the benchHist script. This assumes that -"master" points to the upstream master. - -Run the benchmarks with `cabal bench`. - -It should take around 15 minutes and the results will be stored in the `bench-results` folder. To interpret the results, see the comments in the `bench/hist/Main.hs` module. - -More details in [bench/README](bench/README.md) - - -## History and relationship to other Haskell IDE's - -The teams behind this project and the [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme) have agreed to join forces under the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server), see the [original announcement](https://neilmitchell.blogspot.com/2020/01/one-haskell-ide-to-rule-them-all.html). The technical work is ongoing, with the likely model being that this project serves as the core, while plugins and integrations are kept in the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server). - -The code behind `ghcide` was originally developed by [Digital Asset](https://digitalasset.com/) as part of the [DAML programming language](https://github.com/digital-asset/daml). DAML is a smart contract language targeting distributed-ledger runtimes, based on [GHC](https://www.haskell.org/ghc/) with custom language extensions. The DAML programming language has [an IDE](https://webide.daml.com/), and work was done to separate off a reusable Haskell-only IDE (what is now `ghcide`) which the [DAML IDE then builds upon](https://github.com/digital-asset/daml/tree/master/compiler/damlc). Since that time, there have been various [non-Digital Asset contributors](https://github.com/haskell/ghcide/graphs/contributors), in addition to continued investment by Digital Asset. The project has been handed over to Haskell.org as of September 2020. - -The Haskell community [has](https://github.com/DanielG/ghc-mod) [various](https://github.com/chrisdone/intero) [IDE](https://github.com/rikvdkleij/intellij-haskell) [choices](http://leksah.org/), but the one that had been gathering momentum is [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme). Our project owes a debt of gratitude to the `haskell-ide-engine`. We reuse libraries from their ecosystem, including [`hie-bios`](https://github.com/mpickering/hie-bios#readme) (a likely future environment setup layer in `haskell-ide-engine`), [`haskell-lsp`](https://github.com/alanz/haskell-lsp#readme) and [`lsp-test`](https://github.com/bubba/lsp-test#readme) (the `haskell-ide-engine` [LSP protocol](https://microsoft.github.io/language-server-protocol/) pieces). We make heavy use of their contributions to GHC itself, in particular the work to make GHC take string buffers rather than files. - -The best summary of the architecture of `ghcide` is available [this talk](https://www.youtube.com/watch?v=cijsaeWNf2E&list=PLxxF72uPfQVRdAsvj7THoys-nVj-oc4Ss) ([slides](https://ndmitchell.com/downloads/slides-making_a_haskell_ide-07_sep_2019.pdf)), given at [MuniHac 2019](https://munihac.de/2019.html). However, since that talk the project has renamed from `hie-core` to `ghcide`, and the repo has moved to [this location](https://github.com/haskell/ghcide/). +# `ghcide` - A library for building Haskell IDE tooling + +Our vision is that you should build an IDE by combining: + +![vscode](https://raw.githubusercontent.com/haskell/ghcide/master/img/vscode2.png) + +* [`hie-bios`](https://github.com/mpickering/hie-bios) for determining where your files are, what are their dependencies, what extensions are enabled and so on; +* `ghcide` (i.e. this library) for defining how to type check, when to type check, and producing diagnostic messages; +* A bunch of plugins that haven't yet been written, e.g. [`hie-hlint`](https://github.com/ndmitchell/hlint) and [`hie-ormolu`](https://github.com/tweag/ormolu), to choose which features you want; +* [`haskell-lsp`](https://github.com/alanz/haskell-lsp) for sending those messages to a [Language Server Protocol (LSP)](https://microsoft.github.io/language-server-protocol/) server; +* An LSP client for your editor. + +There are more details about our approach [in this blog post](https://4ta.uk/p/shaking-up-the-ide). + +## Features + +`ghcide` already exports the following features via the lsp protocol: + +| Feature | LSP name | +| - | - | +| Display error messages (parse errors, typecheck errors, etc.) and enabled warnings. | diagnostics | +| Go to definition in local package | definition | +| Display type and source module of values | hover | +| Remove redundant imports, replace suggested typos for values and module imports, fill type holes, insert missing type signatures, add suggested ghc extensions | codeAction (quickfix) | + + +## Limitations to Multi-Component support + +`ghcide` supports loading multiple components into the same session so that +features such as go-to definition work across components. However, there are +some limitations to this. + +1. You will get much better results currently manually specifying the hie.yaml file. +Until tools like cabal and stack provide the right interface to support multi-component +projects, it is always advised to specify explicitly how your project partitions. +2. Cross-component features only work if you have loaded at least one file +from each component. +3. There is a known issue where if you have three components, such that A depends on B which depends on C +then if you load A and C into the session but not B then under certain situations you +can get strange errors about a type coming from two different places. See [this repo](https://github.com/fendor/ghcide-bad-interface-files) for +a simple reproduction of the bug. + +## Using it + +`ghcide` is not an end-user tool, [don't use `ghcide`](https://neilmitchell.blogspot.com/2020/09/dont-use-ghcide-anymore-directly.html) directly (more about the rationale [here](https://github.com/haskell/ghcide/pull/939)). + + [`haskell-language-server`](http://github.com/haskell/haskell-language-server) is an LSP server built on top of `ghcide` with additional features and a user friendly deployment model. To get it, simply install the [Haskell extension](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) in VS Code, or download prebuilt binaries from the [haskell-language-server](https://github.com/haskell/haskell-language-server) project page. + + +The instructions below are meant for developers interested in setting up ghcide as an LSP server for testing purposes. + +### Install `ghcide` + +#### With Nix + +Note that you need to compile `ghcide` with the same `ghc` as the project you are working on. + +1. If the `ghc` you are using matches the version (or better is) from `nixpkgs` it‘s easiest to use the `ghcide` from `nixpkgs`. You can do so via + ``` + nix-env -iA haskellPackages.ghcide + ``` + or e.g. including `pkgs.haskellPackages.ghcide` in your projects `shell.nix`. + Depending on your `nixpkgs` channel that might not be the newest `ghcide`, though. + +2. If your `ghc` does not match nixpkgs you should try the [ghcide-nix repository](https://github.com/cachix/ghcide-nix) + which provides a `ghcide` via the `haskell.nix` infrastructure. + +#### With Cabal or Stack + +First install the `ghcide` binary using `stack` or `cabal`, e.g. + +1. `git clone https://github.com/haskell/ghcide.git` +2. `cd ghcide` +3. `cabal install` or `stack install` (and make sure `~/.local/bin` is on your `$PATH`) + +It's important that `ghcide` is compiled with the same compiler you use to build your projects. + +### Test `ghcide` + +Next, check that `ghcide` is capable of loading your code. Change to the project directory and run `ghcide`, which will try and load everything using the same code as the IDE, but in a way that's much easier to understand. For example, taking the example of [`shake`](https://github.com/ndmitchell/shake), running `ghcide` gives some error messages and warnings before reporting at the end: + +```console +Files that failed: + * .\model\Main.hs + * .\model\Model.hs + * .\model\Test.hs + * .\model\Util.hs + * .\output\docs\Main.hs + * .\output\docs\Part_Architecture_md.hs +Completed (152 worked, 6 failed) +``` + +Of the 158 files in Shake, as of this moment, 152 can be loaded by the IDE, but 6 can't (error messages for the reasons they can't be loaded are given earlier). The failing files are all prototype work or test output, meaning I can confidently use Shake. + +The `ghcide` executable mostly relies on [`hie-bios`](https://github.com/mpickering/hie-bios) to do the difficult work of setting up your GHC environment. If it doesn't work, see [the `hie-bios` manual](https://github.com/mpickering/hie-bios#readme) to get it working. My default fallback is to figure it out by hand and create a `direct` style [`hie.yaml`](https://github.com/ndmitchell/shake/blob/master/hie.yaml) listing the command line arguments to load the project. + +If you can't get `ghcide` working outside the editor, see [this setup troubleshooting guide](docs/Setup.md). Once you have got `ghcide` working outside the editor, the next step is to pick which editor to integrate with. + +### Optimal project setup + +`ghcide` has been designed to handle projects with hundreds or thousands of modules. If `ghci` can handle it, then `ghcide` should be able to handle it. The only caveat is that this currently requires GHC >= 8.6, and that the first time a module is loaded in the editor will trigger generation of support files in the background if those do not already exist. + +### Configuration + +`ghcide` accepts the following lsp configuration options: + +```typescript +{ + // When to check the dependents of a module + // AlwaysCheck means retypechecking them on every change + // CheckOnSave means dependent/parent modules will only be checked when you save + // "CheckOnSaveAndClose" by default + checkParents : "NeverCheck" | "CheckOnClose" | "CheckOnSaveAndClose" | "AlwaysCheck" | , + // Whether to check the entire project on initial load + // true by default + checkProject : boolean + +} +``` + +### Using with VS Code + +The [Haskell](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) extension has a setting for ghcide. + +### Using with Atom + +You can follow the [instructions](https://github.com/moodmosaic/ide-haskell-ghcide#readme) to install with `apm`. + +### Using with Sublime Text + +* Install [LSP](https://packagecontrol.io/packages/LSP) +* Press Ctrl+Shift+P or Cmd+Shift+P in Sublime Text and search for *Preferences: LSP Settings*, then paste these settings +``` +{ + "clients": + { + "ghcide": + { + "enabled" : true, + "languageId": "haskell", + "command" : ["ghcide", "--lsp"], + "scopes" : ["source.haskell"], + "syntaxes" : ["Packages/Haskell/Haskell.sublime-syntax"] + } + } +} +``` + +### Using with Emacs + +If you don't already have [MELPA](https://melpa.org/#/) package installation configured, visit MELPA [getting started](https://melpa.org/#/getting-started) page to get set up. Then, install [`use-package`](https://melpa.org/#/use-package). + +Now you have a choice of two different Emacs packages which can be used to communicate with the `ghcide` LSP server: + ++ `lsp-ui` ++ `eglot` (requires Emacs 26.1+) + +In each case, you can enable support by adding the shown lines to your `.emacs`: + +#### lsp-ui + +```elisp +;; LSP +(use-package flycheck + :ensure t + :init + (global-flycheck-mode t)) +(use-package yasnippet + :ensure t) +(use-package lsp-mode + :ensure t + :hook (haskell-mode . lsp) + :commands lsp) +(use-package lsp-ui + :ensure t + :commands lsp-ui-mode) +(use-package lsp-haskell + :ensure t + :config + (setq lsp-haskell-process-path-hie "ghcide") + (setq lsp-haskell-process-args-hie '()) + ;; Comment/uncomment this line to see interactions between lsp client/server. + ;;(setq lsp-log-io t) +) +``` + +#### eglot + +````elisp +(use-package eglot + :ensure t + :config + (add-to-list 'eglot-server-programs '(haskell-mode . ("ghcide" "--lsp")))) +```` + +### Using with Vim/Neovim + +#### LanguageClient-neovim +Install [LanguageClient-neovim](https://github.com/autozimu/LanguageClient-neovim) + +Add this to your vim config: +```vim +let g:LanguageClient_rootMarkers = ['*.cabal', 'stack.yaml'] +let g:LanguageClient_serverCommands = { + \ 'rust': ['rls'], + \ 'haskell': ['ghcide', '--lsp'], + \ } +``` + +Refer to `:he LanguageClient` for more details on usage and configuration. + +#### vim-lsp +Install [vim-lsp](https://github.com/prabirshrestha/vim-lsp). + +Add this to your vim config: + +```vim +au User lsp_setup call lsp#register_server({ + \ 'name': 'ghcide', + \ 'cmd': {server_info->['/your/path/to/ghcide', '--lsp']}, + \ 'whitelist': ['haskell'], + \ }) +``` + +To verify it works move your cursor over a symbol and run `:LspHover`. + +### coc.nvim + +Install [coc.nvim](https://github.com/neoclide/coc.nvim) + +Add this to your coc-settings.json (which you can edit with :CocConfig): + +```json +{ + "languageserver": { + "haskell": { + "command": "ghcide", + "args": [ + "--lsp" + ], + "rootPatterns": [ + ".stack.yaml", + ".hie-bios", + "BUILD.bazel", + "cabal.config", + "package.yaml" + ], + "filetypes": [ + "hs", + "lhs", + "haskell" + ] + } + } +} +``` + +Here's a nice article on setting up neovim and coc: [Vim and Haskell in +2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/) (this is actually for haskell-ide, not ghcide) + +Here is a Docker container that pins down the build and configuration for +Neovim and ghcide on a minimal Debian 10 base system: +[docker-ghcide-neovim](https://github.com/carlohamalainen/docker-ghcide-neovim/). + +### SpaceVim + +In the `autocomplete` layer, add the `autocomplete_method` option to force the use of `coc`: + +```toml +[[layers]] + name = 'autocomplete' + auto-completion-return-key-behavior = "complete" + auto-completion-tab-key-behavior = "smart" + [options] + autocomplete_method = "coc" +``` + +Add this to your coc-settings.json (which you can edit with :CocConfig): + +```json +{ + "languageserver": { + "haskell": { + "command": "ghcide", + "args": [ + "--lsp" + ], + "rootPatterns": [ + ".stack.yaml", + ".hie-bios", + "BUILD.bazel", + "cabal.config", + "package.yaml" + ], + "filetypes": [ + "hs", + "lhs", + "haskell" + ] + } + } +} +``` + +This example above describes a setup in which `ghcide` is installed +using `stack install ghcide` within a project. + +### Using with Kakoune + +Install [kak-lsp](https://github.com/ul/kak-lsp). + +Change `kak-lsp.toml` to include this: + +```toml +[language.haskell] +filetypes = ["haskell"] +roots = ["Setup.hs", "stack.yaml", "*.cabal", "cabal.project", "hie.yaml"] +command = "ghcide" +args = ["--lsp"] +``` + +## Hacking on ghcide + +To build and work on `ghcide` itself, you should use cabal, e.g., +running `cabal test` will execute the test suite. You can use `stack test` too, but +note that some tests will fail, and none of the maintainers are currently using `stack`. + +If you are using Nix, there is a Cachix nix-shell cache for all the supported platforms: `cachix use haskell-ghcide`. + +If you are using Windows, you should disable the `auto.crlf` setting and configure your editor to use LF line endings, directly or making it use the existing `.editor-config`. + +If you are chasing down test failures, you can use the tasty-rerun feature by running tests as + + cabal test --test-options"--rerun" + +This writes a log file called `.tasty-rerun-log` of the failures, and only runs those. +See the [tasty-rerun](https://hackage.haskell.org/package/tasty-rerun-1.1.17/docs/Test-Tasty-Ingredients-Rerun.html) documentation for other options. + +If you are touching performance sensitive code, take the time to run a differential +benchmark between HEAD and master using the benchHist script. This assumes that +"master" points to the upstream master. + +Run the benchmarks with `cabal bench`. + +It should take around 15 minutes and the results will be stored in the `bench-results` folder. To interpret the results, see the comments in the `bench/hist/Main.hs` module. + +More details in [bench/README](bench/README.md) + + +## History and relationship to other Haskell IDE's + +The teams behind this project and the [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme) have agreed to join forces under the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server), see the [original announcement](https://neilmitchell.blogspot.com/2020/01/one-haskell-ide-to-rule-them-all.html). The technical work is ongoing, with the likely model being that this project serves as the core, while plugins and integrations are kept in the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server). + +The code behind `ghcide` was originally developed by [Digital Asset](https://digitalasset.com/) as part of the [DAML programming language](https://github.com/digital-asset/daml). DAML is a smart contract language targeting distributed-ledger runtimes, based on [GHC](https://www.haskell.org/ghc/) with custom language extensions. The DAML programming language has [an IDE](https://webide.daml.com/), and work was done to separate off a reusable Haskell-only IDE (what is now `ghcide`) which the [DAML IDE then builds upon](https://github.com/digital-asset/daml/tree/master/compiler/damlc). Since that time, there have been various [non-Digital Asset contributors](https://github.com/haskell/ghcide/graphs/contributors), in addition to continued investment by Digital Asset. The project has been handed over to Haskell.org as of September 2020. + +The Haskell community [has](https://github.com/DanielG/ghc-mod) [various](https://github.com/chrisdone/intero) [IDE](https://github.com/rikvdkleij/intellij-haskell) [choices](http://leksah.org/), but the one that had been gathering momentum is [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme). Our project owes a debt of gratitude to the `haskell-ide-engine`. We reuse libraries from their ecosystem, including [`hie-bios`](https://github.com/mpickering/hie-bios#readme) (a likely future environment setup layer in `haskell-ide-engine`), [`haskell-lsp`](https://github.com/alanz/haskell-lsp#readme) and [`lsp-test`](https://github.com/bubba/lsp-test#readme) (the `haskell-ide-engine` [LSP protocol](https://microsoft.github.io/language-server-protocol/) pieces). We make heavy use of their contributions to GHC itself, in particular the work to make GHC take string buffers rather than files. + +The best summary of the architecture of `ghcide` is available [this talk](https://www.youtube.com/watch?v=cijsaeWNf2E&list=PLxxF72uPfQVRdAsvj7THoys-nVj-oc4Ss) ([slides](https://ndmitchell.com/downloads/slides-making_a_haskell_ide-07_sep_2019.pdf)), given at [MuniHac 2019](https://munihac.de/2019.html). However, since that talk the project has renamed from `hie-core` to `ghcide`, and the repo has moved to [this location](https://github.com/haskell/ghcide/). diff --git a/bench/exe/Main.hs b/bench/exe/Main.hs --- a/bench/exe/Main.hs +++ b/bench/exe/Main.hs @@ -1,59 +1,59 @@ -{- An automated benchmark built around the simple experiment described in: - - > https://neilmitchell.blogspot.com/2020/05/fixing-space-leaks-in-ghcide.html - - As an example project, it unpacks Cabal-3.2.0.0 in the local filesystem and - loads the module 'Distribution.Simple'. The rationale for this choice is: - - - It's convenient to download with `cabal unpack Cabal-3.2.0.0` - - It has very few dependencies, and all are already needed to build ghcide - - Distribution.Simple has 235 transitive module dependencies, so non trivial - - The experiments are sequences of lsp commands scripted using lsp-test. - A more refined approach would be to record and replay real IDE interactions, - once the replay functionality is available in lsp-test. - A more declarative approach would be to reuse ide-debug-driver: - - > https://github.com/digital-asset/daml/blob/master/compiler/damlc/ide-debug-driver/README.md - - The result of an experiment is a total duration in seconds after a preset - number of iterations. There is ample room for improvement: - - Statistical analysis to detect outliers and auto infer the number of iterations needed - - GC stats analysis (currently -S is printed as part of the experiment) - - Analyisis of performance over the commit history of the project - - How to run: - 1. `cabal exec cabal run ghcide-bench -- -- ghcide-bench-options` - 1. `stack build ghcide:ghcide-bench && stack exec ghcide-bench -- -- ghcide-bench-options` - - Note that the package database influences the response times of certain actions, - e.g. code actions, and therefore the two methods above do not necessarily - produce the same results. - - -} - -{-# LANGUAGE ImplicitParams #-} - -import Control.Exception.Safe -import Experiments -import Options.Applicative -import System.IO -import Control.Monad - -optsP :: Parser (Config, Bool) -optsP = (,) <$> configP <*> switch (long "no-clean") - -main :: IO () -main = do - hSetBuffering stdout LineBuffering - hSetBuffering stderr LineBuffering - (config, noClean) <- execParser $ info (optsP <**> helper) fullDesc - let ?config = config - - hPrint stderr config - - output "starting test" - - SetupResult{..} <- setup - - runBenchmarks experiments `finally` unless noClean cleanUp +{- An automated benchmark built around the simple experiment described in: + + > https://neilmitchell.blogspot.com/2020/05/fixing-space-leaks-in-ghcide.html + + As an example project, it unpacks Cabal-3.2.0.0 in the local filesystem and + loads the module 'Distribution.Simple'. The rationale for this choice is: + + - It's convenient to download with `cabal unpack Cabal-3.2.0.0` + - It has very few dependencies, and all are already needed to build ghcide + - Distribution.Simple has 235 transitive module dependencies, so non trivial + + The experiments are sequences of lsp commands scripted using lsp-test. + A more refined approach would be to record and replay real IDE interactions, + once the replay functionality is available in lsp-test. + A more declarative approach would be to reuse ide-debug-driver: + + > https://github.com/digital-asset/daml/blob/master/compiler/damlc/ide-debug-driver/README.md + + The result of an experiment is a total duration in seconds after a preset + number of iterations. There is ample room for improvement: + - Statistical analysis to detect outliers and auto infer the number of iterations needed + - GC stats analysis (currently -S is printed as part of the experiment) + - Analyisis of performance over the commit history of the project + + How to run: + 1. `cabal exec cabal run ghcide-bench -- -- ghcide-bench-options` + 1. `stack build ghcide:ghcide-bench && stack exec ghcide-bench -- -- ghcide-bench-options` + + Note that the package database influences the response times of certain actions, + e.g. code actions, and therefore the two methods above do not necessarily + produce the same results. + + -} + +{-# LANGUAGE ImplicitParams #-} + +import Control.Exception.Safe +import Control.Monad +import Experiments +import Options.Applicative +import System.IO + +optsP :: Parser (Config, Bool) +optsP = (,) <$> configP <*> switch (long "no-clean") + +main :: IO () +main = do + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + (config, noClean) <- execParser $ info (optsP <**> helper) fullDesc + let ?config = config + + hPrint stderr config + + output "starting test" + + SetupResult{..} <- setup + + runBenchmarks experiments `finally` unless noClean cleanUp diff --git a/bench/hist/Main.hs b/bench/hist/Main.hs --- a/bench/hist/Main.hs +++ b/bench/hist/Main.hs @@ -1,192 +1,192 @@ -{- Bench history - - A Shake script to analyze the performance of ghcide over the git history of the project - - Driven by a config file `bench/config.yaml` containing the list of Git references to analyze. - - Builds each one of them and executes a set of experiments using the ghcide-bench suite. - - The results of the benchmarks and the analysis are recorded in the file - system with the following structure: - - bench-results - ├── - │  ├── ghc.path - path to ghc used to build the binary - │  ├── ghcide - binary for this version - ├─ - │ ├── results.csv - aggregated results for all the versions - │ └── - │   ├── .gcStats.log - RTS -s output - │   ├── .csv - stats for the experiment - │   ├── .svg - Graph of bytes over elapsed time - │   ├── .diff.svg - idem, including the previous version - │   ├── .log - ghcide-bench output - │   └── results.csv - results of all the experiments for the example - ├── results.csv - aggregated results of all the experiments and versions - └── .svg - graph of bytes over elapsed time, for all the included versions - - For diff graphs, the "previous version" is the preceding entry in the list of versions - in the config file. A possible improvement is to obtain this info via `git rev-list`. - - To execute the script: - - > cabal/stack bench - - To build a specific analysis, enumerate the desired file artifacts - - > stack bench --ba "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg" - > cabal bench --benchmark-options "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg" - - -} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies#-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wno-orphans #-} - -import Data.Foldable (find) -import Data.Yaml (FromJSON (..), decodeFileThrow) -import Development.Benchmark.Rules -import Development.Shake -import Experiments.Types (Example, exampleToOptions) -import qualified Experiments.Types as E -import GHC.Generics (Generic) -import Numeric.Natural (Natural) -import Development.Shake.Classes -import System.Console.GetOpt -import Data.Maybe -import Control.Monad.Extra -import System.FilePath - - -configPath :: FilePath -configPath = "bench/config.yaml" - -configOpt :: OptDescr (Either String FilePath) -configOpt = Option [] ["config"] (ReqArg Right configPath) "config file" - --- | Read the config without dependency -readConfigIO :: FilePath -> IO (Config BuildSystem) -readConfigIO = decodeFileThrow - -instance IsExample Example where getExampleName = E.getExampleName -type instance RuleResult GetExample = Maybe Example -type instance RuleResult GetExamples = [Example] - -shakeOpts :: ShakeOptions -shakeOpts = - shakeOptions{shakeChange = ChangeModtimeAndDigestInput, shakeThreads = 0} - -main :: IO () -main = shakeArgsWith shakeOpts [configOpt] $ \configs wants -> pure $ Just $ do - let config = fromMaybe configPath $ listToMaybe configs - _configStatic <- createBuildSystem config - case wants of - [] -> want ["all"] - _ -> want wants - -ghcideBuildRules :: MkBuildRules BuildSystem -ghcideBuildRules = MkBuildRules findGhcForBuildSystem "ghcide" projectDepends buildGhcide - where - projectDepends = do - need . map ("src" ) =<< getDirectoryFiles "src" ["//*.hs"] - need . map ("session-loader" ) =<< getDirectoryFiles "session-loader" ["//*.hs"] - need =<< getDirectoryFiles "." ["*.cabal"] - --------------------------------------------------------------------------------- - -data Config buildSystem = Config - { experiments :: [Unescaped String], - examples :: [Example], - samples :: Natural, - versions :: [GitCommit], - -- | Output folder ('foo' works, 'foo/bar' does not) - outputFolder :: String, - buildTool :: buildSystem, - profileInterval :: Maybe Double - } - deriving (Generic, Show) - deriving anyclass (FromJSON) - -createBuildSystem :: FilePath -> Rules (Config BuildSystem ) -createBuildSystem config = do - readConfig <- newCache $ \fp -> need [fp] >> liftIO (readConfigIO fp) - - _ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config - _ <- addOracle $ \GetVersions {} -> versions <$> readConfig config - _ <- versioned 1 $ addOracle $ \GetExamples{} -> examples <$> readConfig config - _ <- versioned 1 $ addOracle $ \(GetExample name) -> find (\e -> getExampleName e == name) . examples <$> readConfig config - _ <- addOracle $ \GetBuildSystem {} -> buildTool <$> readConfig config - _ <- addOracle $ \GetSamples{} -> samples <$> readConfig config - - configStatic <- liftIO $ readConfigIO config - let build = outputFolder configStatic - - buildRules build ghcideBuildRules - benchRules build (MkBenchRules (askOracle $ GetSamples ()) benchGhcide warmupGhcide "ghcide") - csvRules build - svgRules build - heapProfileRules build - phonyRules "" "ghcide" NoProfiling build (examples configStatic) - - whenJust (profileInterval configStatic) $ \i -> do - phonyRules "profiled-" "ghcide" (CheapHeapProfiling i) build (examples configStatic) - - return configStatic - -newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show) -type instance RuleResult GetSamples = Natural - --------------------------------------------------------------------------------- - -buildGhcide :: BuildSystem -> [CmdOption] -> FilePath -> Action () -buildGhcide Cabal args out = do - command_ args "cabal" - ["install" - ,"exe:ghcide" - ,"--installdir=" ++ out - ,"--install-method=copy" - ,"--overwrite-policy=always" - ,"--ghc-options=-rtsopts" - ,"--ghc-options=-eventlog" - ] - -buildGhcide Stack args out = - command_ args "stack" - ["--local-bin-path=" <> out - ,"build" - ,"ghcide:ghcide" - ,"--copy-bins" - ,"--ghc-options=-rtsopts" - ,"--ghc-options=-eventlog" - ] - -benchGhcide - :: Natural -> BuildSystem -> [CmdOption] -> BenchProject Example -> Action () -benchGhcide samples buildSystem args BenchProject{..} = do - command_ args "ghcide-bench" $ - [ "--timeout=300", - "--no-clean", - "-v", - "--samples=" <> show samples, - "--csv=" <> outcsv, - "--ghcide=" <> exePath, - "--ghcide-options=" <> unwords exeExtraArgs, - "--select", - unescaped (unescapeExperiment experiment) - ] ++ - exampleToOptions example ++ - [ "--stack" | Stack == buildSystem - ] - -warmupGhcide :: BuildSystem -> FilePath -> [CmdOption] -> Example -> Action () -warmupGhcide buildSystem exePath args example = do - command args "ghcide-bench" $ - [ "--no-clean", - "-v", - "--samples=1", - "--ghcide=" <> exePath, - "--select=hover" - ] ++ - exampleToOptions example ++ - [ "--stack" | Stack == buildSystem - ] +{- Bench history + + A Shake script to analyze the performance of ghcide over the git history of the project + + Driven by a config file `bench/config.yaml` containing the list of Git references to analyze. + + Builds each one of them and executes a set of experiments using the ghcide-bench suite. + + The results of the benchmarks and the analysis are recorded in the file + system with the following structure: + + bench-results + ├── + │  ├── ghc.path - path to ghc used to build the binary + │  ├── ghcide - binary for this version + ├─ + │ ├── results.csv - aggregated results for all the versions + │ └── + │   ├── .gcStats.log - RTS -s output + │   ├── .csv - stats for the experiment + │   ├── .svg - Graph of bytes over elapsed time + │   ├── .diff.svg - idem, including the previous version + │   ├── .log - ghcide-bench output + │   └── results.csv - results of all the experiments for the example + ├── results.csv - aggregated results of all the experiments and versions + └── .svg - graph of bytes over elapsed time, for all the included versions + + For diff graphs, the "previous version" is the preceding entry in the list of versions + in the config file. A possible improvement is to obtain this info via `git rev-list`. + + To execute the script: + + > cabal/stack bench + + To build a specific analysis, enumerate the desired file artifacts + + > stack bench --ba "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg" + > cabal bench --benchmark-options "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg" + + -} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wno-orphans #-} + +import Control.Monad.Extra +import Data.Foldable (find) +import Data.Maybe +import Data.Yaml (FromJSON (..), decodeFileThrow) +import Development.Benchmark.Rules +import Development.Shake +import Development.Shake.Classes +import Experiments.Types (Example, exampleToOptions) +import qualified Experiments.Types as E +import GHC.Generics (Generic) +import Numeric.Natural (Natural) +import System.Console.GetOpt +import System.FilePath + + +configPath :: FilePath +configPath = "bench/config.yaml" + +configOpt :: OptDescr (Either String FilePath) +configOpt = Option [] ["config"] (ReqArg Right configPath) "config file" + +-- | Read the config without dependency +readConfigIO :: FilePath -> IO (Config BuildSystem) +readConfigIO = decodeFileThrow + +instance IsExample Example where getExampleName = E.getExampleName +type instance RuleResult GetExample = Maybe Example +type instance RuleResult GetExamples = [Example] + +shakeOpts :: ShakeOptions +shakeOpts = + shakeOptions{shakeChange = ChangeModtimeAndDigestInput, shakeThreads = 0} + +main :: IO () +main = shakeArgsWith shakeOpts [configOpt] $ \configs wants -> pure $ Just $ do + let config = fromMaybe configPath $ listToMaybe configs + _configStatic <- createBuildSystem config + case wants of + [] -> want ["all"] + _ -> want wants + +ghcideBuildRules :: MkBuildRules BuildSystem +ghcideBuildRules = MkBuildRules findGhcForBuildSystem "ghcide" projectDepends buildGhcide + where + projectDepends = do + need . map ("src" ) =<< getDirectoryFiles "src" ["//*.hs"] + need . map ("session-loader" ) =<< getDirectoryFiles "session-loader" ["//*.hs"] + need =<< getDirectoryFiles "." ["*.cabal"] + +-------------------------------------------------------------------------------- + +data Config buildSystem = Config + { experiments :: [Unescaped String], + examples :: [Example], + samples :: Natural, + versions :: [GitCommit], + -- | Output folder ('foo' works, 'foo/bar' does not) + outputFolder :: String, + buildTool :: buildSystem, + profileInterval :: Maybe Double + } + deriving (Generic, Show) + deriving anyclass (FromJSON) + +createBuildSystem :: FilePath -> Rules (Config BuildSystem ) +createBuildSystem config = do + readConfig <- newCache $ \fp -> need [fp] >> liftIO (readConfigIO fp) + + _ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config + _ <- addOracle $ \GetVersions {} -> versions <$> readConfig config + _ <- versioned 1 $ addOracle $ \GetExamples{} -> examples <$> readConfig config + _ <- versioned 1 $ addOracle $ \(GetExample name) -> find (\e -> getExampleName e == name) . examples <$> readConfig config + _ <- addOracle $ \GetBuildSystem {} -> buildTool <$> readConfig config + _ <- addOracle $ \GetSamples{} -> samples <$> readConfig config + + configStatic <- liftIO $ readConfigIO config + let build = outputFolder configStatic + + buildRules build ghcideBuildRules + benchRules build (MkBenchRules (askOracle $ GetSamples ()) benchGhcide warmupGhcide "ghcide") + csvRules build + svgRules build + heapProfileRules build + phonyRules "" "ghcide" NoProfiling build (examples configStatic) + + whenJust (profileInterval configStatic) $ \i -> do + phonyRules "profiled-" "ghcide" (CheapHeapProfiling i) build (examples configStatic) + + return configStatic + +newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show) +type instance RuleResult GetSamples = Natural + +-------------------------------------------------------------------------------- + +buildGhcide :: BuildSystem -> [CmdOption] -> FilePath -> Action () +buildGhcide Cabal args out = do + command_ args "cabal" + ["install" + ,"exe:ghcide" + ,"--installdir=" ++ out + ,"--install-method=copy" + ,"--overwrite-policy=always" + ,"--ghc-options=-rtsopts" + ,"--ghc-options=-eventlog" + ] + +buildGhcide Stack args out = + command_ args "stack" + ["--local-bin-path=" <> out + ,"build" + ,"ghcide:ghcide" + ,"--copy-bins" + ,"--ghc-options=-rtsopts" + ,"--ghc-options=-eventlog" + ] + +benchGhcide + :: Natural -> BuildSystem -> [CmdOption] -> BenchProject Example -> Action () +benchGhcide samples buildSystem args BenchProject{..} = do + command_ args "ghcide-bench" $ + [ "--timeout=300", + "--no-clean", + "-v", + "--samples=" <> show samples, + "--csv=" <> outcsv, + "--ghcide=" <> exePath, + "--ghcide-options=" <> unwords exeExtraArgs, + "--select", + unescaped (unescapeExperiment experiment) + ] ++ + exampleToOptions example ++ + [ "--stack" | Stack == buildSystem + ] + +warmupGhcide :: BuildSystem -> FilePath -> [CmdOption] -> Example -> Action () +warmupGhcide buildSystem exePath args example = do + command args "ghcide-bench" $ + [ "--no-clean", + "-v", + "--samples=1", + "--ghcide=" <> exePath, + "--select=hover" + ] ++ + exampleToOptions example ++ + [ "--stack" | Stack == buildSystem + ] diff --git a/bench/lib/Experiments.hs b/bench/lib/Experiments.hs --- a/bench/lib/Experiments.hs +++ b/bench/lib/Experiments.hs @@ -1,573 +1,574 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE ImpredicativeTypes #-} -{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} - -module Experiments -( Bench(..) -, BenchRun(..) -, Config(..) -, Verbosity(..) -, CabalStack(..) -, SetupResult(..) -, Example(..) -, experiments -, configP -, defConfig -, output -, setup -, runBench -, exampleToOptions -) where -import Control.Applicative.Combinators (skipManyTill) -import Control.Exception.Safe (IOException, handleAny, try) -import Control.Monad.Extra -import Control.Monad.IO.Class -import Data.Aeson (Value(Null), toJSON) -import Data.List -import Data.Maybe -import qualified Data.Text as T -import Data.Version -import Development.IDE.Plugin.Test -import Experiments.Types -import Language.LSP.Test -import Language.LSP.Types -import Language.LSP.Types.Capabilities -import Numeric.Natural -import Options.Applicative -import System.Directory -import System.Environment.Blank (getEnv) -import System.FilePath ((), (<.>)) -import System.Process -import System.Time.Extra -import Text.ParserCombinators.ReadP (readP_to_S) -import Development.Shake (cmd_, CmdOption (Cwd, FileStdout)) - -charEdit :: Position -> TextDocumentContentChangeEvent -charEdit p = - TextDocumentContentChangeEvent - { _range = Just (Range p p), - _rangeLength = Nothing, - _text = "a" - } - -data DocumentPositions = DocumentPositions { - identifierP :: Maybe Position, - stringLiteralP :: !Position, - doc :: !TextDocumentIdentifier -} - -allWithIdentifierPos :: Monad m => (DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool -allWithIdentifierPos f docs = allM f (filter (isJust . identifierP) docs) - -experiments :: [Bench] -experiments = - [ --------------------------------------------------------------------------------------- - bench "hover" $ allWithIdentifierPos $ \DocumentPositions{..} -> - isJust <$> getHover doc (fromJust identifierP), - --------------------------------------------------------------------------------------- - bench "edit" $ \docs -> do - forM_ docs $ \DocumentPositions{..} -> - changeDoc doc [charEdit stringLiteralP] - waitForProgressDone -- TODO check that this waits for all of them - return True, - --------------------------------------------------------------------------------------- - bench "hover after edit" $ \docs -> do - forM_ docs $ \DocumentPositions{..} -> - changeDoc doc [charEdit stringLiteralP] - flip allWithIdentifierPos docs $ \DocumentPositions{..} -> - isJust <$> getHover doc (fromJust identifierP), - --------------------------------------------------------------------------------------- - bench "getDefinition" $ allWithIdentifierPos $ \DocumentPositions{..} -> - either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP), - --------------------------------------------------------------------------------------- - bench "getDefinition after edit" $ \docs -> do - forM_ docs $ \DocumentPositions{..} -> - changeDoc doc [charEdit stringLiteralP] - flip allWithIdentifierPos docs $ \DocumentPositions{..} -> - either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP), - --------------------------------------------------------------------------------------- - bench "documentSymbols" $ allM $ \DocumentPositions{..} -> do - fmap (either (not . null) (not . null)) . getDocumentSymbols $ doc, - --------------------------------------------------------------------------------------- - bench "documentSymbols after edit" $ \docs -> do - forM_ docs $ \DocumentPositions{..} -> - changeDoc doc [charEdit stringLiteralP] - flip allM docs $ \DocumentPositions{..} -> - either (not . null) (not . null) <$> getDocumentSymbols doc, - --------------------------------------------------------------------------------------- - bench "completions" $ \docs -> do - flip allWithIdentifierPos docs $ \DocumentPositions{..} -> - not . null <$> getCompletions doc (fromJust identifierP), - --------------------------------------------------------------------------------------- - bench "completions after edit" $ \docs -> do - forM_ docs $ \DocumentPositions{..} -> - changeDoc doc [charEdit stringLiteralP] - flip allWithIdentifierPos docs $ \DocumentPositions{..} -> - not . null <$> getCompletions doc (fromJust identifierP), - --------------------------------------------------------------------------------------- - benchWithSetup - "code actions" - ( \docs -> do - unless (any (isJust . identifierP) docs) $ - error "None of the example modules is suitable for this experiment" - forM_ docs $ \DocumentPositions{..} -> - forM_ identifierP $ \p -> changeDoc doc [charEdit p] - waitForProgressDone - ) - ( \docs -> not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> - forM identifierP $ \p -> - getCodeActions doc (Range p p)) - ), - --------------------------------------------------------------------------------------- - benchWithSetup - "code actions after edit" - ( \docs -> do - unless (any (isJust . identifierP) docs) $ - error "None of the example modules is suitable for this experiment" - forM_ docs $ \DocumentPositions{..} -> - forM_ identifierP $ \p -> changeDoc doc [charEdit p] - ) - ( \docs -> do - forM_ docs $ \DocumentPositions{..} -> - changeDoc doc [charEdit stringLiteralP] - waitForProgressDone - not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do - forM identifierP $ \p -> - getCodeActions doc (Range p p)) - ), - --------------------------------------------------------------------------------------- - benchWithSetup - "code actions after cradle edit" - ( \docs -> do - unless (any (isJust . identifierP) docs) $ - error "None of the example modules is suitable for this experiment" - forM_ docs $ \DocumentPositions{..} -> - forM_ identifierP $ \p -> changeDoc doc [charEdit p] - ) - ( \docs -> do - Just hieYaml <- uriToFilePath <$> getDocUri "hie.yaml" - liftIO $ appendFile hieYaml "##\n" - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [ FileEvent (filePathToUri "hie.yaml") FcChanged ] - forM_ docs $ \DocumentPositions{..} -> - changeDoc doc [charEdit stringLiteralP] - waitForProgressDone - not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do - forM identifierP $ \p -> - getCodeActions doc (Range p p)) - ), - --------------------------------------------------------------------------------------- - bench - "hover after cradle edit" - (\docs -> do - Just hieYaml <- uriToFilePath <$> getDocUri "hie.yaml" - liftIO $ appendFile hieYaml "##\n" - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [ FileEvent (filePathToUri "hie.yaml") FcChanged ] - flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP) - ) - ] - ---------------------------------------------------------------------------------------------- - -examplesPath :: FilePath -examplesPath = "bench/example" - -defConfig :: Config -Success defConfig = execParserPure defaultPrefs (info configP fullDesc) [] - -quiet, verbose :: Config -> Bool -verbose = (== All) . verbosity -quiet = (== Quiet) . verbosity - -type HasConfig = (?config :: Config) - -configP :: Parser Config -configP = - Config - <$> (flag' All (short 'v' <> long "verbose") - <|> flag' Quiet (short 'q' <> long "quiet") - <|> pure Normal - ) - <*> optional (strOption (long "shake-profiling" <> metavar "PATH")) - <*> optional (strOption (long "ot-profiling" <> metavar "DIR" <> help "Enable OpenTelemetry and write eventlog for each benchmark in DIR")) - <*> strOption (long "csv" <> metavar "PATH" <> value "results.csv" <> showDefault) - <*> flag Cabal Stack (long "stack" <> help "Use stack (by default cabal is used)") - <*> many (strOption (long "ghcide-options" <> help "additional options for ghcide")) - <*> many (strOption (short 's' <> long "select" <> help "select which benchmarks to run")) - <*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count")) - <*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide") - <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response") - <*> ( GetPackage <$> strOption (long "example-package-name" <> value "Cabal") - <*> (some moduleOption <|> pure ["Distribution/Simple.hs"]) - <*> option versionP (long "example-package-version" <> value (makeVersion [3,2,0,0])) - <|> - UsePackage <$> strOption (long "example-path") - <*> some moduleOption - ) - where - moduleOption = strOption (long "example-module" <> metavar "PATH") - -versionP :: ReadM Version -versionP = maybeReader $ extract . readP_to_S parseVersion - where - extract parses = listToMaybe [ res | (res,"") <- parses] - -output :: (MonadIO m, HasConfig) => String -> m () -output = if quiet?config then (\_ -> pure ()) else liftIO . putStrLn - ---------------------------------------------------------------------------------------- - -type Experiment = [DocumentPositions] -> Session Bool - -data Bench = - Bench - { name :: !String, - enabled :: !Bool, - samples :: !Natural, - benchSetup :: [DocumentPositions] -> Session (), - experiment :: Experiment - } - -select :: HasConfig => Bench -> Bool -select Bench {name, enabled} = - enabled && (null mm || name `elem` mm) - where - mm = matches ?config - -benchWithSetup :: - String -> - ([DocumentPositions] -> Session ()) -> - Experiment -> - Bench -benchWithSetup name benchSetup experiment = Bench {..} - where - enabled = True - samples = 100 - -bench :: String -> Experiment -> Bench -bench name = benchWithSetup name (const $ pure ()) - -runBenchmarksFun :: HasConfig => FilePath -> [Bench] -> IO () -runBenchmarksFun dir allBenchmarks = do - let benchmarks = [ b{samples = fromMaybe 100 (repetitions ?config) } - | b <- allBenchmarks - , select b ] - - whenJust (otMemoryProfiling ?config) $ \eventlogDir -> - createDirectoryIfMissing True eventlogDir - - results <- forM benchmarks $ \b@Bench{name} -> do - let run = runSessionWithConfig conf (cmd name dir) lspTestCaps dir - (b,) <$> runBench run b - - -- output raw data as CSV - let headers = - [ "name" - , "success" - , "samples" - , "startup" - , "setup" - , "userTime" - , "delayedTime" - , "totalTime" - ] - rows = - [ [ name, - show success, - show samples, - show startup, - show runSetup', - show userWaits, - show delayedWork, - show runExperiment - ] - | (Bench {name, samples}, BenchRun {..}) <- results, - let runSetup' = if runSetup < 0.01 then 0 else runSetup - ] - csv = unlines $ map (intercalate ", ") (headers : rows) - writeFile (outputCSV ?config) csv - - -- print a nice table - let pads = map (maximum . map length) (transpose (headers : rowsHuman)) - paddedHeaders = zipWith pad pads headers - outputRow = putStrLn . intercalate " | " - rowsHuman = - [ [ name, - show success, - show samples, - showDuration startup, - showDuration runSetup', - showDuration userWaits, - showDuration delayedWork, - showDuration runExperiment - ] - | (Bench {name, samples}, BenchRun {..}) <- results, - let runSetup' = if runSetup < 0.01 then 0 else runSetup - ] - outputRow paddedHeaders - outputRow $ (map . map) (const '-') paddedHeaders - forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row - where - ghcideCmd dir = - [ ghcide ?config, - "--lsp", - "--test", - "--cwd", - dir, - "+RTS" - ] - cmd name dir = - unwords $ - ghcideCmd dir - ++ case otMemoryProfiling ?config of - Just dir -> ["-l", "-ol" ++ (dir map (\c -> if c == ' ' then '-' else c) name <.> "eventlog")] - Nothing -> [] - ++ [ "-RTS" ] - ++ ghcideOptions ?config - ++ concat - [ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config] - ] - ++ ["--verbose" | verbose ?config] - ++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]] - lspTestCaps = - fullCaps {_window = Just $ WindowClientCapabilities $ Just True} - conf = - defaultConfig - { logStdErr = verbose ?config, - logMessages = verbose ?config, - logColor = False, - messageTimeout = timeoutLsp ?config - } - -data BenchRun = BenchRun - { startup :: !Seconds, - runSetup :: !Seconds, - runExperiment :: !Seconds, - userWaits :: !Seconds, - delayedWork :: !Seconds, - success :: !Bool - } - -badRun :: BenchRun -badRun = BenchRun 0 0 0 0 0 False - --- | Wait for all progress to be done --- Needs at least one progress done notification to return -waitForProgressDone :: Session () -waitForProgressDone = loop - where - loop = do - ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () - _ -> Nothing - done <- null <$> getIncompleteProgressSessions - unless done loop - -runBench :: - (?config :: Config) => - (Session BenchRun -> IO BenchRun) -> - Bench -> - IO BenchRun -runBench runSess b = handleAny (\e -> print e >> return badRun) - $ runSess - $ do - case b of - Bench{..} -> do - (startup, docs) <- duration $ do - (d, docs) <- duration $ setupDocumentContents ?config - output $ "Setting up document contents took " <> showDuration d - -- wait again, as the progress is restarted once while loading the cradle - -- make an edit, to ensure this doesn't block - let DocumentPositions{..} = head docs - changeDoc doc [charEdit stringLiteralP] - waitForProgressDone - return docs - - liftIO $ output $ "Running " <> name <> " benchmark" - (runSetup, ()) <- duration $ benchSetup docs - let loop !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork) - loop !userWaits !delayedWork n = do - (t, res) <- duration $ experiment docs - if not res - then return Nothing - else do - output (showDuration t) - -- Wait for the delayed actions to finish - let m = SCustomMethod "test" - waitId <- sendRequest m (toJSON WaitForShakeQueue) - (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId - case resp of - ResponseMessage{_result=Right Null} -> do - loop (userWaits+t) (delayedWork+td) (n -1) - _ -> - -- Assume a ghcide build lacking the WaitForShakeQueue command - loop (userWaits+t) delayedWork (n -1) - - (runExperiment, result) <- duration $ loop 0 0 samples - let success = isJust result - (userWaits, delayedWork) = fromMaybe (0,0) result - - return BenchRun {..} - -data SetupResult = SetupResult { - runBenchmarks :: [Bench] -> IO (), - -- | Path to the setup benchmark example - benchDir :: FilePath, - cleanUp :: IO () -} - -callCommandLogging :: HasConfig => String -> IO () -callCommandLogging cmd = do - output cmd - callCommand cmd - -setup :: HasConfig => IO SetupResult -setup = do --- when alreadyExists $ removeDirectoryRecursive examplesPath - benchDir <- case example ?config of - UsePackage{..} -> do - let hieYamlPath = examplePath "hie.yaml" - alreadyExists <- doesFileExist hieYamlPath - unless alreadyExists $ - cmd_ (Cwd examplePath) (FileStdout hieYamlPath) ("gen-hie"::String) - return examplePath - GetPackage{..} -> do - let path = examplesPath package - package = exampleName <> "-" <> showVersion exampleVersion - hieYamlPath = path "hie.yaml" - alreadySetup <- doesDirectoryExist path - unless alreadySetup $ - case buildTool ?config of - Cabal -> do - let cabalVerbosity = "-v" ++ show (fromEnum (verbose ?config)) - callCommandLogging $ "cabal get " <> cabalVerbosity <> " " <> package <> " -d " <> examplesPath - let hieYamlPath = path "hie.yaml" - cmd_ (Cwd path) (FileStdout hieYamlPath) ("gen-hie"::String) - -- Need this in case there is a parent cabal.project somewhere - writeFile - (path "cabal.project") - "packages: ." - writeFile - (path "cabal.project.local") - "" - Stack -> do - let stackVerbosity = case verbosity ?config of - Quiet -> "--silent" - Normal -> "" - All -> "--verbose" - callCommandLogging $ "stack " <> stackVerbosity <> " unpack " <> package <> " --to " <> examplesPath - -- Generate the stack descriptor to match the one used to build ghcide - stack_yaml <- fromMaybe "stack.yaml" <$> getEnv "STACK_YAML" - stack_yaml_lines <- lines <$> readFile stack_yaml - writeFile (path stack_yaml) - (unlines $ - "packages: [.]" : - [ l - | l <- stack_yaml_lines - , any (`isPrefixOf` l) - ["resolver" - ,"allow-newer" - ,"compiler"] - ] - ) - - cmd_ (Cwd path) (FileStdout hieYamlPath) ("gen-hie"::String) ["--stack"::String] - return path - - whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True - - let cleanUp = case example ?config of - GetPackage{} -> removeDirectoryRecursive examplesPath - UsePackage{} -> return () - - runBenchmarks = runBenchmarksFun benchDir - - return SetupResult{..} - -setupDocumentContents :: Config -> Session [DocumentPositions] -setupDocumentContents config = - forM (exampleModules $ example config) $ \m -> do - doc <- openDoc m "haskell" - - -- Setup the special positions used by the experiments - lastLine <- length . T.lines <$> documentContents doc - changeDoc doc [TextDocumentContentChangeEvent - { _range = Just (Range (Position lastLine 0) (Position lastLine 0)) - , _rangeLength = Nothing - , _text = T.unlines [ "_hygienic = \"hygienic\"" ] - }] - let - -- Points to a string in the target file, - -- convenient for hygienic edits - stringLiteralP = Position lastLine 15 - - -- Find an identifier defined in another file in this project - symbols <- getDocumentSymbols doc - let endOfImports = case symbols of - Left symbols | Just x <- findEndOfImports symbols -> x - _ -> error $ "symbols: " <> show symbols - contents <- documentContents doc - identifierP <- searchSymbol doc contents endOfImports - return $ DocumentPositions{..} - -findEndOfImports :: [DocumentSymbol] -> Maybe Position -findEndOfImports (DocumentSymbol{_kind = SkModule, _name = "imports", _range} : _) = - Just $ Position (succ $ _line $ _end _range) 4 -findEndOfImports [DocumentSymbol{_kind = SkFile, _children = Just (List cc)}] = - findEndOfImports cc -findEndOfImports (DocumentSymbol{_range} : _) = - Just $ _start _range -findEndOfImports _ = Nothing - --------------------------------------------------------------------------------------------- - -pad :: Int -> String -> String -pad n [] = replicate n ' ' -pad 0 _ = error "pad" -pad n (x:xx) = x : pad (n-1) xx - --- | Search for a position where: --- - get definition works and returns a uri other than this file --- - get completions returns a non empty list -searchSymbol :: TextDocumentIdentifier -> T.Text -> Position -> Session (Maybe Position) -searchSymbol doc@TextDocumentIdentifier{_uri} fileContents pos = do - -- this search is expensive, so we cache the result on disk - let cachedPath = fromJust (uriToFilePath _uri) <.> "identifierPosition" - cachedRes <- liftIO $ try @_ @IOException $ read <$> readFile cachedPath - case cachedRes of - Left _ -> do - result <- loop pos - liftIO $ writeFile cachedPath $ show result - return result - Right res -> - return res - where - loop pos - | _line pos >= lll = - return Nothing - | _character pos >= lengthOfLine (_line pos) = - loop (nextLine pos) - | otherwise = do - checks <- checkDefinitions pos &&^ checkCompletions pos - if checks - then return $ Just pos - else loop (nextIdent pos) - - nextIdent p = p{_character = _character p + 2} - nextLine p = Position (_line p + 1) 4 - - lengthOfLine n = if n >= lll then 0 else T.length (ll !! n) - ll = T.lines fileContents - lll = length ll - - checkDefinitions pos = do - defs <- getDefinitions doc pos - case defs of - (InL [Location uri _]) -> return $ uri /= _uri - _ -> return False - checkCompletions pos = - not . null <$> getCompletions doc pos +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} + +module Experiments +( Bench(..) +, BenchRun(..) +, Config(..) +, Verbosity(..) +, CabalStack(..) +, SetupResult(..) +, Example(..) +, experiments +, configP +, defConfig +, output +, setup +, runBench +, exampleToOptions +) where +import Control.Applicative.Combinators (skipManyTill) +import Control.Exception.Safe (IOException, handleAny, try) +import Control.Monad.Extra +import Control.Monad.IO.Class +import Data.Aeson (Value (Null), toJSON) +import Data.List +import Data.Maybe +import qualified Data.Text as T +import Data.Version +import Development.IDE.Plugin.Test +import Development.Shake (CmdOption (Cwd, FileStdout), + cmd_) +import Experiments.Types +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Capabilities +import Numeric.Natural +import Options.Applicative +import System.Directory +import System.Environment.Blank (getEnv) +import System.FilePath ((<.>), ()) +import System.Process +import System.Time.Extra +import Text.ParserCombinators.ReadP (readP_to_S) + +charEdit :: Position -> TextDocumentContentChangeEvent +charEdit p = + TextDocumentContentChangeEvent + { _range = Just (Range p p), + _rangeLength = Nothing, + _text = "a" + } + +data DocumentPositions = DocumentPositions { + identifierP :: Maybe Position, + stringLiteralP :: !Position, + doc :: !TextDocumentIdentifier +} + +allWithIdentifierPos :: Monad m => (DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool +allWithIdentifierPos f docs = allM f (filter (isJust . identifierP) docs) + +experiments :: [Bench] +experiments = + [ --------------------------------------------------------------------------------------- + bench "hover" $ allWithIdentifierPos $ \DocumentPositions{..} -> + isJust <$> getHover doc (fromJust identifierP), + --------------------------------------------------------------------------------------- + bench "edit" $ \docs -> do + forM_ docs $ \DocumentPositions{..} -> + changeDoc doc [charEdit stringLiteralP] + waitForProgressDone -- TODO check that this waits for all of them + return True, + --------------------------------------------------------------------------------------- + bench "hover after edit" $ \docs -> do + forM_ docs $ \DocumentPositions{..} -> + changeDoc doc [charEdit stringLiteralP] + flip allWithIdentifierPos docs $ \DocumentPositions{..} -> + isJust <$> getHover doc (fromJust identifierP), + --------------------------------------------------------------------------------------- + bench "getDefinition" $ allWithIdentifierPos $ \DocumentPositions{..} -> + either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP), + --------------------------------------------------------------------------------------- + bench "getDefinition after edit" $ \docs -> do + forM_ docs $ \DocumentPositions{..} -> + changeDoc doc [charEdit stringLiteralP] + flip allWithIdentifierPos docs $ \DocumentPositions{..} -> + either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP), + --------------------------------------------------------------------------------------- + bench "documentSymbols" $ allM $ \DocumentPositions{..} -> do + fmap (either (not . null) (not . null)) . getDocumentSymbols $ doc, + --------------------------------------------------------------------------------------- + bench "documentSymbols after edit" $ \docs -> do + forM_ docs $ \DocumentPositions{..} -> + changeDoc doc [charEdit stringLiteralP] + flip allM docs $ \DocumentPositions{..} -> + either (not . null) (not . null) <$> getDocumentSymbols doc, + --------------------------------------------------------------------------------------- + bench "completions" $ \docs -> do + flip allWithIdentifierPos docs $ \DocumentPositions{..} -> + not . null <$> getCompletions doc (fromJust identifierP), + --------------------------------------------------------------------------------------- + bench "completions after edit" $ \docs -> do + forM_ docs $ \DocumentPositions{..} -> + changeDoc doc [charEdit stringLiteralP] + flip allWithIdentifierPos docs $ \DocumentPositions{..} -> + not . null <$> getCompletions doc (fromJust identifierP), + --------------------------------------------------------------------------------------- + benchWithSetup + "code actions" + ( \docs -> do + unless (any (isJust . identifierP) docs) $ + error "None of the example modules is suitable for this experiment" + forM_ docs $ \DocumentPositions{..} -> + forM_ identifierP $ \p -> changeDoc doc [charEdit p] + waitForProgressDone + ) + ( \docs -> not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> + forM identifierP $ \p -> + getCodeActions doc (Range p p)) + ), + --------------------------------------------------------------------------------------- + benchWithSetup + "code actions after edit" + ( \docs -> do + unless (any (isJust . identifierP) docs) $ + error "None of the example modules is suitable for this experiment" + forM_ docs $ \DocumentPositions{..} -> + forM_ identifierP $ \p -> changeDoc doc [charEdit p] + ) + ( \docs -> do + forM_ docs $ \DocumentPositions{..} -> + changeDoc doc [charEdit stringLiteralP] + waitForProgressDone + not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do + forM identifierP $ \p -> + getCodeActions doc (Range p p)) + ), + --------------------------------------------------------------------------------------- + benchWithSetup + "code actions after cradle edit" + ( \docs -> do + unless (any (isJust . identifierP) docs) $ + error "None of the example modules is suitable for this experiment" + forM_ docs $ \DocumentPositions{..} -> + forM_ identifierP $ \p -> changeDoc doc [charEdit p] + ) + ( \docs -> do + Just hieYaml <- uriToFilePath <$> getDocUri "hie.yaml" + liftIO $ appendFile hieYaml "##\n" + sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + List [ FileEvent (filePathToUri "hie.yaml") FcChanged ] + forM_ docs $ \DocumentPositions{..} -> + changeDoc doc [charEdit stringLiteralP] + waitForProgressDone + not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do + forM identifierP $ \p -> + getCodeActions doc (Range p p)) + ), + --------------------------------------------------------------------------------------- + bench + "hover after cradle edit" + (\docs -> do + Just hieYaml <- uriToFilePath <$> getDocUri "hie.yaml" + liftIO $ appendFile hieYaml "##\n" + sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + List [ FileEvent (filePathToUri "hie.yaml") FcChanged ] + flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP) + ) + ] + +--------------------------------------------------------------------------------------------- + +examplesPath :: FilePath +examplesPath = "bench/example" + +defConfig :: Config +Success defConfig = execParserPure defaultPrefs (info configP fullDesc) [] + +quiet, verbose :: Config -> Bool +verbose = (== All) . verbosity +quiet = (== Quiet) . verbosity + +type HasConfig = (?config :: Config) + +configP :: Parser Config +configP = + Config + <$> (flag' All (short 'v' <> long "verbose") + <|> flag' Quiet (short 'q' <> long "quiet") + <|> pure Normal + ) + <*> optional (strOption (long "shake-profiling" <> metavar "PATH")) + <*> optional (strOption (long "ot-profiling" <> metavar "DIR" <> help "Enable OpenTelemetry and write eventlog for each benchmark in DIR")) + <*> strOption (long "csv" <> metavar "PATH" <> value "results.csv" <> showDefault) + <*> flag Cabal Stack (long "stack" <> help "Use stack (by default cabal is used)") + <*> many (strOption (long "ghcide-options" <> help "additional options for ghcide")) + <*> many (strOption (short 's' <> long "select" <> help "select which benchmarks to run")) + <*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count")) + <*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide") + <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response") + <*> ( GetPackage <$> strOption (long "example-package-name" <> value "Cabal") + <*> (some moduleOption <|> pure ["Distribution/Simple.hs"]) + <*> option versionP (long "example-package-version" <> value (makeVersion [3,2,0,0])) + <|> + UsePackage <$> strOption (long "example-path") + <*> some moduleOption + ) + where + moduleOption = strOption (long "example-module" <> metavar "PATH") + +versionP :: ReadM Version +versionP = maybeReader $ extract . readP_to_S parseVersion + where + extract parses = listToMaybe [ res | (res,"") <- parses] + +output :: (MonadIO m, HasConfig) => String -> m () +output = if quiet?config then (\_ -> pure ()) else liftIO . putStrLn + +--------------------------------------------------------------------------------------- + +type Experiment = [DocumentPositions] -> Session Bool + +data Bench = + Bench + { name :: !String, + enabled :: !Bool, + samples :: !Natural, + benchSetup :: [DocumentPositions] -> Session (), + experiment :: Experiment + } + +select :: HasConfig => Bench -> Bool +select Bench {name, enabled} = + enabled && (null mm || name `elem` mm) + where + mm = matches ?config + +benchWithSetup :: + String -> + ([DocumentPositions] -> Session ()) -> + Experiment -> + Bench +benchWithSetup name benchSetup experiment = Bench {..} + where + enabled = True + samples = 100 + +bench :: String -> Experiment -> Bench +bench name = benchWithSetup name (const $ pure ()) + +runBenchmarksFun :: HasConfig => FilePath -> [Bench] -> IO () +runBenchmarksFun dir allBenchmarks = do + let benchmarks = [ b{samples = fromMaybe 100 (repetitions ?config) } + | b <- allBenchmarks + , select b ] + + whenJust (otMemoryProfiling ?config) $ \eventlogDir -> + createDirectoryIfMissing True eventlogDir + + results <- forM benchmarks $ \b@Bench{name} -> do + let run = runSessionWithConfig conf (cmd name dir) lspTestCaps dir + (b,) <$> runBench run b + + -- output raw data as CSV + let headers = + [ "name" + , "success" + , "samples" + , "startup" + , "setup" + , "userTime" + , "delayedTime" + , "totalTime" + ] + rows = + [ [ name, + show success, + show samples, + show startup, + show runSetup', + show userWaits, + show delayedWork, + show runExperiment + ] + | (Bench {name, samples}, BenchRun {..}) <- results, + let runSetup' = if runSetup < 0.01 then 0 else runSetup + ] + csv = unlines $ map (intercalate ", ") (headers : rows) + writeFile (outputCSV ?config) csv + + -- print a nice table + let pads = map (maximum . map length) (transpose (headers : rowsHuman)) + paddedHeaders = zipWith pad pads headers + outputRow = putStrLn . intercalate " | " + rowsHuman = + [ [ name, + show success, + show samples, + showDuration startup, + showDuration runSetup', + showDuration userWaits, + showDuration delayedWork, + showDuration runExperiment + ] + | (Bench {name, samples}, BenchRun {..}) <- results, + let runSetup' = if runSetup < 0.01 then 0 else runSetup + ] + outputRow paddedHeaders + outputRow $ (map . map) (const '-') paddedHeaders + forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row + where + ghcideCmd dir = + [ ghcide ?config, + "--lsp", + "--test", + "--cwd", + dir, + "+RTS" + ] + cmd name dir = + unwords $ + ghcideCmd dir + ++ case otMemoryProfiling ?config of + Just dir -> ["-l", "-ol" ++ (dir map (\c -> if c == ' ' then '-' else c) name <.> "eventlog")] + Nothing -> [] + ++ [ "-RTS" ] + ++ ghcideOptions ?config + ++ concat + [ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config] + ] + ++ ["--verbose" | verbose ?config] + ++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]] + lspTestCaps = + fullCaps {_window = Just $ WindowClientCapabilities $ Just True} + conf = + defaultConfig + { logStdErr = verbose ?config, + logMessages = verbose ?config, + logColor = False, + messageTimeout = timeoutLsp ?config + } + +data BenchRun = BenchRun + { startup :: !Seconds, + runSetup :: !Seconds, + runExperiment :: !Seconds, + userWaits :: !Seconds, + delayedWork :: !Seconds, + success :: !Bool + } + +badRun :: BenchRun +badRun = BenchRun 0 0 0 0 0 False + +-- | Wait for all progress to be done +-- Needs at least one progress done notification to return +waitForProgressDone :: Session () +waitForProgressDone = loop + where + loop = do + ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + _ -> Nothing + done <- null <$> getIncompleteProgressSessions + unless done loop + +runBench :: + (?config :: Config) => + (Session BenchRun -> IO BenchRun) -> + Bench -> + IO BenchRun +runBench runSess b = handleAny (\e -> print e >> return badRun) + $ runSess + $ do + case b of + Bench{..} -> do + (startup, docs) <- duration $ do + (d, docs) <- duration $ setupDocumentContents ?config + output $ "Setting up document contents took " <> showDuration d + -- wait again, as the progress is restarted once while loading the cradle + -- make an edit, to ensure this doesn't block + let DocumentPositions{..} = head docs + changeDoc doc [charEdit stringLiteralP] + waitForProgressDone + return docs + + liftIO $ output $ "Running " <> name <> " benchmark" + (runSetup, ()) <- duration $ benchSetup docs + let loop !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork) + loop !userWaits !delayedWork n = do + (t, res) <- duration $ experiment docs + if not res + then return Nothing + else do + output (showDuration t) + -- Wait for the delayed actions to finish + let m = SCustomMethod "test" + waitId <- sendRequest m (toJSON WaitForShakeQueue) + (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId + case resp of + ResponseMessage{_result=Right Null} -> do + loop (userWaits+t) (delayedWork+td) (n -1) + _ -> + -- Assume a ghcide build lacking the WaitForShakeQueue command + loop (userWaits+t) delayedWork (n -1) + + (runExperiment, result) <- duration $ loop 0 0 samples + let success = isJust result + (userWaits, delayedWork) = fromMaybe (0,0) result + + return BenchRun {..} + +data SetupResult = SetupResult { + runBenchmarks :: [Bench] -> IO (), + -- | Path to the setup benchmark example + benchDir :: FilePath, + cleanUp :: IO () +} + +callCommandLogging :: HasConfig => String -> IO () +callCommandLogging cmd = do + output cmd + callCommand cmd + +setup :: HasConfig => IO SetupResult +setup = do +-- when alreadyExists $ removeDirectoryRecursive examplesPath + benchDir <- case example ?config of + UsePackage{..} -> do + let hieYamlPath = examplePath "hie.yaml" + alreadyExists <- doesFileExist hieYamlPath + unless alreadyExists $ + cmd_ (Cwd examplePath) (FileStdout hieYamlPath) ("gen-hie"::String) + return examplePath + GetPackage{..} -> do + let path = examplesPath package + package = exampleName <> "-" <> showVersion exampleVersion + hieYamlPath = path "hie.yaml" + alreadySetup <- doesDirectoryExist path + unless alreadySetup $ + case buildTool ?config of + Cabal -> do + let cabalVerbosity = "-v" ++ show (fromEnum (verbose ?config)) + callCommandLogging $ "cabal get " <> cabalVerbosity <> " " <> package <> " -d " <> examplesPath + let hieYamlPath = path "hie.yaml" + cmd_ (Cwd path) (FileStdout hieYamlPath) ("gen-hie"::String) + -- Need this in case there is a parent cabal.project somewhere + writeFile + (path "cabal.project") + "packages: ." + writeFile + (path "cabal.project.local") + "" + Stack -> do + let stackVerbosity = case verbosity ?config of + Quiet -> "--silent" + Normal -> "" + All -> "--verbose" + callCommandLogging $ "stack " <> stackVerbosity <> " unpack " <> package <> " --to " <> examplesPath + -- Generate the stack descriptor to match the one used to build ghcide + stack_yaml <- fromMaybe "stack.yaml" <$> getEnv "STACK_YAML" + stack_yaml_lines <- lines <$> readFile stack_yaml + writeFile (path stack_yaml) + (unlines $ + "packages: [.]" : + [ l + | l <- stack_yaml_lines + , any (`isPrefixOf` l) + ["resolver" + ,"allow-newer" + ,"compiler"] + ] + ) + + cmd_ (Cwd path) (FileStdout hieYamlPath) ("gen-hie"::String) ["--stack"::String] + return path + + whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True + + let cleanUp = case example ?config of + GetPackage{} -> removeDirectoryRecursive examplesPath + UsePackage{} -> return () + + runBenchmarks = runBenchmarksFun benchDir + + return SetupResult{..} + +setupDocumentContents :: Config -> Session [DocumentPositions] +setupDocumentContents config = + forM (exampleModules $ example config) $ \m -> do + doc <- openDoc m "haskell" + + -- Setup the special positions used by the experiments + lastLine <- length . T.lines <$> documentContents doc + changeDoc doc [TextDocumentContentChangeEvent + { _range = Just (Range (Position lastLine 0) (Position lastLine 0)) + , _rangeLength = Nothing + , _text = T.unlines [ "_hygienic = \"hygienic\"" ] + }] + let + -- Points to a string in the target file, + -- convenient for hygienic edits + stringLiteralP = Position lastLine 15 + + -- Find an identifier defined in another file in this project + symbols <- getDocumentSymbols doc + let endOfImports = case symbols of + Left symbols | Just x <- findEndOfImports symbols -> x + _ -> error $ "symbols: " <> show symbols + contents <- documentContents doc + identifierP <- searchSymbol doc contents endOfImports + return $ DocumentPositions{..} + +findEndOfImports :: [DocumentSymbol] -> Maybe Position +findEndOfImports (DocumentSymbol{_kind = SkModule, _name = "imports", _range} : _) = + Just $ Position (succ $ _line $ _end _range) 4 +findEndOfImports [DocumentSymbol{_kind = SkFile, _children = Just (List cc)}] = + findEndOfImports cc +findEndOfImports (DocumentSymbol{_range} : _) = + Just $ _start _range +findEndOfImports _ = Nothing + +-------------------------------------------------------------------------------------------- + +pad :: Int -> String -> String +pad n [] = replicate n ' ' +pad 0 _ = error "pad" +pad n (x:xx) = x : pad (n-1) xx + +-- | Search for a position where: +-- - get definition works and returns a uri other than this file +-- - get completions returns a non empty list +searchSymbol :: TextDocumentIdentifier -> T.Text -> Position -> Session (Maybe Position) +searchSymbol doc@TextDocumentIdentifier{_uri} fileContents pos = do + -- this search is expensive, so we cache the result on disk + let cachedPath = fromJust (uriToFilePath _uri) <.> "identifierPosition" + cachedRes <- liftIO $ try @_ @IOException $ read <$> readFile cachedPath + case cachedRes of + Left _ -> do + result <- loop pos + liftIO $ writeFile cachedPath $ show result + return result + Right res -> + return res + where + loop pos + | _line pos >= lll = + return Nothing + | _character pos >= lengthOfLine (_line pos) = + loop (nextLine pos) + | otherwise = do + checks <- checkDefinitions pos &&^ checkCompletions pos + if checks + then return $ Just pos + else loop (nextIdent pos) + + nextIdent p = p{_character = _character p + 2} + nextLine p = Position (_line p + 1) 4 + + lengthOfLine n = if n >= lll then 0 else T.length (ll !! n) + ll = T.lines fileContents + lll = length ll + + checkDefinitions pos = do + defs <- getDefinitions doc pos + case defs of + (InL [Location uri _]) -> return $ uri /= _uri + _ -> return False + checkCompletions pos = + not . null <$> getCompletions doc pos diff --git a/bench/lib/Experiments/Types.hs b/bench/lib/Experiments/Types.hs --- a/bench/lib/Experiments/Types.hs +++ b/bench/lib/Experiments/Types.hs @@ -1,70 +1,70 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -module Experiments.Types (module Experiments.Types ) where - -import Data.Aeson -import Data.Version -import Numeric.Natural -import System.FilePath (isPathSeparator) -import Development.Shake.Classes -import GHC.Generics - -data CabalStack = Cabal | Stack - deriving (Eq, Show) - -data Verbosity = Quiet | Normal | All - deriving (Eq, Show) -data Config = Config - { verbosity :: !Verbosity, - -- For some reason, the Shake profile files are truncated and won't load - shakeProfiling :: !(Maybe FilePath), - otMemoryProfiling :: !(Maybe FilePath), - outputCSV :: !FilePath, - buildTool :: !CabalStack, - ghcideOptions :: ![String], - matches :: ![String], - repetitions :: Maybe Natural, - ghcide :: FilePath, - timeoutLsp :: Int, - example :: Example - } - deriving (Eq, Show) - -data Example - = GetPackage {exampleName :: !String, exampleModules :: [FilePath], exampleVersion :: Version} - | UsePackage {examplePath :: FilePath, exampleModules :: [FilePath]} - deriving (Eq, Generic, Show) - deriving anyclass (Binary, Hashable, NFData) - -getExampleName :: Example -> String -getExampleName UsePackage{examplePath} = map replaceSeparator examplePath - where - replaceSeparator x - | isPathSeparator x = '_' - | otherwise = x -getExampleName GetPackage{exampleName, exampleVersion} = - exampleName <> "-" <> showVersion exampleVersion - -instance FromJSON Example where - parseJSON = withObject "example" $ \x -> do - exampleModules <- x .: "modules" - - path <- x .:? "path" - case path of - Just examplePath -> return UsePackage{..} - Nothing -> do - exampleName <- x .: "name" - exampleVersion <- x .: "version" - return GetPackage {..} - -exampleToOptions :: Example -> [String] -exampleToOptions GetPackage{..} = - ["--example-package-name", exampleName - ,"--example-package-version", showVersion exampleVersion - ] ++ - ["--example-module=" <> m | m <- exampleModules] -exampleToOptions UsePackage{..} = - ["--example-path", examplePath - ] ++ - ["--example-module=" <> m | m <- exampleModules] +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +module Experiments.Types (module Experiments.Types ) where + +import Data.Aeson +import Data.Version +import Development.Shake.Classes +import GHC.Generics +import Numeric.Natural +import System.FilePath (isPathSeparator) + +data CabalStack = Cabal | Stack + deriving (Eq, Show) + +data Verbosity = Quiet | Normal | All + deriving (Eq, Show) +data Config = Config + { verbosity :: !Verbosity, + -- For some reason, the Shake profile files are truncated and won't load + shakeProfiling :: !(Maybe FilePath), + otMemoryProfiling :: !(Maybe FilePath), + outputCSV :: !FilePath, + buildTool :: !CabalStack, + ghcideOptions :: ![String], + matches :: ![String], + repetitions :: Maybe Natural, + ghcide :: FilePath, + timeoutLsp :: Int, + example :: Example + } + deriving (Eq, Show) + +data Example + = GetPackage {exampleName :: !String, exampleModules :: [FilePath], exampleVersion :: Version} + | UsePackage {examplePath :: FilePath, exampleModules :: [FilePath]} + deriving (Eq, Generic, Show) + deriving anyclass (Binary, Hashable, NFData) + +getExampleName :: Example -> String +getExampleName UsePackage{examplePath} = map replaceSeparator examplePath + where + replaceSeparator x + | isPathSeparator x = '_' + | otherwise = x +getExampleName GetPackage{exampleName, exampleVersion} = + exampleName <> "-" <> showVersion exampleVersion + +instance FromJSON Example where + parseJSON = withObject "example" $ \x -> do + exampleModules <- x .: "modules" + + path <- x .:? "path" + case path of + Just examplePath -> return UsePackage{..} + Nothing -> do + exampleName <- x .: "name" + exampleVersion <- x .: "version" + return GetPackage {..} + +exampleToOptions :: Example -> [String] +exampleToOptions GetPackage{..} = + ["--example-package-name", exampleName + ,"--example-package-version", showVersion exampleVersion + ] ++ + ["--example-module=" <> m | m <- exampleModules] +exampleToOptions UsePackage{..} = + ["--example-path", examplePath + ] ++ + ["--example-module=" <> m | m <- exampleModules] diff --git a/cbits/getmodtime.c b/cbits/getmodtime.c --- a/cbits/getmodtime.c +++ b/cbits/getmodtime.c @@ -1,21 +1,21 @@ -// Copyright (c) 2019 The DAML Authors. All rights reserved. -// SPDX-License-Identifier: Apache-2.0 - -#include -#include -int getmodtime(const char* pathname, time_t* sec, long* nsec) { - struct stat s; - int r = stat(pathname, &s); - if (r != 0) { - return r; - } -#ifdef __APPLE__ - *sec = s.st_mtimespec.tv_sec; - *nsec = s.st_mtimespec.tv_nsec; -#else - *sec = s.st_mtim.tv_sec; - *nsec = s.st_mtim.tv_nsec; -#endif - return 0; -} - +// Copyright (c) 2019 The DAML Authors. All rights reserved. +// SPDX-License-Identifier: Apache-2.0 + +#include +#include +int getmodtime(const char* pathname, time_t* sec, long* nsec) { + struct stat s; + int r = stat(pathname, &s); + if (r != 0) { + return r; + } +#ifdef __APPLE__ + *sec = s.st_mtimespec.tv_sec; + *nsec = s.st_mtimespec.tv_nsec; +#else + *sec = s.st_mtim.tv_sec; + *nsec = s.st_mtim.tv_nsec; +#endif + return 0; +} + diff --git a/exe/Arguments.hs b/exe/Arguments.hs --- a/exe/Arguments.hs +++ b/exe/Arguments.hs @@ -1,52 +1,52 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -module Arguments(Arguments, Arguments'(..), getArguments, IdeCmd(..)) where - -import Options.Applicative -import HieDb.Run - -type Arguments = Arguments' IdeCmd - -data IdeCmd = Typecheck [FilePath] | DbCmd Options Command | LSP - -data Arguments' a = Arguments - {argLSP :: Bool - ,argsCwd :: Maybe FilePath - ,argsVersion :: Bool - ,argsShakeProfiling :: Maybe FilePath - ,argsOTMemoryProfiling :: Bool - ,argsTesting :: Bool - ,argsDisableKick :: Bool - ,argsThreads :: Int - ,argsVerbose :: Bool - ,argFilesOrCmd :: a - } - -getArguments :: IO Arguments -getArguments = execParser opts - where - opts = info (arguments <**> helper) - ( fullDesc - <> header "ghcide - the core of a Haskell IDE") - -arguments :: Parser Arguments -arguments = Arguments - <$> switch (long "lsp" <> help "Start talking to an LSP client") - <*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory") - <*> switch (long "version" <> help "Show ghcide and GHC versions") - <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory") - <*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect") - <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite") - <*> switch (long "test-no-kick" <> help "Disable kick. Useful for testing cancellation") - <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault) - <*> switch (long "verbose" <> help "Include internal events in logging output") - <*> ( hsubparser (command "typecheck" (info (Typecheck <$> fileCmd) fileInfo) - <> command "hiedb" (info (DbCmd <$> optParser "" True <*> cmdParser <**> helper) hieInfo) - <> command "lsp" (info (pure LSP <**> helper) lspInfo) ) - <|> Typecheck <$> fileCmd ) - where - fileCmd = many (argument str (metavar "FILES/DIRS...")) - lspInfo = fullDesc <> progDesc "Start talking to an LSP client" - fileInfo = fullDesc <> progDesc "Used as a test bed to check your IDE will work" - hieInfo = fullDesc <> progDesc "Query .hie files" +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Arguments(Arguments, Arguments'(..), getArguments, IdeCmd(..)) where + +import HieDb.Run +import Options.Applicative + +type Arguments = Arguments' IdeCmd + +data IdeCmd = Typecheck [FilePath] | DbCmd Options Command | LSP + +data Arguments' a = Arguments + {argLSP :: Bool + ,argsCwd :: Maybe FilePath + ,argsVersion :: Bool + ,argsShakeProfiling :: Maybe FilePath + ,argsOTMemoryProfiling :: Bool + ,argsTesting :: Bool + ,argsDisableKick :: Bool + ,argsThreads :: Int + ,argsVerbose :: Bool + ,argFilesOrCmd :: a + } + +getArguments :: IO Arguments +getArguments = execParser opts + where + opts = info (arguments <**> helper) + ( fullDesc + <> header "ghcide - the core of a Haskell IDE") + +arguments :: Parser Arguments +arguments = Arguments + <$> switch (long "lsp" <> help "Start talking to an LSP client") + <*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory") + <*> switch (long "version" <> help "Show ghcide and GHC versions") + <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory") + <*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect") + <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite") + <*> switch (long "test-no-kick" <> help "Disable kick. Useful for testing cancellation") + <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault) + <*> switch (long "verbose" <> help "Include internal events in logging output") + <*> ( hsubparser (command "typecheck" (info (Typecheck <$> fileCmd) fileInfo) + <> command "hiedb" (info (DbCmd <$> optParser "" True <*> cmdParser <**> helper) hieInfo) + <> command "lsp" (info (pure LSP <**> helper) lspInfo) ) + <|> Typecheck <$> fileCmd ) + where + fileCmd = many (argument str (metavar "FILES/DIRS...")) + lspInfo = fullDesc <> progDesc "Start talking to an LSP client" + fileInfo = fullDesc <> progDesc "Used as a test bed to check your IDE will work" + hieInfo = fullDesc <> progDesc "Query .hie files" diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,117 +1,121 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 -{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above -{-# LANGUAGE TemplateHaskell #-} - -module Main(main) where - -import Arguments ( Arguments'(..), IdeCmd(..), getArguments ) -import Control.Concurrent.Extra ( newLock, withLock ) -import Control.Monad.Extra ( unless, when, whenJust ) -import Data.Default ( Default(def) ) -import Data.List.Extra ( upper ) -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Data.Version ( showVersion ) -import Development.GitRev ( gitHash ) -import Development.IDE ( Logger(Logger), Priority(Info), action ) -import Development.IDE.Core.OfInterest (kick) -import Development.IDE.Core.Rules (mainRule) -import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde -import qualified Development.IDE.Plugin.Test as Test -import Development.IDE.Session (setInitialDynFlags, getHieDbLoc) -import Development.IDE.Types.Options -import qualified Development.IDE.Main as Main -import Development.Shake (ShakeOptions(shakeThreads)) -import Ide.Plugin.Config (Config(checkParents, checkProject)) -import Ide.PluginUtils (pluginDescToIdePlugins) -import HieDb.Run (Options(..), runCommand) -import Paths_ghcide ( version ) -import qualified System.Directory.Extra as IO -import System.Environment ( getExecutablePath ) -import System.Exit ( ExitCode(ExitFailure), exitSuccess, exitWith ) -import System.Info ( compilerVersion ) -import System.IO ( stderr, hPutStrLn ) - -ghcideVersion :: IO String -ghcideVersion = do - path <- getExecutablePath - let gitHashSection = case $(gitHash) of - x | x == "UNKNOWN" -> "" - x -> " (GIT hash: " <> x <> ")" - return $ "ghcide version: " <> showVersion version - <> " (GHC: " <> showVersion compilerVersion - <> ") (PATH: " <> path <> ")" - <> gitHashSection - -main :: IO () -main = do - -- WARNING: If you write to stdout before runLanguageServer - -- then the language server will not work - Arguments{..} <- getArguments - - if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess - else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion - - whenJust argsCwd IO.setCurrentDirectory - - -- lock to avoid overlapping output on stdout - lock <- newLock - let logger = Logger $ \pri msg -> when (pri >= logLevel) $ withLock lock $ - T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg - logLevel = if argsVerbose then minBound else Info - - case argFilesOrCmd of - DbCmd opts cmd -> do - dir <- IO.getCurrentDirectory - dbLoc <- getHieDbLoc dir - mlibdir <- setInitialDynFlags def - case mlibdir of - Nothing -> exitWith $ ExitFailure 1 - Just libdir -> runCommand libdir opts{database = dbLoc} cmd - - _ -> do - - case argFilesOrCmd of - LSP -> do - hPutStrLn stderr "Starting LSP server..." - hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" - _ -> return () - - Main.defaultMain def - {Main.argFiles = case argFilesOrCmd of - Typecheck x | not argLSP -> Just x - _ -> Nothing - - ,Main.argsLogger = logger - - ,Main.argsRules = do - -- install the main and ghcide-plugin rules - mainRule - -- install the kick action, which triggers a typecheck on every - -- Shake database restart, i.e. on every user edit. - unless argsDisableKick $ - action kick - - ,Main.argsHlsPlugins = - pluginDescToIdePlugins $ - GhcIde.descriptors - ++ [Test.blockCommandDescriptor "block-command" | argsTesting] - - ,Main.argsGhcidePlugin = if argsTesting - then Test.plugin - else mempty - - ,Main.argsIdeOptions = \(fromMaybe def -> config) sessionLoader -> - let defOptions = defaultIdeOptions sessionLoader - in defOptions - { optShakeProfiling = argsShakeProfiling - , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling - , optTesting = IdeTesting argsTesting - , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads} - , optCheckParents = pure $ checkParents config - , optCheckProject = pure $ checkProject config - } - } - +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 +{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above +{-# LANGUAGE TemplateHaskell #-} + +module Main(main) where + +import Arguments (Arguments' (..), + IdeCmd (..), getArguments) +import Control.Concurrent.Extra (newLock, withLock) +import Control.Monad.Extra (unless, when, whenJust) +import Data.Default (Default (def)) +import Data.List.Extra (upper) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Version (showVersion) +import Development.GitRev (gitHash) +import Development.IDE (Logger (Logger), + Priority (Info), action) +import Development.IDE.Core.OfInterest (kick) +import Development.IDE.Core.Rules (mainRule) +import qualified Development.IDE.Main as Main +import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde +import qualified Development.IDE.Plugin.Test as Test +import Development.IDE.Session (getHieDbLoc, + setInitialDynFlags) +import Development.IDE.Types.Options +import Development.Shake (ShakeOptions (shakeThreads)) +import HieDb.Run (Options (..), runCommand) +import Ide.Plugin.Config (Config (checkParents, checkProject)) +import Ide.PluginUtils (pluginDescToIdePlugins) +import Paths_ghcide (version) +import qualified System.Directory.Extra as IO +import System.Environment (getExecutablePath) +import System.Exit (ExitCode (ExitFailure), + exitSuccess, exitWith) +import System.IO (hPutStrLn, stderr) +import System.Info (compilerVersion) + +ghcideVersion :: IO String +ghcideVersion = do + path <- getExecutablePath + let gitHashSection = case $(gitHash) of + x | x == "UNKNOWN" -> "" + x -> " (GIT hash: " <> x <> ")" + return $ "ghcide version: " <> showVersion version + <> " (GHC: " <> showVersion compilerVersion + <> ") (PATH: " <> path <> ")" + <> gitHashSection + +main :: IO () +main = do + -- WARNING: If you write to stdout before runLanguageServer + -- then the language server will not work + Arguments{..} <- getArguments + + if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess + else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion + + whenJust argsCwd IO.setCurrentDirectory + + -- lock to avoid overlapping output on stdout + lock <- newLock + let logger = Logger $ \pri msg -> when (pri >= logLevel) $ withLock lock $ + T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg + logLevel = if argsVerbose then minBound else Info + + case argFilesOrCmd of + DbCmd opts cmd -> do + dir <- IO.getCurrentDirectory + dbLoc <- getHieDbLoc dir + mlibdir <- setInitialDynFlags def + case mlibdir of + Nothing -> exitWith $ ExitFailure 1 + Just libdir -> runCommand libdir opts{database = dbLoc} cmd + + _ -> do + + case argFilesOrCmd of + LSP -> do + hPutStrLn stderr "Starting LSP server..." + hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" + _ -> return () + + Main.defaultMain def + {Main.argFiles = case argFilesOrCmd of + Typecheck x | not argLSP -> Just x + _ -> Nothing + + ,Main.argsLogger = pure logger + + ,Main.argsRules = do + -- install the main and ghcide-plugin rules + mainRule + -- install the kick action, which triggers a typecheck on every + -- Shake database restart, i.e. on every user edit. + unless argsDisableKick $ + action kick + + ,Main.argsHlsPlugins = + pluginDescToIdePlugins $ + GhcIde.descriptors + ++ [Test.blockCommandDescriptor "block-command" | argsTesting] + + ,Main.argsGhcidePlugin = if argsTesting + then Test.plugin + else mempty + + ,Main.argsIdeOptions = \(fromMaybe def -> config) sessionLoader -> + let defOptions = defaultIdeOptions sessionLoader + in defOptions + { optShakeProfiling = argsShakeProfiling + , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling + , optTesting = IdeTesting argsTesting + , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads} + , optCheckParents = pure $ checkParents config + , optCheckProject = pure $ checkProject config + } + } + diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -1,425 +1,427 @@ -cabal-version: 2.2 -build-type: Simple -category: Development -name: ghcide -version: 1.0.0.0 -license: Apache-2.0 -license-file: LICENSE -author: Digital Asset and Ghcide contributors -maintainer: Ghcide contributors -copyright: Digital Asset and Ghcide contributors 2018-2020 -synopsis: The core of an IDE -description: - A library for building Haskell IDE's on top of the GHC API. -homepage: https://github.com/haskell/ghcide#readme -bug-reports: https://github.com/haskell/ghcide/issues -tested-with: GHC == 8.6.4 || == 8.6.5 || == 8.8.2 || == 8.8.3 || == 8.8.4 || == 8.10.2 || == 8.10.3 || == 8.10.4 -extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md - test/data/hover/*.hs - test/data/multi/cabal.project - test/data/multi/hie.yaml - test/data/multi/a/a.cabal - test/data/multi/a/*.hs - test/data/multi/b/b.cabal - test/data/multi/b/*.hs - -source-repository head - type: git - location: https://github.com/haskell/ghcide.git - -flag ghc-patched-unboxed-bytecode - description: The GHC version we link against supports unboxed sums and tuples in bytecode - default: False - manual: True - -library - default-language: Haskell2010 - build-depends: - aeson, - array, - async, - base == 4.*, - binary, - bytestring, - case-insensitive, - containers, - data-default, - deepseq, - directory, - dependent-map, - dependent-sum, - dlist, - extra >= 1.7.4, - fuzzy, - filepath, - fingertree, - ghc-exactprint, - Glob, - haddock-library >= 1.8 && < 1.10, - hashable, - hie-compat ^>= 0.1.0.0, - hls-plugin-api ^>= 1.0.0.0, - lens, - hiedb == 0.3.0.1, - lsp-types == 1.1.*, - lsp == 1.1.1.0, - mtl, - network-uri, - parallel, - prettyprinter-ansi-terminal, - prettyprinter-ansi-terminal, - prettyprinter, - regex-tdfa >= 1.3.1.0, - retrie, - rope-utf16-splay, - safe, - safe-exceptions, - shake >= 0.18.4, - sorted-list, - sqlite-simple, - stm, - syb, - text, - time, - transformers, - unordered-containers >= 0.2.10.0, - utf8-string, - vector, - hslogger, - Diff, - vector, - bytestring-encoding, - opentelemetry >=0.6.1, - heapsize ==0.3.*, - unliftio, - unliftio-core, - ghc-boot-th, - ghc-boot, - ghc >= 8.6, - ghc-check >=0.5.0.1, - ghc-paths, - cryptohash-sha1 >=0.11.100 && <0.12, - hie-bios >= 0.7.1 && < 0.8.0, - implicit-hie-cradle >= 0.3.0.2 && < 0.4, - base16-bytestring >=0.1.1 && <0.2 - if os(windows) - build-depends: - Win32 - else - build-depends: - unix - c-sources: - cbits/getmodtime.c - - default-extensions: - BangPatterns - DeriveFunctor - DeriveGeneric - FlexibleContexts - GeneralizedNewtypeDeriving - LambdaCase - NamedFieldPuns - OverloadedStrings - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - ViewPatterns - DataKinds - TypeOperators - KindSignatures - - hs-source-dirs: - src - session-loader - include-dirs: - include - exposed-modules: - Development.IDE - Development.IDE.Main - Development.IDE.Core.Debouncer - Development.IDE.Core.FileStore - Development.IDE.Core.IdeConfiguration - Development.IDE.Core.OfInterest - Development.IDE.Core.PositionMapping - Development.IDE.Core.Preprocessor - Development.IDE.Core.Rules - Development.IDE.Core.RuleTypes - Development.IDE.Core.Service - Development.IDE.Core.Shake - Development.IDE.Core.Tracing - Development.IDE.GHC.Compat - Development.IDE.Core.Compile - Development.IDE.GHC.Error - Development.IDE.GHC.ExactPrint - Development.IDE.GHC.Orphans - Development.IDE.GHC.Util - Development.IDE.Import.DependencyInformation - Development.IDE.Import.FindImports - Development.IDE.LSP.HoverDefinition - Development.IDE.LSP.LanguageServer - Development.IDE.LSP.Outline - Development.IDE.LSP.Server - Development.IDE.Session - Development.IDE.Spans.Common - Development.IDE.Spans.Documentation - Development.IDE.Spans.AtPoint - Development.IDE.Spans.LocalBindings - Development.IDE.Types.Diagnostics - Development.IDE.Types.Exports - Development.IDE.Types.HscEnvEq - Development.IDE.Types.KnownTargets - Development.IDE.Types.Location - Development.IDE.Types.Logger - Development.IDE.Types.Options - Development.IDE.Types.Shake - Development.IDE.Plugin - Development.IDE.Plugin.Completions - Development.IDE.Plugin.Completions.Types - Development.IDE.Plugin.CodeAction - Development.IDE.Plugin.CodeAction.ExactPrint - Development.IDE.Plugin.HLS - Development.IDE.Plugin.HLS.GhcIde - Development.IDE.Plugin.Test - Development.IDE.Plugin.TypeLenses - - other-modules: - Development.IDE.Core.FileExists - Development.IDE.GHC.CPP - Development.IDE.GHC.Warnings - Development.IDE.LSP.Notifications - Development.IDE.Plugin.CodeAction.PositionIndexed - Development.IDE.Plugin.Completions.Logic - Development.IDE.Session.VersionCheck - Development.IDE.Types.Action - ghc-options: -Wall -Wno-name-shadowing -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors - - if flag(ghc-patched-unboxed-bytecode) - cpp-options: -DGHC_PATCHED_UNBOXED_BYTECODE - -executable ghcide-test-preprocessor - default-language: Haskell2010 - hs-source-dirs: test/preprocessor - ghc-options: -Wall -Wno-name-shadowing - main-is: Main.hs - build-depends: - base == 4.* - -benchmark benchHist - type: exitcode-stdio-1.0 - default-language: Haskell2010 - ghc-options: -Wall -Wno-name-shadowing -threaded - main-is: Main.hs - hs-source-dirs: bench/hist bench/lib - other-modules: Experiments.Types - build-tool-depends: - ghcide:ghcide-bench, - hp2pretty:hp2pretty, - implicit-hie:gen-hie - default-extensions: - BangPatterns - DeriveFunctor - DeriveGeneric - FlexibleContexts - GeneralizedNewtypeDeriving - LambdaCase - NamedFieldPuns - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - ViewPatterns - - build-depends: - aeson, - base == 4.*, - shake-bench == 0.1.*, - directory, - extra, - filepath, - optparse-applicative, - shake, - text, - yaml - -executable ghcide - default-language: Haskell2010 - include-dirs: - include - hs-source-dirs: exe - ghc-options: - -threaded - -Wall - -Wincomplete-uni-patterns - -Wno-name-shadowing - -- allow user RTS overrides - -rtsopts - -- disable idle GC - -- increase nursery size - "-with-rtsopts=-I0 -A128M" - main-is: Main.hs - build-depends: - hiedb, - aeson, - base == 4.*, - data-default, - directory, - extra, - filepath, - gitrev, - safe-exceptions, - ghc, - hashable, - lsp, - lsp-types, - heapsize, - hie-bios, - hls-plugin-api, - ghcide, - lens, - optparse-applicative, - shake, - text, - unordered-containers - other-modules: - Arguments - Paths_ghcide - autogen-modules: - Paths_ghcide - - default-extensions: - BangPatterns - DeriveFunctor - DeriveGeneric - FlexibleContexts - GeneralizedNewtypeDeriving - LambdaCase - NamedFieldPuns - OverloadedStrings - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - ViewPatterns - -test-suite ghcide-tests - type: exitcode-stdio-1.0 - default-language: Haskell2010 - build-tool-depends: - ghcide:ghcide, - ghcide:ghcide-test-preprocessor, - implicit-hie:gen-hie - build-depends: - aeson, - base, - binary, - bytestring, - containers, - data-default, - directory, - extra, - filepath, - -------------------------------------------------------------- - -- The MIN_GHC_API_VERSION macro relies on MIN_VERSION pragmas - -- which require depending on ghc. So the tests need to depend - -- on ghc if they need to use MIN_GHC_API_VERSION. Maybe a - -- better solution can be found, but this is a quick solution - -- which works for now. - ghc, - -------------------------------------------------------------- - ghcide, - ghc-typelits-knownnat, - haddock-library, - lsp, - lsp-types, - hls-plugin-api, - network-uri, - lens, - lsp-test == 0.13.0.0, - optparse-applicative, - process, - QuickCheck, - quickcheck-instances, - rope-utf16-splay, - safe, - safe-exceptions, - shake, - tasty, - tasty-expected-failure, - tasty-hunit, - tasty-quickcheck, - tasty-rerun, - text - if (impl(ghc >= 8.6)) - build-depends: - record-dot-preprocessor, - record-hasfield - hs-source-dirs: test/cabal test/exe test/src bench/lib - include-dirs: include - ghc-options: -threaded -Wall -Wno-name-shadowing -O0 -Wno-unticked-promoted-constructors - main-is: Main.hs - other-modules: - Development.IDE.Test - Development.IDE.Test.Runfiles - Experiments - Experiments.Types - default-extensions: - BangPatterns - DeriveFunctor - DeriveGeneric - FlexibleContexts - GeneralizedNewtypeDeriving - LambdaCase - NamedFieldPuns - OverloadedStrings - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - ViewPatterns - -executable ghcide-bench - default-language: Haskell2010 - build-tool-depends: - ghcide:ghcide - build-depends: - aeson, - base, - bytestring, - containers, - directory, - extra, - filepath, - ghcide, - lsp-test == 0.13.0.0, - optparse-applicative, - process, - safe-exceptions, - shake, - text - hs-source-dirs: bench/lib bench/exe - include-dirs: include - ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts - main-is: Main.hs - other-modules: - Experiments - Experiments.Types - default-extensions: - BangPatterns - DeriveFunctor - DeriveGeneric - FlexibleContexts - GeneralizedNewtypeDeriving - LambdaCase - NamedFieldPuns - OverloadedStrings - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - ViewPatterns +cabal-version: 2.2 +build-type: Simple +category: Development +name: ghcide +version: 1.1.0.0 +license: Apache-2.0 +license-file: LICENSE +author: Digital Asset and Ghcide contributors +maintainer: Ghcide contributors +copyright: Digital Asset and Ghcide contributors 2018-2020 +synopsis: The core of an IDE +description: + A library for building Haskell IDE's on top of the GHC API. +homepage: https://github.com/haskell/ghcide#readme +bug-reports: https://github.com/haskell/ghcide/issues +tested-with: GHC == 8.6.4 || == 8.6.5 || == 8.8.2 || == 8.8.3 || == 8.8.4 || == 8.10.2 || == 8.10.3 || == 8.10.4 +extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md + test/data/hover/*.hs + test/data/multi/cabal.project + test/data/multi/hie.yaml + test/data/multi/a/a.cabal + test/data/multi/a/*.hs + test/data/multi/b/b.cabal + test/data/multi/b/*.hs + +source-repository head + type: git + location: https://github.com/haskell/ghcide.git + +flag ghc-patched-unboxed-bytecode + description: The GHC version we link against supports unboxed sums and tuples in bytecode + default: False + manual: True + +library + default-language: Haskell2010 + build-depends: + aeson, + array, + async, + base == 4.*, + binary, + bytestring, + case-insensitive, + containers, + data-default, + deepseq, + directory, + dependent-map, + dependent-sum, + dlist, + extra >= 1.7.4, + fuzzy, + filepath, + fingertree, + ghc-exactprint, + Glob, + haddock-library >= 1.8 && < 1.10, + hashable, + hie-compat ^>= 0.1.0.0, + hls-plugin-api ^>= 1.0.0.0, + lens, + hiedb == 0.3.0.1, + lsp-types == 1.1.*, + lsp == 1.1.1.0, + mtl, + network-uri, + parallel, + prettyprinter-ansi-terminal, + prettyprinter-ansi-terminal, + prettyprinter, + regex-tdfa >= 1.3.1.0, + retrie, + rope-utf16-splay, + safe, + safe-exceptions, + shake >= 0.18.4, + sorted-list, + sqlite-simple, + stm, + syb, + text, + time, + transformers, + unordered-containers >= 0.2.10.0, + utf8-string, + vector, + hslogger, + Diff, + vector, + bytestring-encoding, + opentelemetry >=0.6.1, + heapsize ==0.3.*, + unliftio, + unliftio-core, + ghc-boot-th, + ghc-boot, + ghc >= 8.6, + ghc-check >=0.5.0.1, + ghc-paths, + cryptohash-sha1 >=0.11.100 && <0.12, + hie-bios >= 0.7.1 && < 0.8.0, + implicit-hie-cradle >= 0.3.0.2 && < 0.4, + base16-bytestring >=0.1.1 && <0.2 + if os(windows) + build-depends: + Win32 + else + build-depends: + unix + c-sources: + cbits/getmodtime.c + + default-extensions: + BangPatterns + DeriveFunctor + DeriveGeneric + FlexibleContexts + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns + DataKinds + TypeOperators + KindSignatures + + hs-source-dirs: + src + session-loader + include-dirs: + include + exposed-modules: + Control.Concurrent.Strict + Development.IDE + Development.IDE.Main + Development.IDE.Core.Debouncer + Development.IDE.Core.FileStore + Development.IDE.Core.IdeConfiguration + Development.IDE.Core.OfInterest + Development.IDE.Core.PositionMapping + Development.IDE.Core.Preprocessor + Development.IDE.Core.Rules + Development.IDE.Core.RuleTypes + Development.IDE.Core.Service + Development.IDE.Core.Shake + Development.IDE.Core.Tracing + Development.IDE.GHC.Compat + Development.IDE.Core.Compile + Development.IDE.GHC.Error + Development.IDE.GHC.ExactPrint + Development.IDE.GHC.Orphans + Development.IDE.GHC.Util + Development.IDE.Import.DependencyInformation + Development.IDE.Import.FindImports + Development.IDE.LSP.HoverDefinition + Development.IDE.LSP.LanguageServer + Development.IDE.LSP.Outline + Development.IDE.LSP.Server + Development.IDE.Session + Development.IDE.Spans.Common + Development.IDE.Spans.Documentation + Development.IDE.Spans.AtPoint + Development.IDE.Spans.LocalBindings + Development.IDE.Types.Diagnostics + Development.IDE.Types.Exports + Development.IDE.Types.HscEnvEq + Development.IDE.Types.KnownTargets + Development.IDE.Types.Location + Development.IDE.Types.Logger + Development.IDE.Types.Options + Development.IDE.Types.Shake + Development.IDE.Plugin + Development.IDE.Plugin.Completions + Development.IDE.Plugin.Completions.Types + Development.IDE.Plugin.CodeAction + Development.IDE.Plugin.CodeAction.ExactPrint + Development.IDE.Plugin.HLS + Development.IDE.Plugin.HLS.GhcIde + Development.IDE.Plugin.Test + Development.IDE.Plugin.TypeLenses + + other-modules: + Development.IDE.Core.FileExists + Development.IDE.GHC.CPP + Development.IDE.GHC.Warnings + Development.IDE.LSP.Notifications + Development.IDE.Plugin.CodeAction.PositionIndexed + Development.IDE.Plugin.CodeAction.Args + Development.IDE.Plugin.Completions.Logic + Development.IDE.Session.VersionCheck + Development.IDE.Types.Action + ghc-options: -Wall -Wno-name-shadowing -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors + + if flag(ghc-patched-unboxed-bytecode) + cpp-options: -DGHC_PATCHED_UNBOXED_BYTECODE + +executable ghcide-test-preprocessor + default-language: Haskell2010 + hs-source-dirs: test/preprocessor + ghc-options: -Wall -Wno-name-shadowing + main-is: Main.hs + build-depends: + base == 4.* + +benchmark benchHist + type: exitcode-stdio-1.0 + default-language: Haskell2010 + ghc-options: -Wall -Wno-name-shadowing -threaded + main-is: Main.hs + hs-source-dirs: bench/hist bench/lib + other-modules: Experiments.Types + build-tool-depends: + ghcide:ghcide-bench, + hp2pretty:hp2pretty, + implicit-hie:gen-hie + default-extensions: + BangPatterns + DeriveFunctor + DeriveGeneric + FlexibleContexts + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns + + build-depends: + aeson, + base == 4.*, + shake-bench == 0.1.*, + directory, + extra, + filepath, + optparse-applicative, + shake, + text, + yaml + +executable ghcide + default-language: Haskell2010 + include-dirs: + include + hs-source-dirs: exe + ghc-options: + -threaded + -Wall + -Wincomplete-uni-patterns + -Wno-name-shadowing + -- allow user RTS overrides + -rtsopts + -- disable idle GC + -- increase nursery size + "-with-rtsopts=-I0 -A128M" + main-is: Main.hs + build-depends: + hiedb, + aeson, + base == 4.*, + data-default, + directory, + extra, + filepath, + gitrev, + safe-exceptions, + ghc, + hashable, + lsp, + lsp-types, + heapsize, + hie-bios, + hls-plugin-api, + ghcide, + lens, + optparse-applicative, + shake, + text, + unordered-containers + other-modules: + Arguments + Paths_ghcide + autogen-modules: + Paths_ghcide + + default-extensions: + BangPatterns + DeriveFunctor + DeriveGeneric + FlexibleContexts + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns + +test-suite ghcide-tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-tool-depends: + ghcide:ghcide, + ghcide:ghcide-test-preprocessor, + implicit-hie:gen-hie + build-depends: + aeson, + base, + binary, + bytestring, + containers, + data-default, + directory, + extra, + filepath, + -------------------------------------------------------------- + -- The MIN_GHC_API_VERSION macro relies on MIN_VERSION pragmas + -- which require depending on ghc. So the tests need to depend + -- on ghc if they need to use MIN_GHC_API_VERSION. Maybe a + -- better solution can be found, but this is a quick solution + -- which works for now. + ghc, + -------------------------------------------------------------- + ghcide, + ghc-typelits-knownnat, + haddock-library, + lsp, + lsp-types, + hls-plugin-api, + network-uri, + lens, + lsp-test == 0.13.0.0, + optparse-applicative, + process, + QuickCheck, + quickcheck-instances, + rope-utf16-splay, + safe, + safe-exceptions, + shake, + tasty, + tasty-expected-failure, + tasty-hunit, + tasty-quickcheck, + tasty-rerun, + text + if (impl(ghc >= 8.6)) + build-depends: + record-dot-preprocessor, + record-hasfield + hs-source-dirs: test/cabal test/exe test/src bench/lib + include-dirs: include + ghc-options: -threaded -Wall -Wno-name-shadowing -O0 -Wno-unticked-promoted-constructors + main-is: Main.hs + other-modules: + Development.IDE.Test + Development.IDE.Test.Runfiles + Experiments + Experiments.Types + default-extensions: + BangPatterns + DeriveFunctor + DeriveGeneric + FlexibleContexts + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns + +executable ghcide-bench + default-language: Haskell2010 + build-tool-depends: + ghcide:ghcide + build-depends: + aeson, + base, + bytestring, + containers, + directory, + extra, + filepath, + ghcide, + lsp-test == 0.13.0.0, + optparse-applicative, + process, + safe-exceptions, + shake, + text + hs-source-dirs: bench/lib bench/exe + include-dirs: include + ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts + main-is: Main.hs + other-modules: + Experiments + Experiments.Types + default-extensions: + BangPatterns + DeriveFunctor + DeriveGeneric + FlexibleContexts + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns diff --git a/include/ghc-api-version.h b/include/ghc-api-version.h --- a/include/ghc-api-version.h +++ b/include/ghc-api-version.h @@ -1,12 +1,12 @@ -#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) -#define GHC_API_VERSION VERSION_ghc_lib -#else -#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z) -#define GHC_API_VERSION VERSION_ghc -#endif - -#endif +#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) +#define GHC_API_VERSION VERSION_ghc_lib +#else +#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z) +#define GHC_API_VERSION VERSION_ghc +#endif + +#endif diff --git a/session-loader/Development/IDE/Session.hs b/session-loader/Development/IDE/Session.hs --- a/session-loader/Development/IDE/Session.hs +++ b/session-loader/Development/IDE/Session.hs @@ -1,862 +1,876 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -#include "ghc-api-version.h" - -{-| -The logic for setting up a ghcide session by tapping into hie-bios. --} -module Development.IDE.Session - (SessionLoadingOptions(..) - ,CacheDirs(..) - ,loadSession - ,loadSessionWithOptions - ,setInitialDynFlags - ,getHieDbLoc - ,runWithDb - ) where - --- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses --- the real GHC library and the types are incompatible. Furthermore, when --- building with ghc-lib we need to make this Haskell agnostic, so no hie-bios! - -import Control.Concurrent.Async -import Control.Concurrent.Extra -import Control.Exception.Safe -import Control.Monad -import Control.Monad.Extra -import Control.Monad.IO.Class -import qualified Crypto.Hash.SHA1 as H -import qualified Data.ByteString.Char8 as B -import qualified Data.HashMap.Strict as HM -import qualified Data.Map.Strict as Map -import qualified Data.Text as T -import Data.Aeson -import Data.Bifunctor -import qualified Data.ByteString.Base16 as B16 -import Data.Default -import Data.Either.Extra -import Data.Function -import Data.Hashable -import Data.List -import Data.IORef -import Data.Maybe -import Data.Time.Clock -import Data.Version -import Development.IDE.Core.Shake -import Development.IDE.Core.RuleTypes -import Development.IDE.GHC.Compat hiding (Target, TargetModule, TargetFile) -import qualified Development.IDE.GHC.Compat as GHC -import Development.IDE.GHC.Util -import Development.IDE.Session.VersionCheck -import Development.IDE.Types.Diagnostics -import Development.IDE.Types.Exports -import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEqPreserveImportPaths, newHscEnvEq) -import Development.IDE.Types.Location -import Development.IDE.Types.Logger -import Development.IDE.Types.Options -import Development.Shake (Action) -import GHC.Check -import qualified HIE.Bios as HieBios -import HIE.Bios.Environment hiding (getCacheDir) -import HIE.Bios.Types -import Hie.Implicit.Cradle (loadImplicitHieCradle) -import Language.LSP.Server -import Language.LSP.Types -import System.Directory -import qualified System.Directory.Extra as IO -import System.FilePath -import System.Info -import System.IO - -import GHCi -import HscTypes (ic_dflags, hsc_IC, hsc_dflags, hsc_NC) -import Linker -import Module -import NameCache -import Packages -import Control.Exception (evaluate) -import Data.Void -import Control.Applicative (Alternative((<|>))) - -import HieDb.Create -import HieDb.Types -import HieDb.Utils -import Database.SQLite.Simple -import Control.Concurrent.STM.TQueue -import Control.Concurrent.STM (atomically) -import Maybes (MaybeT(runMaybeT)) -import HIE.Bios.Cradle (yamlConfig) - - -data CacheDirs = CacheDirs - { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath} - -data SessionLoadingOptions = SessionLoadingOptions - { findCradle :: FilePath -> IO (Maybe FilePath) - , loadCradle :: FilePath -> IO (HieBios.Cradle Void) - -- | Given the project name and a set of command line flags, - -- return the path for storing generated GHC artifacts, - -- or 'Nothing' to respect the cradle setting - , getCacheDirs :: String -> [String] -> IO CacheDirs - -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags' - , getInitialGhcLibDir :: IO (Maybe LibDir) - } - -instance Default SessionLoadingOptions where - def = SessionLoadingOptions - {findCradle = HieBios.findCradle - ,loadCradle = HieBios.loadCradle - ,getCacheDirs = getCacheDirsDefault - ,getInitialGhcLibDir = getInitialGhcLibDirDefault - } - -getInitialGhcLibDirDefault :: IO (Maybe LibDir) -getInitialGhcLibDirDefault = do - dir <- IO.getCurrentDirectory - hieYaml <- runMaybeT $ yamlConfig dir - cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) HieBios.loadCradle hieYaml - hPutStrLn stderr $ "setInitialDynFlags cradle: " ++ show cradle - libDirRes <- getRuntimeGhcLibDir cradle - case libDirRes of - CradleSuccess libdir -> pure $ Just $ LibDir libdir - CradleFail err -> do - hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show (err,dir,hieYaml,cradle) - pure Nothing - CradleNone -> do - hPutStrLn stderr "Couldn't load cradle (CradleNone)" - pure Nothing - --- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir -setInitialDynFlags :: SessionLoadingOptions -> IO (Maybe LibDir) -setInitialDynFlags SessionLoadingOptions{..} = do - libdir <- getInitialGhcLibDir - dynFlags <- mapM dynFlagsForPrinting libdir - mapM_ setUnsafeGlobalDynFlags dynFlags - pure libdir - --- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for --- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial --- by a worker thread using a dedicated database connection. --- This is done in order to serialize writes to the database, or else SQLite becomes unhappy -runWithDb :: FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO () -runWithDb fp k = do - -- Delete the database if it has an incompatible schema version - withHieDb fp (const $ pure ()) - `catch` \IncompatibleSchemaVersion{} -> removeFile fp - withHieDb fp $ \writedb -> do - initConn writedb - chan <- newTQueueIO - withAsync (writerThread writedb chan) $ \_ -> do - withHieDb fp (flip k chan) - where - writerThread db chan = do - -- Clear the index of any files that might have been deleted since the last run - deleteMissingRealFiles db - _ <- garbageCollectTypeNames db - forever $ do - k <- atomically $ readTQueue chan - k db - `catch` \e@SQLError{} -> do - hPutStrLn stderr $ "SQLite error in worker, ignoring: " ++ show e - `catchAny` \e -> do - hPutStrLn stderr $ "Uncaught error in database worker, ignoring: " ++ show e - - -getHieDbLoc :: FilePath -> IO FilePath -getHieDbLoc dir = do - let db = dirHash++"-"++takeBaseName dir++"-"++VERSION_ghc <.> "hiedb" - dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir - cDir <- IO.getXdgDirectory IO.XdgCache cacheDir - createDirectoryIfMissing True cDir - pure (cDir db) - --- | Given a root directory, return a Shake 'Action' which setups an --- 'IdeGhcSession' given a file. --- Some of the many things this does: --- --- * Find the cradle for the file --- * Get the session options, --- * Get the GHC lib directory --- * Make sure the GHC compiletime and runtime versions match --- * Restart the Shake session --- --- This is the key function which implements multi-component support. All --- components mapping to the same hie.yaml file are mapped to the same --- HscEnv which is updated as new components are discovered. -loadSession :: FilePath -> IO (Action IdeGhcSession) -loadSession = loadSessionWithOptions def - -loadSessionWithOptions :: SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) -loadSessionWithOptions SessionLoadingOptions{..} dir = do - -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file - hscEnvs <- newVar Map.empty :: IO (Var HieMap) - -- Mapping from a Filepath to HscEnv - fileToFlags <- newVar Map.empty :: IO (Var FlagsMap) - -- Mapping from a Filepath to its 'hie.yaml' location. - -- Should hold the same Filepaths as 'fileToFlags', otherwise - -- they are inconsistent. So, everywhere you modify 'fileToFlags', - -- you have to modify 'filesMap' as well. - filesMap <- newVar HM.empty :: IO (Var FilesMap) - -- Version of the mappings above - version <- newVar 0 - let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version) - let invalidateShakeCache = do - modifyVar_ version (return . succ) - -- This caches the mapping from Mod.hs -> hie.yaml - cradleLoc <- liftIO $ memoIO $ \v -> do - res <- findCradle v - -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path - -- try and normalise that - -- e.g. see https://github.com/haskell/ghcide/issues/126 - res' <- traverse makeAbsolute res - return $ normalise <$> res' - - dummyAs <- async $ return (error "Uninitialised") - runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath]))) - - return $ do - extras@ShakeExtras{logger, restartShakeSession, ideNc, knownTargetsVar, lspEnv - } <- getShakeExtras - - IdeOptions{ optTesting = IdeTesting optTesting - , optCheckProject = getCheckProject - , optCustomDynFlags - , optExtensions - } <- getIdeOptions - - -- populate the knownTargetsVar with all the - -- files in the project so that `knownFiles` can learn about them and - -- we can generate a complete module graph - let extendKnownTargets newTargets = do - knownTargets <- forM newTargets $ \TargetDetails{..} -> - case targetTarget of - TargetFile f -> pure (targetTarget, [f]) - TargetModule _ -> do - found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations - return (targetTarget, found) - modifyVar_ knownTargetsVar $ traverseHashed $ \known -> do - let known' = HM.unionWith (<>) known $ HM.fromList knownTargets - when (known /= known') $ - logDebug logger $ "Known files updated: " <> - T.pack(show $ (HM.map . map) fromNormalizedFilePath known') - evaluate known' - - -- Create a new HscEnv from a hieYaml root and a set of options - -- If the hieYaml file already has an HscEnv, the new component is - -- combined with the components in the old HscEnv into a new HscEnv - -- which contains the union. - let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO (HscEnv, ComponentInfo, [ComponentInfo]) - packageSetup (hieYaml, cfp, opts, libDir) = do - -- Parse DynFlags for the newly discovered component - hscEnv <- emptyHscEnv ideNc libDir - (df, targets) <- evalGhcEnv hscEnv $ - first optCustomDynFlags <$> setOptions opts (hsc_dflags hscEnv) - let deps = componentDependencies opts ++ maybeToList hieYaml - dep_info <- getDependencyInfo deps - -- Now lookup to see whether we are combining with an existing HscEnv - -- or making a new one. The lookup returns the HscEnv and a list of - -- information about other components loaded into the HscEnv - -- (unitId, DynFlag, Targets) - modifyVar hscEnvs $ \m -> do - -- Just deps if there's already an HscEnv - -- Nothing is it's the first time we are making an HscEnv - let oldDeps = Map.lookup hieYaml m - let -- Add the raw information about this component to the list - -- We will modify the unitId and DynFlags used for - -- compilation but these are the true source of - -- information. - new_deps = RawComponentInfo (thisInstalledUnitId df) df targets cfp opts dep_info - : maybe [] snd oldDeps - -- Get all the unit-ids for things in this component - inplace = map rawComponentUnitId new_deps - - new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do - -- Remove all inplace dependencies from package flags for - -- components in this HscEnv - let (df2, uids) = removeInplacePackages inplace rawComponentDynFlags - let prefix = show rawComponentUnitId - -- See Note [Avoiding bad interface files] - let hscComponents = sort $ map show uids - cacheDirOpts = hscComponents ++ componentOptions opts - cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts - processed_df <- setCacheDirs logger cacheDirs df2 - -- The final component information, mostly the same but the DynFlags don't - -- contain any packages which are also loaded - -- into the same component. - pure $ ComponentInfo rawComponentUnitId - processed_df - uids - rawComponentTargets - rawComponentFP - rawComponentCOptions - rawComponentDependencyInfo - -- Make a new HscEnv, we have to recompile everything from - -- scratch again (for now) - -- It's important to keep the same NameCache though for reasons - -- that I do not fully understand - logInfo logger (T.pack ("Making new HscEnv" ++ show inplace)) - hscEnv <- emptyHscEnv ideNc libDir - newHscEnv <- - -- Add the options for the current component to the HscEnv - evalGhcEnv hscEnv $ do - _ <- setSessionDynFlags df - getSession - - -- Modify the map so the hieYaml now maps to the newly created - -- HscEnv - -- Returns - -- . the new HscEnv so it can be used to modify the - -- FilePath -> HscEnv map (fileToFlags) - -- . The information for the new component which caused this cache miss - -- . The modified information (without -inplace flags) for - -- existing packages - pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps')) - - - let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO (IdeResult HscEnvEq,[FilePath]) - session args@(hieYaml, _cfp, _opts, _libDir) = do - (hscEnv, new, old_deps) <- packageSetup args - - -- Whenever we spin up a session on Linux, dynamically load libm.so.6 - -- in. We need this in case the binary is statically linked, in which - -- case the interactive session will fail when trying to load - -- ghc-prim, which happens whenever Template Haskell is being - -- evaluated or haskell-language-server's eval plugin tries to run - -- some code. If the binary is dynamically linked, then this will have - -- no effect. - -- See https://github.com/haskell/haskell-language-server/issues/221 - when (os == "linux") $ do - initObjLinker hscEnv - res <- loadDLL hscEnv "libm.so.6" - case res of - Nothing -> pure () - Just err -> hPutStrLn stderr $ - "Error dynamically loading libm.so.6:\n" <> err - - -- Make a map from unit-id to DynFlags, this is used when trying to - -- resolve imports. (especially PackageImports) - let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps) - - -- For each component, now make a new HscEnvEq which contains the - -- HscEnv for the hie.yaml file but the DynFlags for that component - - -- New HscEnv for the component in question, returns the new HscEnvEq and - -- a mapping from FilePath to the newly created HscEnvEq. - let new_cache = newComponentCache logger optExtensions hieYaml _cfp hscEnv uids - (cs, res) <- new_cache new - -- Modified cache targets for everything else in the hie.yaml file - -- which now uses the same EPS and so on - cached_targets <- concatMapM (fmap fst . new_cache) old_deps - - let all_targets = cs ++ cached_targets - - modifyVar_ fileToFlags $ \var -> do - pure $ Map.insert hieYaml (HM.fromList (concatMap toFlagsMap all_targets)) var - modifyVar_ filesMap $ \var -> do - evaluate $ HM.union var (HM.fromList (zip (map fst $ concatMap toFlagsMap all_targets) (repeat hieYaml))) - - extendKnownTargets all_targets - - -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - invalidateShakeCache - restartShakeSession [] - - -- Typecheck all files in the project on startup - checkProject <- getCheckProject - unless (null cs || not checkProject) $ do - cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations cs) - void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do - mmt <- uses GetModificationTime cfps' - let cs_exist = catMaybes (zipWith (<$) cfps' mmt) - modIfaces <- uses GetModIface cs_exist - -- update exports map - extras <- getShakeExtras - let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces - liftIO $ modifyVar_ (exportsMap extras) $ evaluate . (exportsMap' <>) - - return (second Map.keys res) - - let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) - consultCradle hieYaml cfp = do - lfp <- flip makeRelative cfp <$> getCurrentDirectory - logInfo logger $ T.pack ("Consulting the cradle for " <> show lfp) - - when (isNothing hieYaml) $ mRunLspT lspEnv $ - sendNotification SWindowShowMessage $ notifyUserImplicitCradle lfp - - cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) loadCradle hieYaml - - when optTesting $ mRunLspT lspEnv $ - sendNotification (SCustomMethod "ghcide/cradle/loaded") (toJSON cfp) - - -- Display a user friendly progress message here: They probably don't know what a cradle is - let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) - <> " (for " <> T.pack lfp <> ")" - eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $ - cradleToOptsAndLibDir cradle cfp - - logDebug logger $ T.pack ("Session loading result: " <> show eopts) - case eopts of - -- The cradle gave us some options so get to work turning them - -- into and HscEnv. - Right (opts, libDir) -> do - installationCheck <- ghcVersionChecker libDir - case installationCheck of - InstallationNotFound{..} -> - error $ "GHC installation not found in libdir: " <> libdir - InstallationMismatch{..} -> - return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) - InstallationChecked _compileTime _ghcLibCheck -> - session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) - -- Failure case, either a cradle error or the none cradle - Left err -> do - dep_info <- getDependencyInfo (maybeToList hieYaml) - let ncfp = toNormalizedFilePath' cfp - let res = (map (renderCradleError ncfp) err, Nothing) - modifyVar_ fileToFlags $ \var -> do - pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var - modifyVar_ filesMap $ \var -> do - evaluate $ HM.insert ncfp hieYaml var - return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) - - -- This caches the mapping from hie.yaml + Mod.hs -> [String] - -- Returns the Ghc session and the cradle dependencies - let sessionOpts :: (Maybe FilePath, FilePath) - -> IO (IdeResult HscEnvEq, [FilePath]) - sessionOpts (hieYaml, file) = do - v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags - cfp <- canonicalizePath file - case HM.lookup (toNormalizedFilePath' cfp) v of - Just (opts, old_di) -> do - deps_ok <- checkDependencyInfo old_di - if not deps_ok - then do - -- If the dependencies are out of date then clear both caches and start - -- again. - modifyVar_ fileToFlags (const (return Map.empty)) - -- Keep the same name cache - modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml ) - consultCradle hieYaml cfp - else return (opts, Map.keys old_di) - Nothing -> consultCradle hieYaml cfp - - -- The main function which gets options for a file. We only want one of these running - -- at a time. Therefore the IORef contains the currently running cradle, if we try - -- to get some more options then we wait for the currently running action to finish - -- before attempting to do so. - let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) - getOptions file = do - ncfp <- toNormalizedFilePath' <$> canonicalizePath file - cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap - hieYaml <- cradleLoc file - sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `catch` \e -> - return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) - - returnWithVersion $ \file -> do - opts <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do - -- If the cradle is not finished, then wait for it to finish. - void $ wait as - as <- async $ getOptions file - return (as, wait as) - pure opts - --- | Run the specific cradle on a specific FilePath via hie-bios. --- This then builds dependencies or whatever based on the cradle, gets the --- GHC options/dynflags needed for the session and the GHC library directory - -cradleToOptsAndLibDir :: Show a => Cradle a -> FilePath - -> IO (Either [CradleError] (ComponentOptions, FilePath)) -cradleToOptsAndLibDir cradle file = do - -- Start off by getting the session options - let showLine s = hPutStrLn stderr ("> " ++ s) - hPutStrLn stderr $ "Output from setting up the cradle " <> show cradle - cradleRes <- runCradle (cradleOptsProg cradle) showLine file - case cradleRes of - CradleSuccess r -> do - -- Now get the GHC lib dir - libDirRes <- getRuntimeGhcLibDir cradle - case libDirRes of - -- This is the successful path - CradleSuccess libDir -> pure (Right (r, libDir)) - CradleFail err -> return (Left [err]) - -- For the None cradle perhaps we still want to report an Info - -- message about the fact that the file is being ignored. - CradleNone -> return (Left []) - - CradleFail err -> return (Left [err]) - -- Same here - CradleNone -> return (Left []) - -emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv -emptyHscEnv nc libDir = do - env <- runGhc (Just libDir) getSession - initDynLinker env - pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } } - -data TargetDetails = TargetDetails - { - targetTarget :: !Target, - targetEnv :: !(IdeResult HscEnvEq), - targetDepends :: !DependencyInfo, - targetLocations :: ![NormalizedFilePath] - } - -fromTargetId :: [FilePath] -- ^ import paths - -> [String] -- ^ extensions to consider - -> TargetId - -> IdeResult HscEnvEq - -> DependencyInfo - -> IO [TargetDetails] --- For a target module we consider all the import paths -fromTargetId is exts (GHC.TargetModule mod) env dep = do - let fps = [i moduleNameSlashes mod -<.> ext <> boot - | ext <- exts - , i <- is - , boot <- ["", "-boot"] - ] - locs <- mapM (fmap toNormalizedFilePath' . canonicalizePath) fps - return [TargetDetails (TargetModule mod) env dep locs] --- For a 'TargetFile' we consider all the possible module names -fromTargetId _ _ (GHC.TargetFile f _) env deps = do - nf <- toNormalizedFilePath' <$> canonicalizePath f - return [TargetDetails (TargetFile nf) env deps [nf]] - -toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))] -toFlagsMap TargetDetails{..} = - [ (l, (targetEnv, targetDepends)) | l <- targetLocations] - - -setNameCache :: IORef NameCache -> HscEnv -> HscEnv -setNameCache nc hsc = hsc { hsc_NC = nc } - --- | Create a mapping from FilePaths to HscEnvEqs -newComponentCache - :: Logger - -> [String] -- File extensions to consider - -> Maybe FilePath -- Path to cradle - -> NormalizedFilePath -- Path to file that caused the creation of this component - -> HscEnv - -> [(InstalledUnitId, DynFlags)] - -> ComponentInfo - -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo)) -newComponentCache logger exts cradlePath cfp hsc_env uids ci = do - let df = componentDynFlags ci - let hscEnv' = hsc_env { hsc_dflags = df - , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } } - - let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath - henv <- newFunc hscEnv' uids - let targetEnv = ([], Just henv) - targetDepends = componentDependencyInfo ci - res = (targetEnv, targetDepends) - logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res)) - - let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends - ctargets <- concatMapM mk (componentTargets ci) - - -- A special target for the file which caused this wonderful - -- component to be created. In case the cradle doesn't list all the targets for - -- the component, in which case things will be horribly broken anyway. - -- Otherwise, we will immediately attempt to reload this module which - -- causes an infinite loop and high CPU usage. - let special_target = TargetDetails (TargetFile cfp) targetEnv targetDepends [componentFP ci] - return (special_target:ctargets, res) - -{- Note [Avoiding bad interface files] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Originally, we set the cache directory for the various components once -on the first occurrence of the component. -This works fine if these components have no references to each other, -but you have components that depend on each other, the interface files are -updated for each component. -After restarting the session and only opening the component that depended -on the other, suddenly the interface files of this component are stale. -However, from the point of view of `ghcide`, they do not look stale, -thus, not regenerated and the IDE shows weird errors such as: -``` -typecheckIface -Declaration for Rep_ClientRunFlags -Axiom branches Rep_ClientRunFlags: - Failed to load interface for ‘Distribution.Simple.Flag’ - Use -v to see a list of the files searched for. -``` -and -``` -expectJust checkFamInstConsistency -CallStack (from HasCallStack): - error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes - expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst -``` - -To mitigate this, we set the cache directory for each component dependent -on the components of the current `HscEnv`, additionally to the component options -of the respective components. -Assume two components, c1, c2, where c2 depends on c1, and the options of the -respective components are co1, co2. -If we want to load component c2, followed by c1, we set the cache directory for -each component in this way: - - * Load component c2 - * (Cache Directory State) - - name of c2 + co2 - * Load component c1 - * (Cache Directory State) - - name of c2 + name of c1 + co2 - - name of c2 + name of c1 + co1 - -Overall, we created three cache directories. If we opened c1 first, then we -create a fourth cache directory. -This makes sure that interface files are always correctly updated. - -Since this causes a lot of recompilation, we only update the cache-directory, -if the dependencies of a component have really changed. -E.g. when you load two executables, they can not depend on each other. They -should be filtered out, such that we dont have to re-compile everything. --} - --- | Set the cache-directory based on the ComponentOptions and a list of --- internal packages. --- For the exact reason, see Note [Avoiding bad interface files]. -setCacheDirs :: MonadIO m => Logger -> CacheDirs -> DynFlags -> m DynFlags -setCacheDirs logger CacheDirs{..} dflags = do - liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack (fromMaybe cacheDir hiCacheDir) - pure $ dflags - & maybe id setHiDir hiCacheDir - & maybe id setHieDir hieCacheDir - & maybe id setODir oCacheDir - - -renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic -renderCradleError nfp (CradleError _ _ec t) = - ideErrorWithSource (Just "cradle") (Just DsError) nfp (T.unlines (map T.pack t)) - --- See Note [Multi Cradle Dependency Info] -type DependencyInfo = Map.Map FilePath (Maybe UTCTime) -type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo]) --- | Maps a "hie.yaml" location to all its Target Filepaths and options. -type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) --- | Maps a Filepath to its respective "hie.yaml" location. --- It aims to be the reverse of 'FlagsMap'. -type FilesMap = HM.HashMap NormalizedFilePath (Maybe FilePath) - --- This is pristine information about a component -data RawComponentInfo = RawComponentInfo - { rawComponentUnitId :: InstalledUnitId - -- | Unprocessed DynFlags. Contains inplace packages such as libraries. - -- We do not want to use them unprocessed. - , rawComponentDynFlags :: DynFlags - -- | All targets of this components. - , rawComponentTargets :: [GHC.Target] - -- | Filepath which caused the creation of this component - , rawComponentFP :: NormalizedFilePath - -- | Component Options used to load the component. - , rawComponentCOptions :: ComponentOptions - -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file - -- to last modification time. See Note [Multi Cradle Dependency Info]. - , rawComponentDependencyInfo :: DependencyInfo - } - --- This is processed information about the component, in particular the dynflags will be modified. -data ComponentInfo = ComponentInfo - { componentUnitId :: InstalledUnitId - -- | Processed DynFlags. Does not contain inplace packages such as local - -- libraries. Can be used to actually load this Component. - , componentDynFlags :: DynFlags - -- | Internal units, such as local libraries, that this component - -- is loaded with. These have been extracted from the original - -- ComponentOptions. - , _componentInternalUnits :: [InstalledUnitId] - -- | All targets of this components. - , componentTargets :: [GHC.Target] - -- | Filepath which caused the creation of this component - , componentFP :: NormalizedFilePath - -- | Component Options used to load the component. - , _componentCOptions :: ComponentOptions - -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file - -- to last modification time. See Note [Multi Cradle Dependency Info] - , componentDependencyInfo :: DependencyInfo - } - --- | Check if any dependency has been modified lately. -checkDependencyInfo :: DependencyInfo -> IO Bool -checkDependencyInfo old_di = do - di <- getDependencyInfo (Map.keys old_di) - return (di == old_di) - --- Note [Multi Cradle Dependency Info] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Why do we implement our own file modification tracking here? --- The primary reason is that the custom caching logic is quite complicated and going into shake --- adds even more complexity and more indirection. I did try for about 5 hours to work out how to --- use shake rules rather than IO but eventually gave up. - --- | Computes a mapping from a filepath to its latest modification date. --- See Note [Multi Cradle Dependency Info] why we do this ourselves instead --- of letting shake take care of it. -getDependencyInfo :: [FilePath] -> IO DependencyInfo -getDependencyInfo fs = Map.fromList <$> mapM do_one fs - - where - tryIO :: IO a -> IO (Either IOException a) - tryIO = try - - do_one :: FilePath -> IO (FilePath, Maybe UTCTime) - do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp) - --- | This function removes all the -package flags which refer to packages we --- are going to deal with ourselves. For example, if a executable depends --- on a library component, then this function will remove the library flag --- from the package flags for the executable --- --- There are several places in GHC (for example the call to hptInstances in --- tcRnImports) which assume that all modules in the HPT have the same unit --- ID. Therefore we create a fake one and give them all the same unit id. -removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId]) -removeInplacePackages us df = (df { packageFlags = ps - , thisInstalledUnitId = fake_uid }, uids) - where - (uids, ps) = partitionEithers (map go (packageFlags df)) - fake_uid = toInstalledUnitId (stringToUnitId "fake_uid") - go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us - then Left (toInstalledUnitId u) - else Right p - go p = Right p - --- | Memoize an IO function, with the characteristics: --- --- * If multiple people ask for a result simultaneously, make sure you only compute it once. --- --- * If there are exceptions, repeatedly reraise them. --- --- * If the caller is aborted (async exception) finish computing it anyway. -memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b) -memoIO op = do - ref <- newVar Map.empty - return $ \k -> join $ mask_ $ modifyVar ref $ \mp -> - case Map.lookup k mp of - Nothing -> do - res <- onceFork $ op k - return (Map.insert k res mp, res) - Just res -> return (mp, res) - --- | Throws if package flags are unsatisfiable -setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [GHC.Target]) -setOptions (ComponentOptions theOpts compRoot _) dflags = do - (dflags', targets') <- addCmdOpts theOpts dflags - let targets = makeTargetsAbsolute compRoot targets' - let dflags'' = - disableWarningsAsErrors $ - -- disabled, generated directly by ghcide instead - flip gopt_unset Opt_WriteInterface $ - -- disabled, generated directly by ghcide instead - -- also, it can confuse the interface stale check - dontWriteHieFiles $ - setIgnoreInterfacePragmas $ - setLinkerOptions $ - disableOptimisation $ - setUpTypedHoles $ - makeDynFlagsAbsolute compRoot dflags' - -- initPackages parses the -package flags and - -- sets up the visibility for each component. - -- Throws if a -package flag cannot be satisfied. - (final_df, _) <- liftIO $ wrapPackageSetupException $ initPackages dflags'' - return (final_df, targets) - - --- we don't want to generate object code so we compile to bytecode --- (HscInterpreted) which implies LinkInMemory --- HscInterpreted -setLinkerOptions :: DynFlags -> DynFlags -setLinkerOptions df = df { - ghcLink = LinkInMemory - , hscTarget = HscNothing - , ghcMode = CompManager - } - -setIgnoreInterfacePragmas :: DynFlags -> DynFlags -setIgnoreInterfacePragmas df = - gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges - -disableOptimisation :: DynFlags -> DynFlags -disableOptimisation df = updOptLevel 0 df - -setHiDir :: FilePath -> DynFlags -> DynFlags -setHiDir f d = - -- override user settings to avoid conflicts leading to recompilation - d { hiDir = Just f} - -setODir :: FilePath -> DynFlags -> DynFlags -setODir f d = - -- override user settings to avoid conflicts leading to recompilation - d { objectDir = Just f} - -getCacheDirsDefault :: String -> [String] -> IO CacheDirs -getCacheDirsDefault prefix opts = do - dir <- Just <$> getXdgDirectory XdgCache (cacheDir prefix ++ "-" ++ opts_hash) - return $ CacheDirs dir dir dir - where - -- Create a unique folder per set of different GHC options, assuming that each different set of - -- GHC options will create incompatible interface files. - opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts) - --- | Sub directory for the cache path -cacheDir :: String -cacheDir = "ghcide" - -notifyUserImplicitCradle:: FilePath -> ShowMessageParams -notifyUserImplicitCradle fp =ShowMessageParams MtWarning $ - "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for " - <> T.pack fp <> - ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n"<> - "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." ----------------------------------------------------------------------------------------------------- - -data PackageSetupException - = PackageSetupException - { message :: !String - } - | GhcVersionMismatch - { compileTime :: !Version - , runTime :: !Version - } - | PackageCheckFailed !NotCompatibleReason - deriving (Eq, Show, Typeable) - -instance Exception PackageSetupException - --- | Wrap any exception as a 'PackageSetupException' -wrapPackageSetupException :: IO a -> IO a -wrapPackageSetupException = handleAny $ \case - e | Just (pkgE :: PackageSetupException) <- fromException e -> throwIO pkgE - e -> (throwIO . PackageSetupException . show) e - -showPackageSetupException :: PackageSetupException -> String -showPackageSetupException GhcVersionMismatch{..} = unwords - ["ghcide compiled against GHC" - ,showVersion compileTime - ,"but currently using" - ,showVersion runTime - ,"\nThis is unsupported, ghcide must be compiled with the same GHC version as the project." - ] -showPackageSetupException PackageSetupException{..} = unwords - [ "ghcide compiled by GHC", showVersion compilerVersion - , "failed to load packages:", message <> "." - , "\nPlease ensure that ghcide is compiled with the same GHC installation as the project."] -showPackageSetupException (PackageCheckFailed PackageVersionMismatch{..}) = unwords - ["ghcide compiled with package " - , packageName <> "-" <> showVersion compileTime - ,"but project uses package" - , packageName <> "-" <> showVersion runTime - ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project." - ] -showPackageSetupException (PackageCheckFailed BasePackageAbiMismatch{..}) = unwords - ["ghcide compiled with base-" <> showVersion compileTime <> "-" <> compileTimeAbi - ,"but project uses base-" <> showVersion compileTime <> "-" <> runTimeAbi - ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project." - ] - -renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic) -renderPackageSetupException fp e = - ideErrorWithSource (Just "cradle") (Just DsError) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +#include "ghc-api-version.h" + +{-| +The logic for setting up a ghcide session by tapping into hie-bios. +-} +module Development.IDE.Session + (SessionLoadingOptions(..) + ,CacheDirs(..) + ,loadSession + ,loadSessionWithOptions + ,setInitialDynFlags + ,getHieDbLoc + ,runWithDb + ) where + +-- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses +-- the real GHC library and the types are incompatible. Furthermore, when +-- building with ghc-lib we need to make this Haskell agnostic, so no hie-bios! + +import Control.Concurrent.Async +import Control.Concurrent.Strict +import Control.Exception.Safe +import Control.Monad +import Control.Monad.Extra +import Control.Monad.IO.Class +import qualified Crypto.Hash.SHA1 as H +import Data.Aeson +import Data.Bifunctor +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Char8 as B +import Data.Default +import Data.Either.Extra +import Data.Function +import qualified Data.HashMap.Strict as HM +import Data.Hashable +import Data.IORef +import Data.List +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.Text as T +import Data.Time.Clock +import Data.Version +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat hiding (Target, + TargetFile, TargetModule) +import qualified Development.IDE.GHC.Compat as GHC +import Development.IDE.GHC.Util +import Development.IDE.Session.VersionCheck +import Development.IDE.Types.Diagnostics +import Development.IDE.Types.Exports +import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq, + newHscEnvEqPreserveImportPaths) +import Development.IDE.Types.Location +import Development.IDE.Types.Logger +import Development.IDE.Types.Options +import Development.Shake (Action) +import GHC.Check +import qualified HIE.Bios as HieBios +import HIE.Bios.Environment hiding (getCacheDir) +import HIE.Bios.Types +import Hie.Implicit.Cradle (loadImplicitHieCradle) +import Language.LSP.Server +import Language.LSP.Types +import System.Directory +import qualified System.Directory.Extra as IO +import System.FilePath +import System.IO +import System.Info + +import Control.Applicative (Alternative ((<|>))) +import Control.Exception (evaluate) +import Data.Void +import GHCi +import HscTypes (hsc_IC, hsc_NC, + hsc_dflags, ic_dflags) +import Linker +import Module +import NameCache +import Packages + +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TQueue +import Database.SQLite.Simple +import HIE.Bios.Cradle (yamlConfig) +import HieDb.Create +import HieDb.Types +import HieDb.Utils +import Maybes (MaybeT (runMaybeT)) + +-- | Bump this version number when making changes to the format of the data stored in hiedb +hiedbDataVersion :: String +hiedbDataVersion = "1" + +data CacheDirs = CacheDirs + { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath} + +data SessionLoadingOptions = SessionLoadingOptions + { findCradle :: FilePath -> IO (Maybe FilePath) + , loadCradle :: FilePath -> IO (HieBios.Cradle Void) + -- | Given the project name and a set of command line flags, + -- return the path for storing generated GHC artifacts, + -- or 'Nothing' to respect the cradle setting + , getCacheDirs :: String -> [String] -> IO CacheDirs + -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags' + , getInitialGhcLibDir :: IO (Maybe LibDir) + , fakeUid :: InstalledUnitId + -- ^ unit id used to tag the internal component built by ghcide + -- To reuse external interface files the unit ids must match, + -- thus make sure to build them with `--this-unit-id` set to the + -- same value as the ghcide fake uid + } + +instance Default SessionLoadingOptions where + def = SessionLoadingOptions + {findCradle = HieBios.findCradle + ,loadCradle = HieBios.loadCradle + ,getCacheDirs = getCacheDirsDefault + ,getInitialGhcLibDir = getInitialGhcLibDirDefault + ,fakeUid = toInstalledUnitId (stringToUnitId "main") + } + +getInitialGhcLibDirDefault :: IO (Maybe LibDir) +getInitialGhcLibDirDefault = do + dir <- IO.getCurrentDirectory + hieYaml <- runMaybeT $ yamlConfig dir + cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) HieBios.loadCradle hieYaml + hPutStrLn stderr $ "setInitialDynFlags cradle: " ++ show cradle + libDirRes <- getRuntimeGhcLibDir cradle + case libDirRes of + CradleSuccess libdir -> pure $ Just $ LibDir libdir + CradleFail err -> do + hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show (err,dir,hieYaml,cradle) + pure Nothing + CradleNone -> do + hPutStrLn stderr "Couldn't load cradle (CradleNone)" + pure Nothing + +-- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir +setInitialDynFlags :: SessionLoadingOptions -> IO (Maybe LibDir) +setInitialDynFlags SessionLoadingOptions{..} = do + libdir <- getInitialGhcLibDir + dynFlags <- mapM dynFlagsForPrinting libdir + mapM_ setUnsafeGlobalDynFlags dynFlags + pure libdir + +-- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for +-- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial +-- by a worker thread using a dedicated database connection. +-- This is done in order to serialize writes to the database, or else SQLite becomes unhappy +runWithDb :: FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO () +runWithDb fp k = do + -- Delete the database if it has an incompatible schema version + withHieDb fp (const $ pure ()) + `catch` \IncompatibleSchemaVersion{} -> removeFile fp + withHieDb fp $ \writedb -> do + initConn writedb + chan <- newTQueueIO + withAsync (writerThread writedb chan) $ \_ -> do + withHieDb fp (flip k chan) + where + writerThread db chan = do + -- Clear the index of any files that might have been deleted since the last run + deleteMissingRealFiles db + _ <- garbageCollectTypeNames db + forever $ do + k <- atomically $ readTQueue chan + k db + `catch` \e@SQLError{} -> do + hPutStrLn stderr $ "SQLite error in worker, ignoring: " ++ show e + `catchAny` \e -> do + hPutStrLn stderr $ "Uncaught error in database worker, ignoring: " ++ show e + + +getHieDbLoc :: FilePath -> IO FilePath +getHieDbLoc dir = do + let db = intercalate "-" [dirHash, takeBaseName dir, VERSION_ghc, hiedbDataVersion] <.> "hiedb" + dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir + cDir <- IO.getXdgDirectory IO.XdgCache cacheDir + createDirectoryIfMissing True cDir + pure (cDir db) + +-- | Given a root directory, return a Shake 'Action' which setups an +-- 'IdeGhcSession' given a file. +-- Some of the many things this does: +-- +-- * Find the cradle for the file +-- * Get the session options, +-- * Get the GHC lib directory +-- * Make sure the GHC compiletime and runtime versions match +-- * Restart the Shake session +-- +-- This is the key function which implements multi-component support. All +-- components mapping to the same hie.yaml file are mapped to the same +-- HscEnv which is updated as new components are discovered. +loadSession :: FilePath -> IO (Action IdeGhcSession) +loadSession = loadSessionWithOptions def + +loadSessionWithOptions :: SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) +loadSessionWithOptions SessionLoadingOptions{..} dir = do + -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file + hscEnvs <- newVar Map.empty :: IO (Var HieMap) + -- Mapping from a Filepath to HscEnv + fileToFlags <- newVar Map.empty :: IO (Var FlagsMap) + -- Mapping from a Filepath to its 'hie.yaml' location. + -- Should hold the same Filepaths as 'fileToFlags', otherwise + -- they are inconsistent. So, everywhere you modify 'fileToFlags', + -- you have to modify 'filesMap' as well. + filesMap <- newVar HM.empty :: IO (Var FilesMap) + -- Version of the mappings above + version <- newVar 0 + let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version) + let invalidateShakeCache = do + void $ modifyVar' version succ + -- This caches the mapping from Mod.hs -> hie.yaml + cradleLoc <- liftIO $ memoIO $ \v -> do + res <- findCradle v + -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path + -- try and normalise that + -- e.g. see https://github.com/haskell/ghcide/issues/126 + res' <- traverse makeAbsolute res + return $ normalise <$> res' + + dummyAs <- async $ return (error "Uninitialised") + runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath]))) + + return $ do + extras@ShakeExtras{logger, restartShakeSession, ideNc, knownTargetsVar, lspEnv + } <- getShakeExtras + + IdeOptions{ optTesting = IdeTesting optTesting + , optCheckProject = getCheckProject + , optCustomDynFlags + , optExtensions + } <- getIdeOptions + + -- populate the knownTargetsVar with all the + -- files in the project so that `knownFiles` can learn about them and + -- we can generate a complete module graph + let extendKnownTargets newTargets = do + knownTargets <- forM newTargets $ \TargetDetails{..} -> + case targetTarget of + TargetFile f -> pure (targetTarget, [f]) + TargetModule _ -> do + found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations + return (targetTarget, found) + modifyVarIO' knownTargetsVar $ traverseHashed $ \known -> do + let known' = HM.unionWith (<>) known $ HM.fromList knownTargets + when (known /= known') $ + logDebug logger $ "Known files updated: " <> + T.pack(show $ (HM.map . map) fromNormalizedFilePath known') + pure known' + + -- Create a new HscEnv from a hieYaml root and a set of options + -- If the hieYaml file already has an HscEnv, the new component is + -- combined with the components in the old HscEnv into a new HscEnv + -- which contains the union. + let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) + -> IO (HscEnv, ComponentInfo, [ComponentInfo]) + packageSetup (hieYaml, cfp, opts, libDir) = do + -- Parse DynFlags for the newly discovered component + hscEnv <- emptyHscEnv ideNc libDir + (df, targets) <- evalGhcEnv hscEnv $ + first optCustomDynFlags <$> setOptions opts (hsc_dflags hscEnv) + let deps = componentDependencies opts ++ maybeToList hieYaml + dep_info <- getDependencyInfo deps + -- Now lookup to see whether we are combining with an existing HscEnv + -- or making a new one. The lookup returns the HscEnv and a list of + -- information about other components loaded into the HscEnv + -- (unitId, DynFlag, Targets) + modifyVar hscEnvs $ \m -> do + -- Just deps if there's already an HscEnv + -- Nothing is it's the first time we are making an HscEnv + let oldDeps = Map.lookup hieYaml m + let -- Add the raw information about this component to the list + -- We will modify the unitId and DynFlags used for + -- compilation but these are the true source of + -- information. + new_deps = RawComponentInfo (thisInstalledUnitId df) df targets cfp opts dep_info + : maybe [] snd oldDeps + -- Get all the unit-ids for things in this component + inplace = map rawComponentUnitId new_deps + + new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do + -- Remove all inplace dependencies from package flags for + -- components in this HscEnv + let (df2, uids) = removeInplacePackages fakeUid inplace rawComponentDynFlags + let prefix = show rawComponentUnitId + -- See Note [Avoiding bad interface files] + let hscComponents = sort $ map show uids + cacheDirOpts = hscComponents ++ componentOptions opts + cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts + processed_df <- setCacheDirs logger cacheDirs df2 + -- The final component information, mostly the same but the DynFlags don't + -- contain any packages which are also loaded + -- into the same component. + pure $ ComponentInfo rawComponentUnitId + processed_df + uids + rawComponentTargets + rawComponentFP + rawComponentCOptions + rawComponentDependencyInfo + -- Make a new HscEnv, we have to recompile everything from + -- scratch again (for now) + -- It's important to keep the same NameCache though for reasons + -- that I do not fully understand + logInfo logger (T.pack ("Making new HscEnv" ++ show inplace)) + hscEnv <- emptyHscEnv ideNc libDir + newHscEnv <- + -- Add the options for the current component to the HscEnv + evalGhcEnv hscEnv $ do + _ <- setSessionDynFlags df + getSession + + -- Modify the map so the hieYaml now maps to the newly created + -- HscEnv + -- Returns + -- . the new HscEnv so it can be used to modify the + -- FilePath -> HscEnv map (fileToFlags) + -- . The information for the new component which caused this cache miss + -- . The modified information (without -inplace flags) for + -- existing packages + pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps')) + + + let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) + -> IO (IdeResult HscEnvEq,[FilePath]) + session args@(hieYaml, _cfp, _opts, _libDir) = do + (hscEnv, new, old_deps) <- packageSetup args + + -- Whenever we spin up a session on Linux, dynamically load libm.so.6 + -- in. We need this in case the binary is statically linked, in which + -- case the interactive session will fail when trying to load + -- ghc-prim, which happens whenever Template Haskell is being + -- evaluated or haskell-language-server's eval plugin tries to run + -- some code. If the binary is dynamically linked, then this will have + -- no effect. + -- See https://github.com/haskell/haskell-language-server/issues/221 + when (os == "linux") $ do + initObjLinker hscEnv + res <- loadDLL hscEnv "libm.so.6" + case res of + Nothing -> pure () + Just err -> hPutStrLn stderr $ + "Error dynamically loading libm.so.6:\n" <> err + + -- Make a map from unit-id to DynFlags, this is used when trying to + -- resolve imports. (especially PackageImports) + let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps) + + -- For each component, now make a new HscEnvEq which contains the + -- HscEnv for the hie.yaml file but the DynFlags for that component + + -- New HscEnv for the component in question, returns the new HscEnvEq and + -- a mapping from FilePath to the newly created HscEnvEq. + let new_cache = newComponentCache logger optExtensions hieYaml _cfp hscEnv uids + (cs, res) <- new_cache new + -- Modified cache targets for everything else in the hie.yaml file + -- which now uses the same EPS and so on + cached_targets <- concatMapM (fmap fst . new_cache) old_deps + + let all_targets = cs ++ cached_targets + + void $ modifyVar' fileToFlags $ + Map.insert hieYaml (HM.fromList (concatMap toFlagsMap all_targets)) + void $ modifyVar' filesMap $ + flip HM.union (HM.fromList (zip (map fst $ concatMap toFlagsMap all_targets) (repeat hieYaml))) + + void $ extendKnownTargets all_targets + + -- Invalidate all the existing GhcSession build nodes by restarting the Shake session + invalidateShakeCache + restartShakeSession [] + + -- Typecheck all files in the project on startup + checkProject <- getCheckProject + unless (null cs || not checkProject) $ do + cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations cs) + void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do + mmt <- uses GetModificationTime cfps' + let cs_exist = catMaybes (zipWith (<$) cfps' mmt) + modIfaces <- uses GetModIface cs_exist + -- update exports map + extras <- getShakeExtras + let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces + liftIO $ modifyVar_ (exportsMap extras) $ evaluate . (exportsMap' <>) + + return (second Map.keys res) + + let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) + consultCradle hieYaml cfp = do + lfp <- flip makeRelative cfp <$> getCurrentDirectory + logInfo logger $ T.pack ("Consulting the cradle for " <> show lfp) + + when (isNothing hieYaml) $ + logWarning logger $ implicitCradleWarning lfp + + cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) loadCradle hieYaml + + when optTesting $ mRunLspT lspEnv $ + sendNotification (SCustomMethod "ghcide/cradle/loaded") (toJSON cfp) + + -- Display a user friendly progress message here: They probably don't know what a cradle is + let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) + <> " (for " <> T.pack lfp <> ")" + eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $ + cradleToOptsAndLibDir cradle cfp + + logDebug logger $ T.pack ("Session loading result: " <> show eopts) + case eopts of + -- The cradle gave us some options so get to work turning them + -- into and HscEnv. + Right (opts, libDir) -> do + installationCheck <- ghcVersionChecker libDir + case installationCheck of + InstallationNotFound{..} -> + error $ "GHC installation not found in libdir: " <> libdir + InstallationMismatch{..} -> + return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) + InstallationChecked _compileTime _ghcLibCheck -> + session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) + -- Failure case, either a cradle error or the none cradle + Left err -> do + dep_info <- getDependencyInfo (maybeToList hieYaml) + let ncfp = toNormalizedFilePath' cfp + let res = (map (renderCradleError ncfp) err, Nothing) + void $ modifyVar' fileToFlags $ + Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) + void $ modifyVar' filesMap $ HM.insert ncfp hieYaml + return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) + + -- This caches the mapping from hie.yaml + Mod.hs -> [String] + -- Returns the Ghc session and the cradle dependencies + let sessionOpts :: (Maybe FilePath, FilePath) + -> IO (IdeResult HscEnvEq, [FilePath]) + sessionOpts (hieYaml, file) = do + v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags + cfp <- canonicalizePath file + case HM.lookup (toNormalizedFilePath' cfp) v of + Just (opts, old_di) -> do + deps_ok <- checkDependencyInfo old_di + if not deps_ok + then do + -- If the dependencies are out of date then clear both caches and start + -- again. + modifyVar_ fileToFlags (const (return Map.empty)) + -- Keep the same name cache + modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml ) + consultCradle hieYaml cfp + else return (opts, Map.keys old_di) + Nothing -> consultCradle hieYaml cfp + + -- The main function which gets options for a file. We only want one of these running + -- at a time. Therefore the IORef contains the currently running cradle, if we try + -- to get some more options then we wait for the currently running action to finish + -- before attempting to do so. + let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) + getOptions file = do + ncfp <- toNormalizedFilePath' <$> canonicalizePath file + cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap + hieYaml <- cradleLoc file + sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `catch` \e -> + return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) + + returnWithVersion $ \file -> do + opts <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do + -- If the cradle is not finished, then wait for it to finish. + void $ wait as + as <- async $ getOptions file + return (as, wait as) + pure opts + +-- | Run the specific cradle on a specific FilePath via hie-bios. +-- This then builds dependencies or whatever based on the cradle, gets the +-- GHC options/dynflags needed for the session and the GHC library directory + +cradleToOptsAndLibDir :: Show a => Cradle a -> FilePath + -> IO (Either [CradleError] (ComponentOptions, FilePath)) +cradleToOptsAndLibDir cradle file = do + -- Start off by getting the session options + let showLine s = hPutStrLn stderr ("> " ++ s) + hPutStrLn stderr $ "Output from setting up the cradle " <> show cradle + cradleRes <- runCradle (cradleOptsProg cradle) showLine file + case cradleRes of + CradleSuccess r -> do + -- Now get the GHC lib dir + libDirRes <- getRuntimeGhcLibDir cradle + case libDirRes of + -- This is the successful path + CradleSuccess libDir -> pure (Right (r, libDir)) + CradleFail err -> return (Left [err]) + -- For the None cradle perhaps we still want to report an Info + -- message about the fact that the file is being ignored. + CradleNone -> return (Left []) + + CradleFail err -> return (Left [err]) + -- Same here + CradleNone -> return (Left []) + +emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv +emptyHscEnv nc libDir = do + env <- runGhc (Just libDir) getSession + initDynLinker env + pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } } + +data TargetDetails = TargetDetails + { + targetTarget :: !Target, + targetEnv :: !(IdeResult HscEnvEq), + targetDepends :: !DependencyInfo, + targetLocations :: ![NormalizedFilePath] + } + +fromTargetId :: [FilePath] -- ^ import paths + -> [String] -- ^ extensions to consider + -> TargetId + -> IdeResult HscEnvEq + -> DependencyInfo + -> IO [TargetDetails] +-- For a target module we consider all the import paths +fromTargetId is exts (GHC.TargetModule mod) env dep = do + let fps = [i moduleNameSlashes mod -<.> ext <> boot + | ext <- exts + , i <- is + , boot <- ["", "-boot"] + ] + locs <- mapM (fmap toNormalizedFilePath' . canonicalizePath) fps + return [TargetDetails (TargetModule mod) env dep locs] +-- For a 'TargetFile' we consider all the possible module names +fromTargetId _ _ (GHC.TargetFile f _) env deps = do + nf <- toNormalizedFilePath' <$> canonicalizePath f + return [TargetDetails (TargetFile nf) env deps [nf]] + +toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))] +toFlagsMap TargetDetails{..} = + [ (l, (targetEnv, targetDepends)) | l <- targetLocations] + + +setNameCache :: IORef NameCache -> HscEnv -> HscEnv +setNameCache nc hsc = hsc { hsc_NC = nc } + +-- | Create a mapping from FilePaths to HscEnvEqs +newComponentCache + :: Logger + -> [String] -- File extensions to consider + -> Maybe FilePath -- Path to cradle + -> NormalizedFilePath -- Path to file that caused the creation of this component + -> HscEnv + -> [(InstalledUnitId, DynFlags)] + -> ComponentInfo + -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo)) +newComponentCache logger exts cradlePath cfp hsc_env uids ci = do + let df = componentDynFlags ci + let hscEnv' = hsc_env { hsc_dflags = df + , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } } + + let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath + henv <- newFunc hscEnv' uids + let targetEnv = ([], Just henv) + targetDepends = componentDependencyInfo ci + res = (targetEnv, targetDepends) + logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res)) + + let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends + ctargets <- concatMapM mk (componentTargets ci) + + -- A special target for the file which caused this wonderful + -- component to be created. In case the cradle doesn't list all the targets for + -- the component, in which case things will be horribly broken anyway. + -- Otherwise, we will immediately attempt to reload this module which + -- causes an infinite loop and high CPU usage. + let special_target = TargetDetails (TargetFile cfp) targetEnv targetDepends [componentFP ci] + return (special_target:ctargets, res) + +{- Note [Avoiding bad interface files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Originally, we set the cache directory for the various components once +on the first occurrence of the component. +This works fine if these components have no references to each other, +but you have components that depend on each other, the interface files are +updated for each component. +After restarting the session and only opening the component that depended +on the other, suddenly the interface files of this component are stale. +However, from the point of view of `ghcide`, they do not look stale, +thus, not regenerated and the IDE shows weird errors such as: +``` +typecheckIface +Declaration for Rep_ClientRunFlags +Axiom branches Rep_ClientRunFlags: + Failed to load interface for ‘Distribution.Simple.Flag’ + Use -v to see a list of the files searched for. +``` +and +``` +expectJust checkFamInstConsistency +CallStack (from HasCallStack): + error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes + expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst +``` + +To mitigate this, we set the cache directory for each component dependent +on the components of the current `HscEnv`, additionally to the component options +of the respective components. +Assume two components, c1, c2, where c2 depends on c1, and the options of the +respective components are co1, co2. +If we want to load component c2, followed by c1, we set the cache directory for +each component in this way: + + * Load component c2 + * (Cache Directory State) + - name of c2 + co2 + * Load component c1 + * (Cache Directory State) + - name of c2 + name of c1 + co2 + - name of c2 + name of c1 + co1 + +Overall, we created three cache directories. If we opened c1 first, then we +create a fourth cache directory. +This makes sure that interface files are always correctly updated. + +Since this causes a lot of recompilation, we only update the cache-directory, +if the dependencies of a component have really changed. +E.g. when you load two executables, they can not depend on each other. They +should be filtered out, such that we dont have to re-compile everything. +-} + +-- | Set the cache-directory based on the ComponentOptions and a list of +-- internal packages. +-- For the exact reason, see Note [Avoiding bad interface files]. +setCacheDirs :: MonadIO m => Logger -> CacheDirs -> DynFlags -> m DynFlags +setCacheDirs logger CacheDirs{..} dflags = do + liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack (fromMaybe cacheDir hiCacheDir) + pure $ dflags + & maybe id setHiDir hiCacheDir + & maybe id setHieDir hieCacheDir + & maybe id setODir oCacheDir + + +renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic +renderCradleError nfp (CradleError _ _ec t) = + ideErrorWithSource (Just "cradle") (Just DsError) nfp (T.unlines (map T.pack t)) + +-- See Note [Multi Cradle Dependency Info] +type DependencyInfo = Map.Map FilePath (Maybe UTCTime) +type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo]) +-- | Maps a "hie.yaml" location to all its Target Filepaths and options. +type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) +-- | Maps a Filepath to its respective "hie.yaml" location. +-- It aims to be the reverse of 'FlagsMap'. +type FilesMap = HM.HashMap NormalizedFilePath (Maybe FilePath) + +-- This is pristine information about a component +data RawComponentInfo = RawComponentInfo + { rawComponentUnitId :: InstalledUnitId + -- | Unprocessed DynFlags. Contains inplace packages such as libraries. + -- We do not want to use them unprocessed. + , rawComponentDynFlags :: DynFlags + -- | All targets of this components. + , rawComponentTargets :: [GHC.Target] + -- | Filepath which caused the creation of this component + , rawComponentFP :: NormalizedFilePath + -- | Component Options used to load the component. + , rawComponentCOptions :: ComponentOptions + -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file + -- to last modification time. See Note [Multi Cradle Dependency Info]. + , rawComponentDependencyInfo :: DependencyInfo + } + +-- This is processed information about the component, in particular the dynflags will be modified. +data ComponentInfo = ComponentInfo + { componentUnitId :: InstalledUnitId + -- | Processed DynFlags. Does not contain inplace packages such as local + -- libraries. Can be used to actually load this Component. + , componentDynFlags :: DynFlags + -- | Internal units, such as local libraries, that this component + -- is loaded with. These have been extracted from the original + -- ComponentOptions. + , _componentInternalUnits :: [InstalledUnitId] + -- | All targets of this components. + , componentTargets :: [GHC.Target] + -- | Filepath which caused the creation of this component + , componentFP :: NormalizedFilePath + -- | Component Options used to load the component. + , _componentCOptions :: ComponentOptions + -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file + -- to last modification time. See Note [Multi Cradle Dependency Info] + , componentDependencyInfo :: DependencyInfo + } + +-- | Check if any dependency has been modified lately. +checkDependencyInfo :: DependencyInfo -> IO Bool +checkDependencyInfo old_di = do + di <- getDependencyInfo (Map.keys old_di) + return (di == old_di) + +-- Note [Multi Cradle Dependency Info] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Why do we implement our own file modification tracking here? +-- The primary reason is that the custom caching logic is quite complicated and going into shake +-- adds even more complexity and more indirection. I did try for about 5 hours to work out how to +-- use shake rules rather than IO but eventually gave up. + +-- | Computes a mapping from a filepath to its latest modification date. +-- See Note [Multi Cradle Dependency Info] why we do this ourselves instead +-- of letting shake take care of it. +getDependencyInfo :: [FilePath] -> IO DependencyInfo +getDependencyInfo fs = Map.fromList <$> mapM do_one fs + + where + tryIO :: IO a -> IO (Either IOException a) + tryIO = try + + do_one :: FilePath -> IO (FilePath, Maybe UTCTime) + do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp) + +-- | This function removes all the -package flags which refer to packages we +-- are going to deal with ourselves. For example, if a executable depends +-- on a library component, then this function will remove the library flag +-- from the package flags for the executable +-- +-- There are several places in GHC (for example the call to hptInstances in +-- tcRnImports) which assume that all modules in the HPT have the same unit +-- ID. Therefore we create a fake one and give them all the same unit id. +removeInplacePackages + :: InstalledUnitId -- ^ fake uid to use for our internal component + -> [InstalledUnitId] + -> DynFlags + -> (DynFlags, [InstalledUnitId]) +removeInplacePackages fake_uid us df = (df { packageFlags = ps + , thisInstalledUnitId = fake_uid }, uids) + where + (uids, ps) = partitionEithers (map go (packageFlags df)) + go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us + then Left (toInstalledUnitId u) + else Right p + go p = Right p + +-- | Memoize an IO function, with the characteristics: +-- +-- * If multiple people ask for a result simultaneously, make sure you only compute it once. +-- +-- * If there are exceptions, repeatedly reraise them. +-- +-- * If the caller is aborted (async exception) finish computing it anyway. +memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b) +memoIO op = do + ref <- newVar Map.empty + return $ \k -> join $ mask_ $ modifyVar ref $ \mp -> + case Map.lookup k mp of + Nothing -> do + res <- onceFork $ op k + return (Map.insert k res mp, res) + Just res -> return (mp, res) + +-- | Throws if package flags are unsatisfiable +setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [GHC.Target]) +setOptions (ComponentOptions theOpts compRoot _) dflags = do + (dflags', targets') <- addCmdOpts theOpts dflags + let targets = makeTargetsAbsolute compRoot targets' + let dflags'' = + disableWarningsAsErrors $ + -- disabled, generated directly by ghcide instead + flip gopt_unset Opt_WriteInterface $ + -- disabled, generated directly by ghcide instead + -- also, it can confuse the interface stale check + dontWriteHieFiles $ + setIgnoreInterfacePragmas $ + setLinkerOptions $ + disableOptimisation $ + setUpTypedHoles $ + makeDynFlagsAbsolute compRoot dflags' + -- initPackages parses the -package flags and + -- sets up the visibility for each component. + -- Throws if a -package flag cannot be satisfied. + (final_df, _) <- liftIO $ wrapPackageSetupException $ initPackages dflags'' + return (final_df, targets) + + +-- we don't want to generate object code so we compile to bytecode +-- (HscInterpreted) which implies LinkInMemory +-- HscInterpreted +setLinkerOptions :: DynFlags -> DynFlags +setLinkerOptions df = df { + ghcLink = LinkInMemory + , hscTarget = HscNothing + , ghcMode = CompManager + } + +setIgnoreInterfacePragmas :: DynFlags -> DynFlags +setIgnoreInterfacePragmas df = + gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges + +disableOptimisation :: DynFlags -> DynFlags +disableOptimisation df = updOptLevel 0 df + +setHiDir :: FilePath -> DynFlags -> DynFlags +setHiDir f d = + -- override user settings to avoid conflicts leading to recompilation + d { hiDir = Just f} + +setODir :: FilePath -> DynFlags -> DynFlags +setODir f d = + -- override user settings to avoid conflicts leading to recompilation + d { objectDir = Just f} + +getCacheDirsDefault :: String -> [String] -> IO CacheDirs +getCacheDirsDefault prefix opts = do + dir <- Just <$> getXdgDirectory XdgCache (cacheDir prefix ++ "-" ++ opts_hash) + return $ CacheDirs dir dir dir + where + -- Create a unique folder per set of different GHC options, assuming that each different set of + -- GHC options will create incompatible interface files. + opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts) + +-- | Sub directory for the cache path +cacheDir :: String +cacheDir = "ghcide" + +implicitCradleWarning :: FilePath -> T.Text +implicitCradleWarning fp = + "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for " + <> T.pack fp <> + ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n"<> + "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." +---------------------------------------------------------------------------------------------------- + +data PackageSetupException + = PackageSetupException + { message :: !String + } + | GhcVersionMismatch + { compileTime :: !Version + , runTime :: !Version + } + | PackageCheckFailed !NotCompatibleReason + deriving (Eq, Show, Typeable) + +instance Exception PackageSetupException + +-- | Wrap any exception as a 'PackageSetupException' +wrapPackageSetupException :: IO a -> IO a +wrapPackageSetupException = handleAny $ \case + e | Just (pkgE :: PackageSetupException) <- fromException e -> throwIO pkgE + e -> (throwIO . PackageSetupException . show) e + +showPackageSetupException :: PackageSetupException -> String +showPackageSetupException GhcVersionMismatch{..} = unwords + ["ghcide compiled against GHC" + ,showVersion compileTime + ,"but currently using" + ,showVersion runTime + ,"\nThis is unsupported, ghcide must be compiled with the same GHC version as the project." + ] +showPackageSetupException PackageSetupException{..} = unwords + [ "ghcide compiled by GHC", showVersion compilerVersion + , "failed to load packages:", message <> "." + , "\nPlease ensure that ghcide is compiled with the same GHC installation as the project."] +showPackageSetupException (PackageCheckFailed PackageVersionMismatch{..}) = unwords + ["ghcide compiled with package " + , packageName <> "-" <> showVersion compileTime + ,"but project uses package" + , packageName <> "-" <> showVersion runTime + ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project." + ] +showPackageSetupException (PackageCheckFailed BasePackageAbiMismatch{..}) = unwords + ["ghcide compiled with base-" <> showVersion compileTime <> "-" <> compileTimeAbi + ,"but project uses base-" <> showVersion compileTime <> "-" <> runTimeAbi + ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project." + ] + +renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic) +renderPackageSetupException fp e = + ideErrorWithSource (Just "cradle") (Just DsError) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) diff --git a/session-loader/Development/IDE/Session/VersionCheck.hs b/session-loader/Development/IDE/Session/VersionCheck.hs --- a/session-loader/Development/IDE/Session/VersionCheck.hs +++ b/session-loader/Development/IDE/Session/VersionCheck.hs @@ -1,17 +1,17 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | This module exists to circumvent a compile time exception on Windows with --- Stack and GHC 8.10.1. It's just been pulled out from Development.IDE.Session. --- See https://github.com/haskell/ghcide/pull/697 -module Development.IDE.Session.VersionCheck (ghcVersionChecker) where - -import Data.Maybe -import GHC.Check --- Only use this for checking against the compile time GHC libDir! --- Use getRuntimeGhcLibDir from hie-bios instead for everything else --- otherwise binaries will not be distributable since paths will be baked into them -import qualified GHC.Paths -import System.Environment - -ghcVersionChecker :: GhcVersionChecker -ghcVersionChecker = $$(makeGhcVersionChecker (fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR")) +{-# LANGUAGE TemplateHaskell #-} + +-- | This module exists to circumvent a compile time exception on Windows with +-- Stack and GHC 8.10.1. It's just been pulled out from Development.IDE.Session. +-- See https://github.com/haskell/ghcide/pull/697 +module Development.IDE.Session.VersionCheck (ghcVersionChecker) where + +import Data.Maybe +import GHC.Check +-- Only use this for checking against the compile time GHC libDir! +-- Use getRuntimeGhcLibDir from hie-bios instead for everything else +-- otherwise binaries will not be distributable since paths will be baked into them +import qualified GHC.Paths +import System.Environment + +ghcVersionChecker :: GhcVersionChecker +ghcVersionChecker = $$(makeGhcVersionChecker (fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR")) diff --git a/src/Control/Concurrent/Strict.hs b/src/Control/Concurrent/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Strict.hs @@ -0,0 +1,34 @@ +module Control.Concurrent.Strict + (modifyVar', modifyVarIO' + ,modifyVar, modifyVar_ + ,module Control.Concurrent.Extra + ) where + +import Control.Concurrent.Extra hiding (modifyVar, modifyVar_) +import qualified Control.Concurrent.Extra as Extra +import Control.Exception (evaluate) +import Data.Tuple.Extra (dupe) +import Control.Monad (void) + +-- | Strict modification that returns the new value +modifyVar' :: Var a -> (a -> a) -> IO a +modifyVar' var upd = modifyVarIO' var (pure . upd) + +-- | Strict modification that returns the new value +modifyVarIO' :: Var a -> (a -> IO a) -> IO a +modifyVarIO' var upd = do + res <- Extra.modifyVar var $ \v -> do + v' <- upd v + pure $ dupe v' + evaluate res + +modifyVar :: Var a -> (a -> IO (a, b)) -> IO b +modifyVar var upd = do + (new, res) <- Extra.modifyVar var $ \old -> do + (new,res) <- upd old + return (new, (new, res)) + void $ evaluate new + return res + +modifyVar_ :: Var a -> (a -> IO a) -> IO () +modifyVar_ var upd = void $ modifyVarIO' var upd diff --git a/src/Development/IDE.hs b/src/Development/IDE.hs --- a/src/Development/IDE.hs +++ b/src/Development/IDE.hs @@ -1,50 +1,53 @@ -module Development.IDE -( - -- TODO It would be much nicer to enumerate all the exports - -- and organize them in sections - module X - -) where - -import Development.IDE.Core.FileExists as X (getFileExists) -import Development.IDE.Core.FileStore as X (getFileContents) -import Development.IDE.Core.IdeConfiguration as X (IdeConfiguration (..), - isWorkspaceFile) -import Development.IDE.Core.OfInterest as X (getFilesOfInterest) -import Development.IDE.Core.RuleTypes as X -import Development.IDE.Core.Rules as X (getAtPoint, - getClientConfigAction, - getDefinition, - getParsedModule, - getTypeDefinition) -import Development.IDE.Core.Service as X (runAction) -import Development.IDE.Core.Shake as X (FastResult (..), - IdeAction (..), - IdeRule, IdeState, - ShakeExtras, - actionLogger, - define, - defineEarlyCutoff, - getClientConfig, - getPluginConfig, - ideLogger, - runIdeAction, - shakeExtras, use, - useNoFile, - useNoFile_, - useWithStale, - useWithStaleFast, - useWithStaleFast', - useWithStale_, - use_, uses, uses_) -import Development.IDE.GHC.Error as X -import Development.IDE.GHC.Util as X -import Development.IDE.Plugin as X -import Development.IDE.Types.Diagnostics as X -import Development.IDE.Types.HscEnvEq as X (HscEnvEq (..), - hscEnv, - hscEnvWithImportPaths) -import Development.IDE.Types.Location as X -import Development.IDE.Types.Logger as X -import Development.Shake as X (Action, RuleResult, - Rules, action) +module Development.IDE +( + -- TODO It would be much nicer to enumerate all the exports + -- and organize them in sections + module X + +) where + +import Development.IDE.Core.FileExists as X (getFileExists) +import Development.IDE.Core.FileStore as X (getFileContents) +import Development.IDE.Core.IdeConfiguration as X (IdeConfiguration (..), + isWorkspaceFile) +import Development.IDE.Core.OfInterest as X (getFilesOfInterest) +import Development.IDE.Core.RuleTypes as X +import Development.IDE.Core.Rules as X (IsHiFileStable (..), + getAtPoint, + getClientConfigAction, + getDefinition, + getParsedModule, + getTypeDefinition) +import Development.IDE.Core.Service as X (runAction) +import Development.IDE.Core.Shake as X (FastResult (..), + IdeAction (..), + IdeRule, IdeState, + RuleBody (..), + ShakeExtras, + actionLogger, + define, + defineEarlyCutoff, + defineNoDiagnostics, + getClientConfig, + getPluginConfig, + ideLogger, + runIdeAction, + shakeExtras, use, + useNoFile, + useNoFile_, + useWithStale, + useWithStaleFast, + useWithStaleFast', + useWithStale_, + use_, uses, uses_) +import Development.IDE.GHC.Error as X +import Development.IDE.GHC.Util as X +import Development.IDE.Plugin as X +import Development.IDE.Types.Diagnostics as X +import Development.IDE.Types.HscEnvEq as X (HscEnvEq (..), + hscEnv, + hscEnvWithImportPaths) +import Development.IDE.Types.Location as X +import Development.IDE.Types.Logger as X +import Development.Shake as X (Action, RuleResult, + Rules, action) diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -1,973 +1,987 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE CPP #-} -#include "ghc-api-version.h" - --- | Based on https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/API. --- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values. -module Development.IDE.Core.Compile - ( TcModuleResult(..) - , RunSimplifier(..) - , compileModule - , parseModule - , typecheckModule - , computePackageDeps - , addRelativeImport - , mkHiFileResultCompile - , mkHiFileResultNoCompile - , generateObjectCode - , generateByteCode - , generateHieAsts - , writeAndIndexHieFile - , indexHieFile - , writeHiFile - , getModSummaryFromImports - , loadHieFile - , loadInterface - , loadModulesHome - , setupFinderCache - , getDocsBatch - , lookupName - ) where - -import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Preprocessor -import Development.IDE.Core.Shake -import Development.IDE.GHC.Error -import Development.IDE.GHC.Warnings -import Development.IDE.Spans.Common -import Development.IDE.Types.Diagnostics -import Development.IDE.GHC.Orphans() -import Development.IDE.GHC.Util -import Development.IDE.Types.Options -import Development.IDE.Types.Location -import Outputable hiding ((<>)) - -import HieDb - -import Language.LSP.Types (DiagnosticTag(..)) - -import LoadIface (loadModuleInterface) -import DriverPhases -import HscTypes -import DriverPipeline hiding (unP) - -import qualified Parser -import Lexer -#if MIN_GHC_API_VERSION(8,10,0) -import Control.DeepSeq (force, rnf) -#else -import Control.DeepSeq (rnf) -import ErrUtils -#endif - -import Finder -import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule, writeHieFile) -import qualified Development.IDE.GHC.Compat as GHC -import qualified Development.IDE.GHC.Compat as Compat -import GhcMonad -import GhcPlugins as GHC hiding (fst3, (<>)) -import HscMain (makeSimpleDetails, hscDesugar, hscTypecheckRename, hscSimplify, hscGenHardCode, hscInteractive) -import MkIface -import StringBuffer as SB -import TcRnMonad hiding (newUnique) -import TcIface (typecheckIface) -import TidyPgm -import Hooks -import TcSplice - -import Control.Exception.Safe -import Control.Lens hiding (List) -import Control.Monad.Extra -import Control.Monad.Except -import Control.Monad.Trans.Except -import Data.Bifunctor (first, second) -import qualified Data.ByteString as BS -import qualified Data.Text as T -import Data.IORef -import Data.List.Extra -import Data.Maybe -import qualified Data.Map.Strict as Map -import System.FilePath -import System.Directory -import System.IO.Extra ( fixIO, newTempFileWithin ) -import Control.Exception (evaluate) -import TcEnv (tcLookup) -import qualified Data.DList as DL -import Data.Time (UTCTime, getCurrentTime) -import Bag -import Linker (unload) -import qualified GHC.LanguageExtensions as LangExt -import PrelNames -import HeaderInfo -import Maybes (orElse) - -import qualified Data.HashMap.Strict as HashMap -import qualified Language.LSP.Types as LSP -import qualified Language.LSP.Server as LSP -import Control.Concurrent.STM hiding (orElse) -import Control.Concurrent.Extra -import Data.Functor -import Data.Unique -import GHC.Fingerprint -import Data.Coerce -import Data.Aeson (toJSON) -import Data.Tuple.Extra (dupe) - --- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. -parseModule - :: IdeOptions - -> HscEnv - -> FilePath - -> ModSummary - -> IO (IdeResult ParsedModule) -parseModule IdeOptions{..} env filename ms = - fmap (either (, Nothing) id) $ - runExceptT $ do - (diag, modu) <- parseFileContents env optPreprocessor filename ms - return (diag, Just modu) - - --- | Given a package identifier, what packages does it depend on -computePackageDeps - :: HscEnv - -> InstalledUnitId - -> IO (Either [FileDiagnostic] [InstalledUnitId]) -computePackageDeps env pkg = do - let dflags = hsc_dflags env - case lookupInstalledPackage dflags pkg of - Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $ - T.pack $ "unknown package: " ++ show pkg] - Just pkgInfo -> return $ Right $ depends pkgInfo - -typecheckModule :: IdeDefer - -> HscEnv - -> [Linkable] -- ^ linkables not to unload - -> ParsedModule - -> IO (IdeResult TcModuleResult) -typecheckModule (IdeDefer defer) hsc keep_lbls pm = do - fmap (either (,Nothing) id) $ - catchSrcErrors (hsc_dflags hsc) "typecheck" $ do - - let modSummary = pm_mod_summary pm - dflags = ms_hspp_opts modSummary - - modSummary' <- initPlugins hsc modSummary - (warnings, tcm) <- withWarnings "typecheck" $ \tweak -> - tcRnModule hsc keep_lbls $ enableTopLevelWarnings - $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'} - let errorPipeline = unDefer . hideDiag dflags . tagDiag - diags = map errorPipeline warnings - deferedError = any fst diags - return (map snd diags, Just $ tcm{tmrDeferedError = deferedError}) - where - demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id - --- | Add a Hook to the DynFlags which captures and returns the --- typechecked splices before they are run. This information --- is used for hover. -captureSplices :: DynFlags -> (DynFlags -> IO a) -> IO (a, Splices) -captureSplices dflags k = do - splice_ref <- newIORef mempty - res <- k (dflags { hooks = addSpliceHook splice_ref (hooks dflags)}) - splices <- readIORef splice_ref - return (res, splices) - where - addSpliceHook :: IORef Splices -> Hooks -> Hooks - addSpliceHook var h = h { runMetaHook = Just (splice_hook (runMetaHook h) var) } - - splice_hook :: Maybe (MetaHook TcM) -> IORef Splices -> MetaHook TcM - splice_hook (fromMaybe defaultRunMeta -> hook) var metaReq e = case metaReq of - (MetaE f) -> do - expr' <- metaRequestE hook e - liftIO $ modifyIORef' var $ exprSplicesL %~ ((e, expr') :) - pure $ f expr' - (MetaP f) -> do - pat' <- metaRequestP hook e - liftIO $ modifyIORef' var $ patSplicesL %~ ((e, pat') :) - pure $ f pat' - (MetaT f) -> do - type' <- metaRequestT hook e - liftIO $ modifyIORef' var $ typeSplicesL %~ ((e, type') :) - pure $ f type' - (MetaD f) -> do - decl' <- metaRequestD hook e - liftIO $ modifyIORef' var $ declSplicesL %~ ((e, decl') :) - pure $ f decl' - (MetaAW f) -> do - aw' <- metaRequestAW hook e - liftIO $ modifyIORef' var $ awSplicesL %~ ((e, aw') :) - pure $ f aw' - - -tcRnModule :: HscEnv -> [Linkable] -> ParsedModule -> IO TcModuleResult -tcRnModule hsc_env keep_lbls pmod = do - let ms = pm_mod_summary pmod - hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - - unload hsc_env_tmp keep_lbls - - ((tc_gbl_env, mrn_info), splices) - <- liftIO $ captureSplices (ms_hspp_opts ms) $ \dflags -> - do let hsc_env_tmp = hsc_env { hsc_dflags = dflags } - hscTypecheckRename hsc_env_tmp ms $ - HsParsedModule { hpm_module = parsedSource pmod, - hpm_src_files = pm_extra_src_files pmod, - hpm_annotations = pm_annotations pmod } - let rn_info = case mrn_info of - Just x -> x - Nothing -> error "no renamed info tcRnModule" - pure (TcModuleResult pmod rn_info tc_gbl_env splices False) - -mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult -mkHiFileResultNoCompile session tcm = do - let hsc_env_tmp = session { hsc_dflags = ms_hspp_opts ms } - ms = pm_mod_summary $ tmrParsed tcm - tcGblEnv = tmrTypechecked tcm - details <- makeSimpleDetails hsc_env_tmp tcGblEnv - sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv -#if MIN_GHC_API_VERSION(8,10,0) - iface <- mkIfaceTc session sf details tcGblEnv -#else - (iface, _) <- mkIfaceTc session Nothing sf details tcGblEnv -#endif - let mod_info = HomeModInfo iface details Nothing - pure $! HiFileResult ms mod_info - -mkHiFileResultCompile - :: HscEnv - -> TcModuleResult - -> ModGuts - -> LinkableType -- ^ use object code or byte code? - -> IO (IdeResult HiFileResult) -mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do - let session = session' { hsc_dflags = ms_hspp_opts ms } - ms = pm_mod_summary $ tmrParsed tcm - tcGblEnv = tmrTypechecked tcm - - let genLinkable = case ltype of - ObjectLinkable -> generateObjectCode - BCOLinkable -> generateByteCode - - (linkable, details, diags) <- - if mg_hsc_src simplified_guts == HsBootFile - then do - -- give variables unique OccNames - details <- mkBootModDetailsTc session tcGblEnv - pure (Nothing, details, []) - else do - -- give variables unique OccNames - (guts, details) <- tidyProgram session simplified_guts - (diags, linkable) <- genLinkable session ms guts - pure (linkable, details, diags) -#if MIN_GHC_API_VERSION(8,10,0) - let !partial_iface = force (mkPartialIface session details simplified_guts) - final_iface <- mkFullIface session partial_iface -#else - (final_iface,_) <- mkIface session Nothing details simplified_guts -#endif - let mod_info = HomeModInfo final_iface details linkable - pure (diags, Just $! HiFileResult ms mod_info) - - where - dflags = hsc_dflags session' - source = "compile" - catchErrs x = x `catches` - [ Handler $ return . (,Nothing) . diagFromGhcException source dflags - , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "") - . (("Error during " ++ T.unpack source) ++) . show @SomeException - ] - -initPlugins :: HscEnv -> ModSummary -> IO ModSummary -initPlugins session modSummary = do - dflags <- liftIO $ initializePlugins session $ ms_hspp_opts modSummary - return modSummary{ms_hspp_opts = dflags} - --- | Whether we should run the -O0 simplifier when generating core. --- --- This is required for template Haskell to work but we disable this in DAML. --- See #256 -newtype RunSimplifier = RunSimplifier Bool - --- | Compile a single type-checked module to a 'CoreModule' value, or --- provide errors. -compileModule - :: RunSimplifier - -> HscEnv - -> ModSummary - -> TcGblEnv - -> IO (IdeResult ModGuts) -compileModule (RunSimplifier simplify) session ms tcg = - fmap (either (, Nothing) (second Just)) $ - catchSrcErrors (hsc_dflags session) "compile" $ do - (warnings,desugared_guts) <- withWarnings "compile" $ \tweak -> do - let ms' = tweak ms - session' = session{ hsc_dflags = ms_hspp_opts ms'} - desugar <- hscDesugar session' ms' tcg - if simplify - then do - plugins <- readIORef (tcg_th_coreplugins tcg) - hscSimplify session' plugins desugar - else pure desugar - return (map snd warnings, desugared_guts) - -generateObjectCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) -generateObjectCode session summary guts = do - fmap (either (, Nothing) (second Just)) $ - catchSrcErrors (hsc_dflags session) "object" $ do - let dot_o = ml_obj_file (ms_location summary) - mod = ms_mod summary - fp = replaceExtension dot_o "s" - createDirectoryIfMissing True (takeDirectory fp) - (warnings, dot_o_fp) <- - withWarnings "object" $ \_tweak -> do - let summary' = _tweak summary -#if MIN_GHC_API_VERSION(8,10,0) - target = defaultObjectTarget $ hsc_dflags session -#else - target = defaultObjectTarget $ targetPlatform $ hsc_dflags session -#endif - session' = session { hsc_dflags = updOptLevel 0 $ (ms_hspp_opts summary') { outputFile = Just dot_o , hscTarget = target}} - (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts -#if MIN_GHC_API_VERSION(8,10,0) - (ms_location summary') -#else - summary' -#endif - fp - compileFile session' StopLn (outputFilename, Just (As False)) - let unlinked = DotO dot_o_fp - -- Need time to be the modification time for recompilation checking - t <- liftIO $ getModificationTime dot_o_fp - let linkable = LM t mod [unlinked] - - pure (map snd warnings, linkable) - -generateByteCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) -generateByteCode hscEnv summary guts = do - fmap (either (, Nothing) (second Just)) $ - catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do - (warnings, (_, bytecode, sptEntries)) <- - withWarnings "bytecode" $ \_tweak -> do - let summary' = _tweak summary - session = hscEnv { hsc_dflags = ms_hspp_opts summary' } - hscInteractive session guts -#if MIN_GHC_API_VERSION(8,10,0) - (ms_location summary') -#else - summary' -#endif - let unlinked = BCOs bytecode sptEntries - time <- liftIO getCurrentTime - let linkable = LM time (ms_mod summary) [unlinked] - - pure (map snd warnings, linkable) - -demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule -demoteTypeErrorsToWarnings = - (update_pm_mod_summary . update_hspp_opts) demoteTEsToWarns where - - demoteTEsToWarns :: DynFlags -> DynFlags - -- convert the errors into warnings, and also check the warnings are enabled - demoteTEsToWarns = (`wopt_set` Opt_WarnDeferredTypeErrors) - . (`wopt_set` Opt_WarnTypedHoles) - . (`wopt_set` Opt_WarnDeferredOutOfScopeVariables) - . (`gopt_set` Opt_DeferTypeErrors) - . (`gopt_set` Opt_DeferTypedHoles) - . (`gopt_set` Opt_DeferOutOfScopeVariables) - -enableTopLevelWarnings :: ParsedModule -> ParsedModule -enableTopLevelWarnings = - (update_pm_mod_summary . update_hspp_opts) - ((`wopt_set` Opt_WarnMissingPatternSynonymSignatures) . - (`wopt_set` Opt_WarnMissingSignatures)) - -- the line below would show also warnings for let bindings without signature - -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures))) - -update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary -update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms} - -update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule -update_pm_mod_summary up pm = - pm{pm_mod_summary = up $ pm_mod_summary pm} - -unDefer :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic) -unDefer (Reason Opt_WarnDeferredTypeErrors , fd) = (True, upgradeWarningToError fd) -unDefer (Reason Opt_WarnTypedHoles , fd) = (True, upgradeWarningToError fd) -unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = (True, upgradeWarningToError fd) -unDefer ( _ , fd) = (False, fd) - -upgradeWarningToError :: FileDiagnostic -> FileDiagnostic -upgradeWarningToError (nfp, sh, fd) = - (nfp, sh, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where - warn2err :: T.Text -> T.Text - warn2err = T.intercalate ": error:" . T.splitOn ": warning:" - -hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic) -hideDiag originalFlags (Reason warning, (nfp, _sh, fd)) - | not (wopt warning originalFlags) - = (Reason warning, (nfp, HideDiag, fd)) -hideDiag _originalFlags t = t - --- | Warnings which lead to a diagnostic tag -unnecessaryDeprecationWarningFlags :: [WarningFlag] -unnecessaryDeprecationWarningFlags - = [ Opt_WarnUnusedTopBinds - , Opt_WarnUnusedLocalBinds - , Opt_WarnUnusedPatternBinds - , Opt_WarnUnusedImports - , Opt_WarnUnusedMatches - , Opt_WarnUnusedTypePatterns - , Opt_WarnUnusedForalls -#if MIN_GHC_API_VERSION(8,10,0) - , Opt_WarnUnusedRecordWildcards -#endif - , Opt_WarnInaccessibleCode - , Opt_WarnWarningsDeprecations - ] - --- | Add a unnecessary/deprecated tag to the required diagnostics. -tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic) -tagDiag (Reason warning, (nfp, sh, fd)) - | Just tag <- requiresTag warning - = (Reason warning, (nfp, sh, fd { _tags = addTag tag (_tags fd) })) - where - requiresTag :: WarningFlag -> Maybe DiagnosticTag - requiresTag Opt_WarnWarningsDeprecations - = Just DtDeprecated - requiresTag wflag -- deprecation was already considered above - | wflag `elem` unnecessaryDeprecationWarningFlags - = Just DtUnnecessary - requiresTag _ = Nothing - addTag :: DiagnosticTag -> Maybe (List DiagnosticTag) -> Maybe (List DiagnosticTag) - addTag t Nothing = Just (List [t]) - addTag t (Just (List ts)) = Just (List (t : ts)) --- other diagnostics are left unaffected -tagDiag t = t - -addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags -addRelativeImport fp modu dflags = dflags - {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags} - -atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO () -atomicFileWrite targetPath write = do - let dir = takeDirectory targetPath - createDirectoryIfMissing True dir - (tempFilePath, cleanUp) <- newTempFileWithin dir - (write tempFilePath >> renameFile tempFilePath targetPath) `onException` cleanUp - -generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type)) -generateHieAsts hscEnv tcm = - handleGenerationErrors' dflags "extended interface generation" $ runHsc hscEnv $ do - -- These varBinds use unitDataConId but it could be anything as the id name is not used - -- during the hie file generation process. It's a workaround for the fact that the hie modules - -- don't export an interface which allows for additional information to be added to hie files. - let fake_splice_binds = listToBag (map (mkVarBind unitDataConId) (spliceExpresions $ tmrTopLevelSplices tcm)) - real_binds = tcg_binds $ tmrTypechecked tcm - Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm) - where - dflags = hsc_dflags hscEnv - -spliceExpresions :: Splices -> [LHsExpr GhcTc] -spliceExpresions Splices{..} = - DL.toList $ mconcat - [ DL.fromList $ map fst exprSplices - , DL.fromList $ map fst patSplices - , DL.fromList $ map fst typeSplices - , DL.fromList $ map fst declSplices - , DL.fromList $ map fst awSplices - ] - --- | In addition to indexing the `.hie` file, this function is responsible for --- maintaining the 'IndexQueue' state and notfiying the user about indexing --- progress. --- --- We maintain a record of all pending index operations in the 'indexPending' --- TVar. --- When 'indexHieFile' is called, it must check to ensure that the file hasn't --- already be queued up for indexing. If it has, then we can just skip it --- --- Otherwise, we record the current file as pending and write an indexing --- operation to the queue --- --- When the indexing operation is picked up and executed by the worker thread, --- the first thing it does is ensure that a newer index for the same file hasn't --- been scheduled by looking at 'indexPending'. If a newer index has been --- scheduled, we can safely skip this one --- --- Otherwise, we start or continue a progress reporting session, telling it --- about progress so far and the current file we are attempting to index. Then --- we can go ahead and call in to hiedb to actually do the indexing operation --- --- Once this completes, we have to update the 'IndexQueue' state. First, we --- must remove the just indexed file from 'indexPending' Then we check if --- 'indexPending' is now empty. In that case, we end the progress session and --- report the total number of file indexed. We also set the 'indexCompleted' --- TVar to 0 in order to set it up for a fresh indexing session. Otherwise, we --- can just increment the 'indexCompleted' TVar and exit. --- -indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Fingerprint -> Compat.HieFile -> IO () -indexHieFile se mod_summary srcPath hash hf = atomically $ do - pending <- readTVar indexPending - case HashMap.lookup srcPath pending of - Just pendingHash | pendingHash == hash -> pure () -- An index is already scheduled - _ -> do - modifyTVar' indexPending $ HashMap.insert srcPath hash - writeTQueue indexQueue $ \db -> do - -- We are now in the worker thread - -- Check if a newer index of this file has been scheduled, and if so skip this one - newerScheduled <- atomically $ do - pending <- readTVar indexPending - pure $ case HashMap.lookup srcPath pending of - Nothing -> False - -- If the hash in the pending list doesn't match the current hash, then skip - Just pendingHash -> pendingHash /= hash - unless newerScheduled $ do - pre - addRefsFromLoaded db targetPath (RealFile $ fromNormalizedFilePath srcPath) hash hf - post - where - mod_location = ms_location mod_summary - targetPath = Compat.ml_hie_file mod_location - HieDbWriter{..} = hiedbWriter se - - -- Get a progress token to report progress and update it for the current file - pre = do - tok <- modifyVar indexProgressToken $ fmap dupe . \case - x@(Just _) -> pure x - -- Create a token if we don't already have one - Nothing -> do - case lspEnv se of - Nothing -> pure Nothing - Just env -> LSP.runLspT env $ do - u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique - -- TODO: Wait for the progress create response to use the token - _ <- LSP.sendRequest LSP.SWindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ()) - LSP.sendNotification LSP.SProgress $ LSP.ProgressParams u $ - LSP.Begin $ LSP.WorkDoneProgressBeginParams - { _title = "Indexing references from:" - , _cancellable = Nothing - , _message = Nothing - , _percentage = Nothing - } - pure (Just u) - - (!done, !remaining) <- atomically $ do - done <- readTVar indexCompleted - remaining <- HashMap.size <$> readTVar indexPending - pure (done, remaining) - - let progress = " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..." - - whenJust (lspEnv se) $ \env -> whenJust tok $ \tok -> LSP.runLspT env $ - LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $ - LSP.Report $ LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = Just $ T.pack (show srcPath) <> progress - , _percentage = Nothing - } - - -- Report the progress once we are done indexing this file - post = do - mdone <- atomically $ do - -- Remove current element from pending - pending <- stateTVar indexPending $ - dupe . HashMap.update (\pendingHash -> guard (pendingHash /= hash) $> pendingHash) srcPath - modifyTVar' indexCompleted (+1) - -- If we are done, report and reset completed - whenMaybe (HashMap.null pending) $ - swapTVar indexCompleted 0 - whenJust (lspEnv se) $ \env -> LSP.runLspT env $ - when (coerce $ ideTesting se) $ - LSP.sendNotification (LSP.SCustomMethod "ghcide/reference/ready") $ - toJSON $ fromNormalizedFilePath srcPath - whenJust mdone $ \done -> - modifyVar_ indexProgressToken $ \tok -> do - whenJust (lspEnv se) $ \env -> LSP.runLspT env $ - whenJust tok $ \tok -> - LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $ - LSP.End $ LSP.WorkDoneProgressEndParams - { _message = Just $ "Finished indexing " <> T.pack (show done) <> " files" - } - -- We are done with the current indexing cycle, so destroy the token - pure Nothing - -writeAndIndexHieFile :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic] -writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source = - handleGenerationErrors dflags "extended interface write/compression" $ do - hf <- runHsc hscEnv $ - GHC.mkHieFile' mod_summary exports ast source - atomicFileWrite targetPath $ flip GHC.writeHieFile hf - hash <- getFileHash targetPath - indexHieFile se mod_summary srcPath hash hf - where - dflags = hsc_dflags hscEnv - mod_location = ms_location mod_summary - targetPath = Compat.ml_hie_file mod_location - -writeHiFile :: HscEnv -> HiFileResult -> IO [FileDiagnostic] -writeHiFile hscEnv tc = - handleGenerationErrors dflags "interface write" $ do - atomicFileWrite targetPath $ \fp -> - writeIfaceFile dflags fp modIface - where - modIface = hm_iface $ hirHomeMod tc - targetPath = ml_hi_file $ ms_location $ hirModSummary tc - dflags = hsc_dflags hscEnv - -handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic] -handleGenerationErrors dflags source action = - action >> return [] `catches` - [ Handler $ return . diagFromGhcException source dflags - , Handler $ return . diagFromString source DsError (noSpan "") - . (("Error during " ++ T.unpack source) ++) . show @SomeException - ] - -handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a) -handleGenerationErrors' dflags source action = - fmap ([],) action `catches` - [ Handler $ return . (,Nothing) . diagFromGhcException source dflags - , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "") - . (("Error during " ++ T.unpack source) ++) . show @SomeException - ] - --- | Initialise the finder cache, dependencies should be topologically --- sorted. -setupFinderCache :: [ModSummary] -> HscEnv -> IO HscEnv -setupFinderCache mss session = do - - -- Make modules available for others that import them, - -- by putting them in the finder cache. - let ims = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss - ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims - -- set the target and module graph in the session - graph = mkModuleGraph mss - - -- We have to create a new IORef here instead of modifying the existing IORef as - -- it is shared between concurrent compilations. - prevFinderCache <- readIORef $ hsc_FC session - let newFinderCache = - foldl' - (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) prevFinderCache - $ zip ims ifrs - newFinderCacheVar <- newIORef $! newFinderCache - - pure $ session { hsc_FC = newFinderCacheVar, hsc_mod_graph = graph } - - --- | Load modules, quickly. Input doesn't need to be desugared. --- A module must be loaded before dependent modules can be typechecked. --- This variant of loadModuleHome will *never* cause recompilation, it just --- modifies the session. --- The order modules are loaded is important when there are hs-boot files. --- In particular you should make sure to load the .hs version of a file after the --- .hs-boot version. -loadModulesHome - :: [HomeModInfo] - -> HscEnv - -> HscEnv -loadModulesHome mod_infos e = - e { hsc_HPT = addListToHpt (hsc_HPT e) [(mod_name x, x) | x <- mod_infos] - , hsc_type_env_var = Nothing } - where - mod_name = moduleName . mi_module . hm_iface - -withBootSuffix :: HscSource -> ModLocation -> ModLocation -withBootSuffix HsBootFile = addBootSuffixLocnOut -withBootSuffix _ = id - --- | Given a buffer, env and filepath, produce a module summary by parsing only the imports. --- Runs preprocessors as needed. -getModSummaryFromImports - :: HscEnv - -> FilePath - -> UTCTime - -> Maybe SB.StringBuffer - -> ExceptT [FileDiagnostic] IO (ModSummary,[LImportDecl GhcPs]) -getModSummaryFromImports env fp modTime contents = do - (contents, dflags) <- preprocessor env fp contents - - -- The warns will hopefully be reported when we actually parse the module - (_warns, L main_loc hsmod) <- parseHeader dflags fp contents - - -- Copied from `HeaderInfo.getImports`, but we also need to keep the parsed imports - let mb_mod = hsmodName hsmod - imps = hsmodImports hsmod - - mod = fmap unLoc mb_mod `orElse` mAIN_NAME - - (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps - - -- GHC.Prim doesn't exist physically, so don't go looking for it. - ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc - . ideclName . unLoc) - ord_idecls - - implicit_prelude = xopt LangExt.ImplicitPrelude dflags - implicit_imports = mkPrelImports mod main_loc - implicit_prelude imps - convImport (L _ i) = (fmap sl_fs (ideclPkgQual i) - , ideclName i) - - srcImports = map convImport src_idecls - textualImports = map convImport (implicit_imports ++ ordinary_imps) - - allImps = implicit_imports ++ imps - - -- Force bits that might keep the string buffer and DynFlags alive unnecessarily - liftIO $ evaluate $ rnf srcImports - liftIO $ evaluate $ rnf textualImports - - modLoc <- liftIO $ mkHomeModLocation dflags mod fp - - let modl = mkModule (thisPackage dflags) mod - sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile - summary = - ModSummary - { ms_mod = modl -#if MIN_GHC_API_VERSION(8,8,0) - , ms_hie_date = Nothing -#endif - , ms_hs_date = modTime - , ms_hsc_src = sourceType - -- The contents are used by the GetModSummary rule - , ms_hspp_buf = Just contents - , ms_hspp_file = fp - , ms_hspp_opts = dflags - , ms_iface_date = Nothing - , ms_location = withBootSuffix sourceType modLoc - , ms_obj_date = Nothing - , ms_parsed_mod = Nothing - , ms_srcimps = srcImports - , ms_textual_imps = textualImports - } - return (summary, allImps) - --- | Parse only the module header -parseHeader - :: Monad m - => DynFlags -- ^ flags to use - -> FilePath -- ^ the filename (for source locations) - -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported) - -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs)) -parseHeader dflags filename contents = do - let loc = mkRealSrcLoc (mkFastString filename) 1 1 - case unP Parser.parseHeader (mkPState dflags contents loc) of -#if MIN_GHC_API_VERSION(8,10,0) - PFailed pst -> - throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags -#else - PFailed _ locErr msgErr -> - throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr -#endif - POk pst rdr_module -> do - let (warns, errs) = getMessages pst dflags - -- Just because we got a `POk`, it doesn't mean there - -- weren't errors! To clarify, the GHC parser - -- distinguishes between fatal and non-fatal - -- errors. Non-fatal errors are the sort that don't - -- prevent parsing from continuing (that is, a parse - -- tree can still be produced despite the error so that - -- further errors/warnings can be collected). Fatal - -- errors are those from which a parse tree just can't - -- be produced. - unless (null errs) $ - throwE $ diagFromErrMsgs "parser" dflags errs - - let warnings = diagFromErrMsgs "parser" dflags warns - return (warnings, rdr_module) - --- | Given a buffer, flags, and file path, produce a --- parsed module (or errors) and any parse warnings. Does not run any preprocessors --- ModSummary must contain the (preprocessed) contents of the buffer -parseFileContents - :: HscEnv - -> (GHC.ParsedSource -> IdePreprocessedSource) - -> FilePath -- ^ the filename (for source locations) - -> ModSummary - -> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule) -parseFileContents env customPreprocessor filename ms = do - let loc = mkRealSrcLoc (mkFastString filename) 1 1 - dflags = ms_hspp_opts ms - contents = fromJust $ ms_hspp_buf ms - case unP Parser.parseModule (mkPState dflags contents loc) of -#if MIN_GHC_API_VERSION(8,10,0) - PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags -#else - PFailed _ locErr msgErr -> - throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr -#endif - POk pst rdr_module -> - let hpm_annotations = - (Map.fromListWith (++) $ annotations pst, - Map.fromList ((noSrcSpan,comment_q pst) - :annotations_comments pst)) - (warns, errs) = getMessages pst dflags - in - do - -- Just because we got a `POk`, it doesn't mean there - -- weren't errors! To clarify, the GHC parser - -- distinguishes between fatal and non-fatal - -- errors. Non-fatal errors are the sort that don't - -- prevent parsing from continuing (that is, a parse - -- tree can still be produced despite the error so that - -- further errors/warnings can be collected). Fatal - -- errors are those from which a parse tree just can't - -- be produced. - unless (null errs) $ - throwE $ diagFromErrMsgs "parser" dflags errs - - -- Ok, we got here. It's safe to continue. - let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module - - unless (null errs) $ - throwE $ diagFromStrings "parser" DsError errs - - let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns - parsed' <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed - - -- To get the list of extra source files, we take the list - -- that the parser gave us, - -- - eliminate files beginning with '<'. gcc likes to use - -- pseudo-filenames like "" and "" - -- - normalise them (eliminate differences between ./f and f) - -- - filter out the preprocessed source file - -- - filter out anything beginning with tmpdir - -- - remove duplicates - -- - filter out the .hs/.lhs source filename if we have one - -- - let n_hspp = normalise filename - srcs0 = nubOrd $ filter (not . (tmpDir dflags `isPrefixOf`)) - $ filter (/= n_hspp) - $ map normalise - $ filter (not . isPrefixOf "<") - $ map unpackFS - $ srcfiles pst - srcs1 = case ml_hs_file (ms_location ms) of - Just f -> filter (/= normalise f) srcs0 - Nothing -> srcs0 - - -- sometimes we see source files from earlier - -- preprocessing stages that cannot be found, so just - -- filter them out: - srcs2 <- liftIO $ filterM doesFileExist srcs1 - - let pm = - ParsedModule { - pm_mod_summary = ms - , pm_parsed_source = parsed' - , pm_extra_src_files = srcs2 - , pm_annotations = hpm_annotations - } - warnings = diagFromErrMsgs "parser" dflags warns - pure (warnings ++ preproc_warnings, pm) - -loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile -loadHieFile ncu f = do - GHC.hie_file_result <$> GHC.readHieFile ncu f - --- | Retuns an up-to-date module interface, regenerating if needed. --- Assumes file exists. --- Requires the 'HscEnv' to be set up with dependencies -loadInterface - :: MonadIO m => HscEnv - -> ModSummary - -> SourceModified - -> Maybe LinkableType - -> (Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult)) -- ^ Action to regenerate an interface - -> m ([FileDiagnostic], Maybe HiFileResult) -loadInterface session ms sourceMod linkableNeeded regen = do - res <- liftIO $ checkOldIface session ms sourceMod Nothing - case res of - (UpToDate, Just iface) - -- If the module used TH splices when it was last - -- compiled, then the recompilation check is not - -- accurate enough (https://gitlab.haskell.org/ghc/ghc/-/issues/481) - -- and we must ignore - -- it. However, if the module is stable (none of - -- the modules it depends on, directly or - -- indirectly, changed), then we *can* skip - -- recompilation. This is why the SourceModified - -- type contains SourceUnmodifiedAndStable, and - -- it's pretty important: otherwise ghc --make - -- would always recompile TH modules, even if - -- nothing at all has changed. Stability is just - -- the same check that make is doing for us in - -- one-shot mode. - | not (mi_used_th iface) || SourceUnmodifiedAndStable == sourceMod - -> do - linkable <- case linkableNeeded of - Just ObjectLinkable -> liftIO $ findObjectLinkableMaybe (ms_mod ms) (ms_location ms) - _ -> pure Nothing - - -- We don't need to regenerate if the object is up do date, or we don't need one - let objUpToDate = isNothing linkableNeeded || case linkable of - Nothing -> False - Just (LM obj_time _ _) -> obj_time > ms_hs_date ms - if objUpToDate - then do - hmi <- liftIO $ mkDetailsFromIface session iface linkable - return ([], Just $ HiFileResult ms hmi) - else regen linkableNeeded - (_reason, _) -> regen linkableNeeded - -mkDetailsFromIface :: HscEnv -> ModIface -> Maybe Linkable -> IO HomeModInfo -mkDetailsFromIface session iface linkable = do - details <- liftIO $ fixIO $ \details -> do - let hsc' = session { hsc_HPT = addToHpt (hsc_HPT session) (moduleName $ mi_module iface) (HomeModInfo iface details linkable) } - initIfaceLoad hsc' (typecheckIface iface) - return (HomeModInfo iface details linkable) - --- | Non-interactive, batch version of 'InteractiveEval.getDocs'. --- The interactive paths create problems in ghc-lib builds ---- and leads to fun errors like "Cannot continue after interface file error". -getDocsBatch - :: HscEnv - -> Module -- ^ a moudle where the names are in scope - -> [Name] - -> IO [Either String (Maybe HsDocString, Map.Map Int HsDocString)] -getDocsBatch hsc_env _mod _names = do - ((_warns,errs), res) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ forM _names $ \name -> - case nameModule_maybe name of - Nothing -> return (Left $ NameHasNoModule name) - Just mod -> do - ModIface { mi_doc_hdr = mb_doc_hdr - , mi_decl_docs = DeclDocMap dmap - , mi_arg_docs = ArgDocMap amap - } <- loadModuleInterface "getModuleInterface" mod - if isNothing mb_doc_hdr && Map.null dmap && Map.null amap - then pure (Left (NoDocsInIface mod $ compiled name)) - else pure (Right ( Map.lookup name dmap - , Map.findWithDefault Map.empty name amap)) - case res of - Just x -> return $ map (first $ T.unpack . showGhc) x - Nothing -> throwErrors errs - where - throwErrors = liftIO . throwIO . mkSrcErr - compiled n = - -- TODO: Find a more direct indicator. - case nameSrcLoc n of - RealSrcLoc {} -> False - UnhelpfulLoc {} -> True - -fakeSpan :: RealSrcSpan -fakeSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "") 1 1 - --- | Non-interactive, batch version of 'InteractiveEval.lookupNames'. --- The interactive paths create problems in ghc-lib builds ---- and leads to fun errors like "Cannot continue after interface file error". -lookupName :: HscEnv - -> Module -- ^ A module where the Names are in scope - -> Name - -> IO (Maybe TyThing) -lookupName hsc_env mod name = do - (_messages, res) <- initTc hsc_env HsSrcFile False mod fakeSpan $ do - tcthing <- tcLookup name - case tcthing of - AGlobal thing -> return thing - ATcId{tct_id=id} -> return (AnId id) - _ -> panic "tcRnLookupName'" - return res +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +#include "ghc-api-version.h" + +-- | Based on https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/API. +-- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values. +module Development.IDE.Core.Compile + ( TcModuleResult(..) + , RunSimplifier(..) + , compileModule + , parseModule + , typecheckModule + , computePackageDeps + , addRelativeImport + , mkHiFileResultCompile + , mkHiFileResultNoCompile + , generateObjectCode + , generateByteCode + , generateHieAsts + , writeAndIndexHieFile + , indexHieFile + , writeHiFile + , getModSummaryFromImports + , loadHieFile + , loadInterface + , loadModulesHome + , setupFinderCache + , getDocsBatch + , lookupName + ) where + +import Development.IDE.Core.Preprocessor +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Shake +import Development.IDE.GHC.Error +import Development.IDE.GHC.Orphans () +import Development.IDE.GHC.Util +import Development.IDE.GHC.Warnings +import Development.IDE.Spans.Common +import Development.IDE.Types.Diagnostics +import Development.IDE.Types.Location +import Development.IDE.Types.Options +import Outputable hiding ((<>)) + +import HieDb + +import Language.LSP.Types (DiagnosticTag (..)) + +import DriverPhases +import DriverPipeline hiding (unP) +import HscTypes +import LoadIface (loadModuleInterface) + +import Lexer +import qualified Parser +#if MIN_GHC_API_VERSION(8,10,0) +import Control.DeepSeq (force, rnf) +#else +import Control.DeepSeq (rnf) +import ErrUtils +#endif + +import Development.IDE.GHC.Compat hiding (parseModule, + typecheckModule, + writeHieFile) +import qualified Development.IDE.GHC.Compat as Compat +import qualified Development.IDE.GHC.Compat as GHC +import Finder +import GhcMonad +import GhcPlugins as GHC hiding (fst3, (<>)) +import Hooks +import HscMain (hscDesugar, hscGenHardCode, + hscInteractive, hscSimplify, + hscTypecheckRename, + makeSimpleDetails) +import MkIface +import StringBuffer as SB +import TcIface (typecheckIface) +import TcRnMonad hiding (newUnique) +import TcSplice +import TidyPgm + +import Bag +import Control.Exception (evaluate) +import Control.Exception.Safe +import Control.Lens hiding (List) +import Control.Monad.Except +import Control.Monad.Extra +import Control.Monad.Trans.Except +import Data.Bifunctor (first, second) +import qualified Data.ByteString as BS +import qualified Data.DList as DL +import Data.IORef +import Data.List.Extra +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.Text as T +import Data.Time (UTCTime, getCurrentTime) +import qualified GHC.LanguageExtensions as LangExt +import HeaderInfo +import Linker (unload) +import Maybes (orElse) +import PrelNames +import System.Directory +import System.FilePath +import System.IO.Extra (fixIO, newTempFileWithin) +import TcEnv (tcLookup) + +import Control.Concurrent.Extra +import Control.Concurrent.STM hiding (orElse) +import Data.Aeson (toJSON) +import Data.Binary +import Data.Coerce +import Data.Functor +import qualified Data.HashMap.Strict as HashMap +import Data.Tuple.Extra (dupe) +import Data.Unique +import GHC.Fingerprint +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Types as LSP + +-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. +parseModule + :: IdeOptions + -> HscEnv + -> FilePath + -> ModSummary + -> IO (IdeResult ParsedModule) +parseModule IdeOptions{..} env filename ms = + fmap (either (, Nothing) id) $ + runExceptT $ do + (diag, modu) <- parseFileContents env optPreprocessor filename ms + return (diag, Just modu) + + +-- | Given a package identifier, what packages does it depend on +computePackageDeps + :: HscEnv + -> InstalledUnitId + -> IO (Either [FileDiagnostic] [InstalledUnitId]) +computePackageDeps env pkg = do + let dflags = hsc_dflags env + case lookupInstalledPackage dflags pkg of + Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $ + T.pack $ "unknown package: " ++ show pkg] + Just pkgInfo -> return $ Right $ depends pkgInfo + +typecheckModule :: IdeDefer + -> HscEnv + -> [Linkable] -- ^ linkables not to unload + -> ParsedModule + -> IO (IdeResult TcModuleResult) +typecheckModule (IdeDefer defer) hsc keep_lbls pm = do + fmap (either (,Nothing) id) $ + catchSrcErrors (hsc_dflags hsc) "typecheck" $ do + + let modSummary = pm_mod_summary pm + dflags = ms_hspp_opts modSummary + + modSummary' <- initPlugins hsc modSummary + (warnings, tcm) <- withWarnings "typecheck" $ \tweak -> + tcRnModule hsc keep_lbls $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'} + let errorPipeline = unDefer . hideDiag dflags . tagDiag + diags = map errorPipeline warnings + deferedError = any fst diags + return (map snd diags, Just $ tcm{tmrDeferedError = deferedError}) + where + demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id + +-- | Add a Hook to the DynFlags which captures and returns the +-- typechecked splices before they are run. This information +-- is used for hover. +captureSplices :: DynFlags -> (DynFlags -> IO a) -> IO (a, Splices) +captureSplices dflags k = do + splice_ref <- newIORef mempty + res <- k (dflags { hooks = addSpliceHook splice_ref (hooks dflags)}) + splices <- readIORef splice_ref + return (res, splices) + where + addSpliceHook :: IORef Splices -> Hooks -> Hooks + addSpliceHook var h = h { runMetaHook = Just (splice_hook (runMetaHook h) var) } + + splice_hook :: Maybe (MetaHook TcM) -> IORef Splices -> MetaHook TcM + splice_hook (fromMaybe defaultRunMeta -> hook) var metaReq e = case metaReq of + (MetaE f) -> do + expr' <- metaRequestE hook e + liftIO $ modifyIORef' var $ exprSplicesL %~ ((e, expr') :) + pure $ f expr' + (MetaP f) -> do + pat' <- metaRequestP hook e + liftIO $ modifyIORef' var $ patSplicesL %~ ((e, pat') :) + pure $ f pat' + (MetaT f) -> do + type' <- metaRequestT hook e + liftIO $ modifyIORef' var $ typeSplicesL %~ ((e, type') :) + pure $ f type' + (MetaD f) -> do + decl' <- metaRequestD hook e + liftIO $ modifyIORef' var $ declSplicesL %~ ((e, decl') :) + pure $ f decl' + (MetaAW f) -> do + aw' <- metaRequestAW hook e + liftIO $ modifyIORef' var $ awSplicesL %~ ((e, aw') :) + pure $ f aw' + + +tcRnModule :: HscEnv -> [Linkable] -> ParsedModule -> IO TcModuleResult +tcRnModule hsc_env keep_lbls pmod = do + let ms = pm_mod_summary pmod + hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } + + unload hsc_env_tmp keep_lbls + + ((tc_gbl_env, mrn_info), splices) + <- liftIO $ captureSplices (ms_hspp_opts ms) $ \dflags -> + do let hsc_env_tmp = hsc_env { hsc_dflags = dflags } + hscTypecheckRename hsc_env_tmp ms $ + HsParsedModule { hpm_module = parsedSource pmod, + hpm_src_files = pm_extra_src_files pmod, + hpm_annotations = pm_annotations pmod } + let rn_info = case mrn_info of + Just x -> x + Nothing -> error "no renamed info tcRnModule" + pure (TcModuleResult pmod rn_info tc_gbl_env splices False) + +mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult +mkHiFileResultNoCompile session tcm = do + let hsc_env_tmp = session { hsc_dflags = ms_hspp_opts ms } + ms = pm_mod_summary $ tmrParsed tcm + tcGblEnv = tmrTypechecked tcm + details <- makeSimpleDetails hsc_env_tmp tcGblEnv + sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv +#if MIN_GHC_API_VERSION(8,10,0) + iface <- mkIfaceTc hsc_env_tmp sf details tcGblEnv +#else + (iface, _) <- mkIfaceTc hsc_env_tmp Nothing sf details tcGblEnv +#endif + let mod_info = HomeModInfo iface details Nothing + pure $! mkHiFileResult ms mod_info + +mkHiFileResultCompile + :: HscEnv + -> TcModuleResult + -> ModGuts + -> LinkableType -- ^ use object code or byte code? + -> IO (IdeResult HiFileResult) +mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do + let session = session' { hsc_dflags = ms_hspp_opts ms } + ms = pm_mod_summary $ tmrParsed tcm + tcGblEnv = tmrTypechecked tcm + + let genLinkable = case ltype of + ObjectLinkable -> generateObjectCode + BCOLinkable -> generateByteCode + + (linkable, details, diags) <- + if mg_hsc_src simplified_guts == HsBootFile + then do + -- give variables unique OccNames + details <- mkBootModDetailsTc session tcGblEnv + pure (Nothing, details, []) + else do + -- give variables unique OccNames + (guts, details) <- tidyProgram session simplified_guts + (diags, linkable) <- genLinkable session ms guts + pure (linkable, details, diags) +#if MIN_GHC_API_VERSION(8,10,0) + let !partial_iface = force (mkPartialIface session details simplified_guts) + final_iface <- mkFullIface session partial_iface +#else + (final_iface,_) <- mkIface session Nothing details simplified_guts +#endif + let mod_info = HomeModInfo final_iface details linkable + pure (diags, Just $! mkHiFileResult ms mod_info) + + where + dflags = hsc_dflags session' + source = "compile" + catchErrs x = x `catches` + [ Handler $ return . (,Nothing) . diagFromGhcException source dflags + , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "") + . (("Error during " ++ T.unpack source) ++) . show @SomeException + ] + +initPlugins :: HscEnv -> ModSummary -> IO ModSummary +initPlugins session modSummary = do + dflags <- liftIO $ initializePlugins session $ ms_hspp_opts modSummary + return modSummary{ms_hspp_opts = dflags} + +-- | Whether we should run the -O0 simplifier when generating core. +-- +-- This is required for template Haskell to work but we disable this in DAML. +-- See #256 +newtype RunSimplifier = RunSimplifier Bool + +-- | Compile a single type-checked module to a 'CoreModule' value, or +-- provide errors. +compileModule + :: RunSimplifier + -> HscEnv + -> ModSummary + -> TcGblEnv + -> IO (IdeResult ModGuts) +compileModule (RunSimplifier simplify) session ms tcg = + fmap (either (, Nothing) (second Just)) $ + catchSrcErrors (hsc_dflags session) "compile" $ do + (warnings,desugared_guts) <- withWarnings "compile" $ \tweak -> do + let ms' = tweak ms + session' = session{ hsc_dflags = ms_hspp_opts ms'} + desugar <- hscDesugar session' ms' tcg + if simplify + then do + plugins <- readIORef (tcg_th_coreplugins tcg) + hscSimplify session' plugins desugar + else pure desugar + return (map snd warnings, desugared_guts) + +generateObjectCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) +generateObjectCode session summary guts = do + fmap (either (, Nothing) (second Just)) $ + catchSrcErrors (hsc_dflags session) "object" $ do + let dot_o = ml_obj_file (ms_location summary) + mod = ms_mod summary + fp = replaceExtension dot_o "s" + createDirectoryIfMissing True (takeDirectory fp) + (warnings, dot_o_fp) <- + withWarnings "object" $ \_tweak -> do + let summary' = _tweak summary +#if MIN_GHC_API_VERSION(8,10,0) + target = defaultObjectTarget $ hsc_dflags session +#else + target = defaultObjectTarget $ targetPlatform $ hsc_dflags session +#endif + session' = session { hsc_dflags = updOptLevel 0 $ (ms_hspp_opts summary') { outputFile = Just dot_o , hscTarget = target}} + (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts +#if MIN_GHC_API_VERSION(8,10,0) + (ms_location summary') +#else + summary' +#endif + fp + compileFile session' StopLn (outputFilename, Just (As False)) + let unlinked = DotO dot_o_fp + -- Need time to be the modification time for recompilation checking + t <- liftIO $ getModificationTime dot_o_fp + let linkable = LM t mod [unlinked] + + pure (map snd warnings, linkable) + +generateByteCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) +generateByteCode hscEnv summary guts = do + fmap (either (, Nothing) (second Just)) $ + catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do + (warnings, (_, bytecode, sptEntries)) <- + withWarnings "bytecode" $ \_tweak -> do + let summary' = _tweak summary + session = hscEnv { hsc_dflags = ms_hspp_opts summary' } + hscInteractive session guts +#if MIN_GHC_API_VERSION(8,10,0) + (ms_location summary') +#else + summary' +#endif + let unlinked = BCOs bytecode sptEntries + time <- liftIO getCurrentTime + let linkable = LM time (ms_mod summary) [unlinked] + + pure (map snd warnings, linkable) + +demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule +demoteTypeErrorsToWarnings = + (update_pm_mod_summary . update_hspp_opts) demoteTEsToWarns where + + demoteTEsToWarns :: DynFlags -> DynFlags + -- convert the errors into warnings, and also check the warnings are enabled + demoteTEsToWarns = (`wopt_set` Opt_WarnDeferredTypeErrors) + . (`wopt_set` Opt_WarnTypedHoles) + . (`wopt_set` Opt_WarnDeferredOutOfScopeVariables) + . (`gopt_set` Opt_DeferTypeErrors) + . (`gopt_set` Opt_DeferTypedHoles) + . (`gopt_set` Opt_DeferOutOfScopeVariables) + +update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary +update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms} + +update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule +update_pm_mod_summary up pm = + pm{pm_mod_summary = up $ pm_mod_summary pm} + +unDefer :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic) +unDefer (Reason Opt_WarnDeferredTypeErrors , fd) = (True, upgradeWarningToError fd) +unDefer (Reason Opt_WarnTypedHoles , fd) = (True, upgradeWarningToError fd) +unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = (True, upgradeWarningToError fd) +unDefer ( _ , fd) = (False, fd) + +upgradeWarningToError :: FileDiagnostic -> FileDiagnostic +upgradeWarningToError (nfp, sh, fd) = + (nfp, sh, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where + warn2err :: T.Text -> T.Text + warn2err = T.intercalate ": error:" . T.splitOn ": warning:" + +hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic) +hideDiag originalFlags (Reason warning, (nfp, _sh, fd)) + | not (wopt warning originalFlags) + = (Reason warning, (nfp, HideDiag, fd)) +hideDiag _originalFlags t = t + +-- | Warnings which lead to a diagnostic tag +unnecessaryDeprecationWarningFlags :: [WarningFlag] +unnecessaryDeprecationWarningFlags + = [ Opt_WarnUnusedTopBinds + , Opt_WarnUnusedLocalBinds + , Opt_WarnUnusedPatternBinds + , Opt_WarnUnusedImports + , Opt_WarnUnusedMatches + , Opt_WarnUnusedTypePatterns + , Opt_WarnUnusedForalls +#if MIN_GHC_API_VERSION(8,10,0) + , Opt_WarnUnusedRecordWildcards +#endif + , Opt_WarnInaccessibleCode + , Opt_WarnWarningsDeprecations + ] + +-- | Add a unnecessary/deprecated tag to the required diagnostics. +tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic) +tagDiag (Reason warning, (nfp, sh, fd)) + | Just tag <- requiresTag warning + = (Reason warning, (nfp, sh, fd { _tags = addTag tag (_tags fd) })) + where + requiresTag :: WarningFlag -> Maybe DiagnosticTag + requiresTag Opt_WarnWarningsDeprecations + = Just DtDeprecated + requiresTag wflag -- deprecation was already considered above + | wflag `elem` unnecessaryDeprecationWarningFlags + = Just DtUnnecessary + requiresTag _ = Nothing + addTag :: DiagnosticTag -> Maybe (List DiagnosticTag) -> Maybe (List DiagnosticTag) + addTag t Nothing = Just (List [t]) + addTag t (Just (List ts)) = Just (List (t : ts)) +-- other diagnostics are left unaffected +tagDiag t = t + +addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags +addRelativeImport fp modu dflags = dflags + {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags} + +atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO () +atomicFileWrite targetPath write = do + let dir = takeDirectory targetPath + createDirectoryIfMissing True dir + (tempFilePath, cleanUp) <- newTempFileWithin dir + (write tempFilePath >> renameFile tempFilePath targetPath) `onException` cleanUp + +generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type)) +generateHieAsts hscEnv tcm = + handleGenerationErrors' dflags "extended interface generation" $ runHsc hscEnv $ do + -- These varBinds use unitDataConId but it could be anything as the id name is not used + -- during the hie file generation process. It's a workaround for the fact that the hie modules + -- don't export an interface which allows for additional information to be added to hie files. + let fake_splice_binds = listToBag (map (mkVarBind unitDataConId) (spliceExpresions $ tmrTopLevelSplices tcm)) + real_binds = tcg_binds $ tmrTypechecked tcm + Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm) + where + dflags = hsc_dflags hscEnv + +spliceExpresions :: Splices -> [LHsExpr GhcTc] +spliceExpresions Splices{..} = + DL.toList $ mconcat + [ DL.fromList $ map fst exprSplices + , DL.fromList $ map fst patSplices + , DL.fromList $ map fst typeSplices + , DL.fromList $ map fst declSplices + , DL.fromList $ map fst awSplices + ] + +-- | In addition to indexing the `.hie` file, this function is responsible for +-- maintaining the 'IndexQueue' state and notfiying the user about indexing +-- progress. +-- +-- We maintain a record of all pending index operations in the 'indexPending' +-- TVar. +-- When 'indexHieFile' is called, it must check to ensure that the file hasn't +-- already be queued up for indexing. If it has, then we can just skip it +-- +-- Otherwise, we record the current file as pending and write an indexing +-- operation to the queue +-- +-- When the indexing operation is picked up and executed by the worker thread, +-- the first thing it does is ensure that a newer index for the same file hasn't +-- been scheduled by looking at 'indexPending'. If a newer index has been +-- scheduled, we can safely skip this one +-- +-- Otherwise, we start or continue a progress reporting session, telling it +-- about progress so far and the current file we are attempting to index. Then +-- we can go ahead and call in to hiedb to actually do the indexing operation +-- +-- Once this completes, we have to update the 'IndexQueue' state. First, we +-- must remove the just indexed file from 'indexPending' Then we check if +-- 'indexPending' is now empty. In that case, we end the progress session and +-- report the total number of file indexed. We also set the 'indexCompleted' +-- TVar to 0 in order to set it up for a fresh indexing session. Otherwise, we +-- can just increment the 'indexCompleted' TVar and exit. +-- +indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Fingerprint -> Compat.HieFile -> IO () +indexHieFile se mod_summary srcPath hash hf = atomically $ do + pending <- readTVar indexPending + case HashMap.lookup srcPath pending of + Just pendingHash | pendingHash == hash -> pure () -- An index is already scheduled + _ -> do + modifyTVar' indexPending $ HashMap.insert srcPath hash + writeTQueue indexQueue $ \db -> do + -- We are now in the worker thread + -- Check if a newer index of this file has been scheduled, and if so skip this one + newerScheduled <- atomically $ do + pending <- readTVar indexPending + pure $ case HashMap.lookup srcPath pending of + Nothing -> False + -- If the hash in the pending list doesn't match the current hash, then skip + Just pendingHash -> pendingHash /= hash + unless newerScheduled $ do + pre + addRefsFromLoaded db targetPath (RealFile $ fromNormalizedFilePath srcPath) hash hf + post + where + mod_location = ms_location mod_summary + targetPath = Compat.ml_hie_file mod_location + HieDbWriter{..} = hiedbWriter se + + -- Get a progress token to report progress and update it for the current file + pre = do + tok <- modifyVar indexProgressToken $ fmap dupe . \case + x@(Just _) -> pure x + -- Create a token if we don't already have one + Nothing -> do + case lspEnv se of + Nothing -> pure Nothing + Just env -> LSP.runLspT env $ do + u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique + -- TODO: Wait for the progress create response to use the token + _ <- LSP.sendRequest LSP.SWindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ()) + LSP.sendNotification LSP.SProgress $ LSP.ProgressParams u $ + LSP.Begin $ LSP.WorkDoneProgressBeginParams + { _title = "Indexing references from:" + , _cancellable = Nothing + , _message = Nothing + , _percentage = Nothing + } + pure (Just u) + + (!done, !remaining) <- atomically $ do + done <- readTVar indexCompleted + remaining <- HashMap.size <$> readTVar indexPending + pure (done, remaining) + + let progress = " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..." + + whenJust (lspEnv se) $ \env -> whenJust tok $ \tok -> LSP.runLspT env $ + LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $ + LSP.Report $ LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = Just $ T.pack (fromNormalizedFilePath srcPath) <> progress + , _percentage = Nothing + } + + -- Report the progress once we are done indexing this file + post = do + mdone <- atomically $ do + -- Remove current element from pending + pending <- stateTVar indexPending $ + dupe . HashMap.update (\pendingHash -> guard (pendingHash /= hash) $> pendingHash) srcPath + modifyTVar' indexCompleted (+1) + -- If we are done, report and reset completed + whenMaybe (HashMap.null pending) $ + swapTVar indexCompleted 0 + whenJust (lspEnv se) $ \env -> LSP.runLspT env $ + when (coerce $ ideTesting se) $ + LSP.sendNotification (LSP.SCustomMethod "ghcide/reference/ready") $ + toJSON $ fromNormalizedFilePath srcPath + whenJust mdone $ \done -> + modifyVar_ indexProgressToken $ \tok -> do + whenJust (lspEnv se) $ \env -> LSP.runLspT env $ + whenJust tok $ \tok -> + LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $ + LSP.End $ LSP.WorkDoneProgressEndParams + { _message = Just $ "Finished indexing " <> T.pack (show done) <> " files" + } + -- We are done with the current indexing cycle, so destroy the token + pure Nothing + +writeAndIndexHieFile :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic] +writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source = + handleGenerationErrors dflags "extended interface write/compression" $ do + hf <- runHsc hscEnv $ + GHC.mkHieFile' mod_summary exports ast source + atomicFileWrite targetPath $ flip GHC.writeHieFile hf + hash <- getFileHash targetPath + indexHieFile se mod_summary srcPath hash hf + where + dflags = hsc_dflags hscEnv + mod_location = ms_location mod_summary + targetPath = Compat.ml_hie_file mod_location + +writeHiFile :: HscEnv -> HiFileResult -> IO [FileDiagnostic] +writeHiFile hscEnv tc = + handleGenerationErrors dflags "interface write" $ do + atomicFileWrite targetPath $ \fp -> + writeIfaceFile dflags fp modIface + where + modIface = hm_iface $ hirHomeMod tc + targetPath = ml_hi_file $ ms_location $ hirModSummary tc + dflags = hsc_dflags hscEnv + +handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic] +handleGenerationErrors dflags source action = + action >> return [] `catches` + [ Handler $ return . diagFromGhcException source dflags + , Handler $ return . diagFromString source DsError (noSpan "") + . (("Error during " ++ T.unpack source) ++) . show @SomeException + ] + +handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a) +handleGenerationErrors' dflags source action = + fmap ([],) action `catches` + [ Handler $ return . (,Nothing) . diagFromGhcException source dflags + , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "") + . (("Error during " ++ T.unpack source) ++) . show @SomeException + ] + +-- | Initialise the finder cache, dependencies should be topologically +-- sorted. +setupFinderCache :: [ModSummary] -> HscEnv -> IO HscEnv +setupFinderCache mss session = do + + -- Make modules available for others that import them, + -- by putting them in the finder cache. + let ims = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss + ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims + -- set the target and module graph in the session + graph = mkModuleGraph mss + + -- We have to create a new IORef here instead of modifying the existing IORef as + -- it is shared between concurrent compilations. + prevFinderCache <- readIORef $ hsc_FC session + let newFinderCache = + foldl' + (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) prevFinderCache + $ zip ims ifrs + newFinderCacheVar <- newIORef $! newFinderCache + + pure $ session { hsc_FC = newFinderCacheVar, hsc_mod_graph = graph } + + +-- | Load modules, quickly. Input doesn't need to be desugared. +-- A module must be loaded before dependent modules can be typechecked. +-- This variant of loadModuleHome will *never* cause recompilation, it just +-- modifies the session. +-- The order modules are loaded is important when there are hs-boot files. +-- In particular you should make sure to load the .hs version of a file after the +-- .hs-boot version. +loadModulesHome + :: [HomeModInfo] + -> HscEnv + -> HscEnv +loadModulesHome mod_infos e = + e { hsc_HPT = addListToHpt (hsc_HPT e) [(mod_name x, x) | x <- mod_infos] + , hsc_type_env_var = Nothing } + where + mod_name = moduleName . mi_module . hm_iface + +withBootSuffix :: HscSource -> ModLocation -> ModLocation +withBootSuffix HsBootFile = addBootSuffixLocnOut +withBootSuffix _ = id + +-- | Given a buffer, env and filepath, produce a module summary by parsing only the imports. +-- Runs preprocessors as needed. +getModSummaryFromImports + :: HscEnv + -> FilePath + -> UTCTime + -> Maybe SB.StringBuffer + -> ExceptT [FileDiagnostic] IO ModSummaryResult +getModSummaryFromImports env fp modTime contents = do + (contents, opts, dflags) <- preprocessor env fp contents + + -- The warns will hopefully be reported when we actually parse the module + (_warns, L main_loc hsmod) <- parseHeader dflags fp contents + + -- Copied from `HeaderInfo.getImports`, but we also need to keep the parsed imports + let mb_mod = hsmodName hsmod + imps = hsmodImports hsmod + + mod = fmap unLoc mb_mod `orElse` mAIN_NAME + + (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps + + -- GHC.Prim doesn't exist physically, so don't go looking for it. + ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc + . ideclName . unLoc) + ord_idecls + + implicit_prelude = xopt LangExt.ImplicitPrelude dflags + implicit_imports = mkPrelImports mod main_loc + implicit_prelude imps + convImport (L _ i) = (fmap sl_fs (ideclPkgQual i) + , ideclName i) + + srcImports = map convImport src_idecls + textualImports = map convImport (implicit_imports ++ ordinary_imps) + + msrImports = implicit_imports ++ imps + + -- Force bits that might keep the string buffer and DynFlags alive unnecessarily + liftIO $ evaluate $ rnf srcImports + liftIO $ evaluate $ rnf textualImports + + modLoc <- liftIO $ mkHomeModLocation dflags mod fp + + let modl = mkModule (thisPackage dflags) mod + sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile + msrModSummary = + ModSummary + { ms_mod = modl +#if MIN_GHC_API_VERSION(8,8,0) + , ms_hie_date = Nothing +#endif + , ms_hs_date = modTime + , ms_hsc_src = sourceType + -- The contents are used by the GetModSummary rule + , ms_hspp_buf = Just contents + , ms_hspp_file = fp + , ms_hspp_opts = dflags + , ms_iface_date = Nothing + , ms_location = withBootSuffix sourceType modLoc + , ms_obj_date = Nothing + , ms_parsed_mod = Nothing + , ms_srcimps = srcImports + , ms_textual_imps = textualImports + } + + msrFingerprint <- liftIO $ computeFingerprint opts msrModSummary + return ModSummaryResult{..} + where + -- Compute a fingerprint from the contents of `ModSummary`, + -- eliding the timestamps, the preprocessed source and other non relevant fields + computeFingerprint opts ModSummary{..} = do + fingerPrintImports <- fingerprintFromPut $ do + put $ uniq $ moduleNameFS $ moduleName ms_mod + forM_ (ms_srcimps ++ ms_textual_imps) $ \(mb_p, m) -> do + put $ uniq $ moduleNameFS $ unLoc m + whenJust mb_p $ put . uniq + return $! fingerprintFingerprints $ + [ fingerprintString fp + , fingerPrintImports + ] ++ map fingerprintString opts + + +-- | Parse only the module header +parseHeader + :: Monad m + => DynFlags -- ^ flags to use + -> FilePath -- ^ the filename (for source locations) + -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported) + -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs)) +parseHeader dflags filename contents = do + let loc = mkRealSrcLoc (mkFastString filename) 1 1 + case unP Parser.parseHeader (mkPState dflags contents loc) of +#if MIN_GHC_API_VERSION(8,10,0) + PFailed pst -> + throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags +#else + PFailed _ locErr msgErr -> + throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr +#endif + POk pst rdr_module -> do + let (warns, errs) = getMessages pst dflags + -- Just because we got a `POk`, it doesn't mean there + -- weren't errors! To clarify, the GHC parser + -- distinguishes between fatal and non-fatal + -- errors. Non-fatal errors are the sort that don't + -- prevent parsing from continuing (that is, a parse + -- tree can still be produced despite the error so that + -- further errors/warnings can be collected). Fatal + -- errors are those from which a parse tree just can't + -- be produced. + unless (null errs) $ + throwE $ diagFromErrMsgs "parser" dflags errs + + let warnings = diagFromErrMsgs "parser" dflags warns + return (warnings, rdr_module) + +-- | Given a buffer, flags, and file path, produce a +-- parsed module (or errors) and any parse warnings. Does not run any preprocessors +-- ModSummary must contain the (preprocessed) contents of the buffer +parseFileContents + :: HscEnv + -> (GHC.ParsedSource -> IdePreprocessedSource) + -> FilePath -- ^ the filename (for source locations) + -> ModSummary + -> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule) +parseFileContents env customPreprocessor filename ms = do + let loc = mkRealSrcLoc (mkFastString filename) 1 1 + dflags = ms_hspp_opts ms + contents = fromJust $ ms_hspp_buf ms + case unP Parser.parseModule (mkPState dflags contents loc) of +#if MIN_GHC_API_VERSION(8,10,0) + PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags +#else + PFailed _ locErr msgErr -> + throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr +#endif + POk pst rdr_module -> + let hpm_annotations = + (Map.fromListWith (++) $ annotations pst, + Map.fromList ((noSrcSpan,comment_q pst) + :annotations_comments pst)) + (warns, errs) = getMessages pst dflags + in + do + -- Just because we got a `POk`, it doesn't mean there + -- weren't errors! To clarify, the GHC parser + -- distinguishes between fatal and non-fatal + -- errors. Non-fatal errors are the sort that don't + -- prevent parsing from continuing (that is, a parse + -- tree can still be produced despite the error so that + -- further errors/warnings can be collected). Fatal + -- errors are those from which a parse tree just can't + -- be produced. + unless (null errs) $ + throwE $ diagFromErrMsgs "parser" dflags errs + + -- Ok, we got here. It's safe to continue. + let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module + + unless (null errs) $ + throwE $ diagFromStrings "parser" DsError errs + + let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns + parsed' <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed + + -- To get the list of extra source files, we take the list + -- that the parser gave us, + -- - eliminate files beginning with '<'. gcc likes to use + -- pseudo-filenames like "" and "" + -- - normalise them (eliminate differences between ./f and f) + -- - filter out the preprocessed source file + -- - filter out anything beginning with tmpdir + -- - remove duplicates + -- - filter out the .hs/.lhs source filename if we have one + -- + let n_hspp = normalise filename + srcs0 = nubOrd $ filter (not . (tmpDir dflags `isPrefixOf`)) + $ filter (/= n_hspp) + $ map normalise + $ filter (not . isPrefixOf "<") + $ map unpackFS + $ srcfiles pst + srcs1 = case ml_hs_file (ms_location ms) of + Just f -> filter (/= normalise f) srcs0 + Nothing -> srcs0 + + -- sometimes we see source files from earlier + -- preprocessing stages that cannot be found, so just + -- filter them out: + srcs2 <- liftIO $ filterM doesFileExist srcs1 + + let pm = + ParsedModule { + pm_mod_summary = ms + , pm_parsed_source = parsed' + , pm_extra_src_files = srcs2 + , pm_annotations = hpm_annotations + } + warnings = diagFromErrMsgs "parser" dflags warns + pure (warnings ++ preproc_warnings, pm) + +loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile +loadHieFile ncu f = do + GHC.hie_file_result <$> GHC.readHieFile ncu f + +-- | Retuns an up-to-date module interface, regenerating if needed. +-- Assumes file exists. +-- Requires the 'HscEnv' to be set up with dependencies +loadInterface + :: MonadIO m => HscEnv + -> ModSummary + -> SourceModified + -> Maybe LinkableType + -> (Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult)) -- ^ Action to regenerate an interface + -> m ([FileDiagnostic], Maybe HiFileResult) +loadInterface session ms sourceMod linkableNeeded regen = do + let sessionWithMsDynFlags = session{hsc_dflags = ms_hspp_opts ms} + res <- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod Nothing + case res of + (UpToDate, Just iface) + -- If the module used TH splices when it was last + -- compiled, then the recompilation check is not + -- accurate enough (https://gitlab.haskell.org/ghc/ghc/-/issues/481) + -- and we must ignore + -- it. However, if the module is stable (none of + -- the modules it depends on, directly or + -- indirectly, changed), then we *can* skip + -- recompilation. This is why the SourceModified + -- type contains SourceUnmodifiedAndStable, and + -- it's pretty important: otherwise ghc --make + -- would always recompile TH modules, even if + -- nothing at all has changed. Stability is just + -- the same check that make is doing for us in + -- one-shot mode. + | not (mi_used_th iface) || SourceUnmodifiedAndStable == sourceMod + -> do + linkable <- case linkableNeeded of + Just ObjectLinkable -> liftIO $ findObjectLinkableMaybe (ms_mod ms) (ms_location ms) + _ -> pure Nothing + + -- We don't need to regenerate if the object is up do date, or we don't need one + let objUpToDate = isNothing linkableNeeded || case linkable of + Nothing -> False + Just (LM obj_time _ _) -> obj_time > ms_hs_date ms + if objUpToDate + then do + hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface linkable + return ([], Just $ mkHiFileResult ms hmi) + else regen linkableNeeded + (_reason, _) -> regen linkableNeeded + +mkDetailsFromIface :: HscEnv -> ModIface -> Maybe Linkable -> IO HomeModInfo +mkDetailsFromIface session iface linkable = do + details <- liftIO $ fixIO $ \details -> do + let hsc' = session { hsc_HPT = addToHpt (hsc_HPT session) (moduleName $ mi_module iface) (HomeModInfo iface details linkable) } + initIfaceLoad hsc' (typecheckIface iface) + return (HomeModInfo iface details linkable) + +-- | Non-interactive, batch version of 'InteractiveEval.getDocs'. +-- The interactive paths create problems in ghc-lib builds +--- and leads to fun errors like "Cannot continue after interface file error". +getDocsBatch + :: HscEnv + -> Module -- ^ a moudle where the names are in scope + -> [Name] + -> IO [Either String (Maybe HsDocString, Map.Map Int HsDocString)] +getDocsBatch hsc_env _mod _names = do + ((_warns,errs), res) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ forM _names $ \name -> + case nameModule_maybe name of + Nothing -> return (Left $ NameHasNoModule name) + Just mod -> do + ModIface { mi_doc_hdr = mb_doc_hdr + , mi_decl_docs = DeclDocMap dmap + , mi_arg_docs = ArgDocMap amap + } <- loadModuleInterface "getModuleInterface" mod + if isNothing mb_doc_hdr && Map.null dmap && Map.null amap + then pure (Left (NoDocsInIface mod $ compiled name)) + else pure (Right ( Map.lookup name dmap + , Map.findWithDefault Map.empty name amap)) + case res of + Just x -> return $ map (first $ T.unpack . showGhc) x + Nothing -> throwErrors errs + where + throwErrors = liftIO . throwIO . mkSrcErr + compiled n = + -- TODO: Find a more direct indicator. + case nameSrcLoc n of + RealSrcLoc {} -> False + UnhelpfulLoc {} -> True + +fakeSpan :: RealSrcSpan +fakeSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "") 1 1 + +-- | Non-interactive, batch version of 'InteractiveEval.lookupNames'. +-- The interactive paths create problems in ghc-lib builds +--- and leads to fun errors like "Cannot continue after interface file error". +lookupName :: HscEnv + -> Module -- ^ A module where the Names are in scope + -> Name + -> IO (Maybe TyThing) +lookupName hsc_env mod name = do + (_messages, res) <- initTc hsc_env HsSrcFile False mod fakeSpan $ do + tcthing <- tcLookup name + case tcthing of + AGlobal thing -> return thing + ATcId{tct_id=id} -> return (AnId id) + _ -> panic "tcRnLookupName'" + return res diff --git a/src/Development/IDE/Core/Debouncer.hs b/src/Development/IDE/Core/Debouncer.hs --- a/src/Development/IDE/Core/Debouncer.hs +++ b/src/Development/IDE/Core/Debouncer.hs @@ -1,57 +1,59 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -module Development.IDE.Core.Debouncer - ( Debouncer - , registerEvent - , newAsyncDebouncer - , noopDebouncer - ) where - -import Control.Concurrent.Extra -import Control.Concurrent.Async -import Control.Exception -import Control.Monad.Extra -import Data.Hashable -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as Map -import System.Time.Extra - --- | A debouncer can be used to avoid triggering many events --- (e.g. diagnostics) for the same key (e.g. the same file) --- within a short timeframe. This is accomplished --- by delaying each event for a given time. If another event --- is registered for the same key within that timeframe, --- only the new event will fire. --- --- We abstract over the debouncer used so we an use a proper debouncer in the IDE but disable --- debouncing in the DAML CLI compiler. -newtype Debouncer k = Debouncer { registerEvent :: Seconds -> k -> IO () -> IO () } - --- | Debouncer used in the IDE that delays events as expected. -newAsyncDebouncer :: (Eq k, Hashable k) => IO (Debouncer k) -newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty - --- | Register an event that will fire after the given delay if no other event --- for the same key gets registered until then. --- --- If there is a pending event for the same key, the pending event will be killed. --- Events are run unmasked so it is up to the user of `registerEvent` --- to mask if required. -asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO () -asyncRegisterEvent d 0 k fire = do - modifyVar_ d $ \m -> mask_ $ do - whenJust (Map.lookup k m) cancel - pure $ Map.delete k m - fire -asyncRegisterEvent d delay k fire = modifyVar_ d $ \m -> mask_ $ do - whenJust (Map.lookup k m) cancel - a <- asyncWithUnmask $ \unmask -> unmask $ do - sleep delay - fire - modifyVar_ d (pure . Map.delete k) - pure $ Map.insert k a m - --- | Debouncer used in the DAML CLI compiler that emits events immediately. -noopDebouncer :: Debouncer k -noopDebouncer = Debouncer $ \_ _ a -> a +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Development.IDE.Core.Debouncer + ( Debouncer + , registerEvent + , newAsyncDebouncer + , noopDebouncer + ) where + +import Control.Concurrent.Async +import Control.Concurrent.Strict +import Control.Exception +import Control.Monad (join) +import Data.Foldable (traverse_) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map +import Data.Hashable +import System.Time.Extra + +-- | A debouncer can be used to avoid triggering many events +-- (e.g. diagnostics) for the same key (e.g. the same file) +-- within a short timeframe. This is accomplished +-- by delaying each event for a given time. If another event +-- is registered for the same key within that timeframe, +-- only the new event will fire. +-- +-- We abstract over the debouncer used so we an use a proper debouncer in the IDE but disable +-- debouncing in the DAML CLI compiler. +newtype Debouncer k = Debouncer { registerEvent :: Seconds -> k -> IO () -> IO () } + +-- | Debouncer used in the IDE that delays events as expected. +newAsyncDebouncer :: (Eq k, Hashable k) => IO (Debouncer k) +newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty + +-- | Register an event that will fire after the given delay if no other event +-- for the same key gets registered until then. +-- +-- If there is a pending event for the same key, the pending event will be killed. +-- Events are run unmasked so it is up to the user of `registerEvent` +-- to mask if required. +asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO () +asyncRegisterEvent d 0 k fire = do + join $ modifyVar d $ \m -> do + (cancel, !m') <- evaluate $ Map.alterF (\prev -> (traverse_ cancel prev, Nothing)) k m + return (m', cancel) + fire +asyncRegisterEvent d delay k fire = mask_ $ do + a <- asyncWithUnmask $ \unmask -> unmask $ do + sleep delay + fire + modifyVar_ d (evaluate . Map.delete k) + join $ modifyVar d $ \m -> do + (cancel, !m') <- evaluate $ Map.alterF (\prev -> (traverse_ cancel prev, Just a)) k m + return (m', cancel) + +-- | Debouncer used in the DAML CLI compiler that emits events immediately. +noopDebouncer :: Debouncer k +noopDebouncer = Debouncer $ \_ _ a -> a diff --git a/src/Development/IDE/Core/FileExists.hs b/src/Development/IDE/Core/FileExists.hs --- a/src/Development/IDE/Core/FileExists.hs +++ b/src/Development/IDE/Core/FileExists.hs @@ -1,239 +1,248 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -module Development.IDE.Core.FileExists - ( fileExistsRules - , modifyFileExists - , getFileExists - , watchedGlobs - , GetFileExists(..) - ) -where - -import Control.Concurrent.Extra -import Control.Exception -import Control.Monad.Extra -import Data.Binary -import qualified Data.ByteString as BS -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Maybe -import Development.IDE.Core.FileStore -import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.Shake -import Development.IDE.Types.Location -import Development.IDE.Types.Options -import Development.Shake -import Development.Shake.Classes -import GHC.Generics -import Language.LSP.Server hiding (getVirtualFile) -import Language.LSP.Types -import Language.LSP.Types.Capabilities -import qualified System.Directory as Dir -import qualified System.FilePath.Glob as Glob - -{- Note [File existence cache and LSP file watchers] -Some LSP servers provide the ability to register file watches with the client, which will then notify -us of file changes. Some clients can do this more efficiently than us, or generally it's a tricky -problem - -Here we use this to maintain a quick lookup cache of file existence. How this works is: -- On startup, if the client supports it we ask it to watch some files (see below). -- When those files are created or deleted (we can also see change events, but we don't -care since we're only caching existence here) we get a notification from the client. -- The notification handler calls 'modifyFileExists' to update our cache. - -This means that the cache will only ever work for the files we have set up a watcher for. -So we pick the set that we mostly care about and which are likely to change existence -most often: the source files of the project (as determined by the source extensions -we're configured to care about). - -For all other files we fall back to the slow path. - -There are a few failure modes to think about: - -1. The client doesn't send us the notifications we asked for. - -There's not much we can do in this case: the whole point is to rely on the client so -we don't do the checking ourselves. If the client lets us down, we will just be wrong. - -2. Races between registering watchers, getting notifications, and file changes. - -If a file changes status between us asking for notifications and the client actually -setting up the notifications, we might not get told about it. But this is a relatively -small race window around startup, so we just don't worry about it. - -3. Using the fast path for files that we aren't watching. - -In this case we will fall back to the slow path, but cache that result forever (since -it won't get invalidated by a client notification). To prevent this we guard the -fast path by a check that the path also matches our watching patterns. --} - --- See Note [File existence cache and LSP file watchers] --- | A map for tracking the file existence. --- If a path maps to 'True' then it exists; if it maps to 'False' then it doesn't exist'; and --- if it's not in the map then we don't know. -type FileExistsMap = (HashMap NormalizedFilePath Bool) - --- | A wrapper around a mutable 'FileExistsState' -newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap) - -instance IsIdeGlobal FileExistsMapVar - --- | Grab the current global value of 'FileExistsMap' without acquiring a dependency -getFileExistsMapUntracked :: Action FileExistsMap -getFileExistsMapUntracked = do - FileExistsMapVar v <- getIdeGlobalAction - liftIO $ readVar v - --- | Modify the global store of file exists. -modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO () -modifyFileExists state changes = do - FileExistsMapVar var <- getIdeGlobalState state - changesMap <- evaluate $ HashMap.fromList changes - -- Masked to ensure that the previous values are flushed together with the map update - mask $ \_ -> do - -- update the map - modifyVar_ var $ evaluate . HashMap.union changesMap - -- See Note [Invalidating file existence results] - -- flush previous values - mapM_ (deleteValue state GetFileExists . fst) changes - -------------------------------------------------------------------------------------- - -type instance RuleResult GetFileExists = Bool - -data GetFileExists = GetFileExists - deriving (Eq, Show, Typeable, Generic) - -instance NFData GetFileExists -instance Hashable GetFileExists -instance Binary GetFileExists - --- | Returns True if the file exists --- Note that a file is not considered to exist unless it is saved to disk. --- In particular, VFS existence is not enough. --- Consider the following example: --- 1. The file @A.hs@ containing the line @import B@ is added to the files of interest --- Since @B.hs@ is neither open nor exists, GetLocatedImports finds Nothing --- 2. The editor creates a new buffer @B.hs@ --- Unless the editor also sends a @DidChangeWatchedFile@ event, ghcide will not pick it up --- Most editors, e.g. VSCode, only send the event when the file is saved to disk. -getFileExists :: NormalizedFilePath -> Action Bool -getFileExists fp = use_ GetFileExists fp - -{- Note [Which files should we watch?] -The watcher system gives us a lot of flexibility: we can set multiple watchers, and they can all watch on glob -patterns. - -We used to have a quite precise system, where we would register a watcher for a single file path only (and always) -when we actually looked to see if it existed. The downside of this is that it sends a *lot* of notifications -to the client (thousands on a large project), and this could lock up some clients like emacs -(https://github.com/emacs-lsp/lsp-mode/issues/2165). - -Now we take the opposite approach: we register a single, quite general watcher that looks for all files -with a predefined set of extensions. The consequences are: -- The client will have to watch more files. This is usually not too bad, since the pattern is a single glob, -and the clients typically call out to an optimized implementation of file watching that understands globs. -- The client will send us a lot more notifications. This isn't too bad in practice, since although -we're watching a lot of files in principle, they don't get created or destroyed that often. -- We won't ever hit the fast lookup path for files which aren't in our watch pattern, since the only way -files get into our map is when the client sends us a notification about them because we're watching them. -This is fine so long as we're watching the files we check most often, i.e. source files. --} - --- | The list of file globs that we ask the client to watch. -watchedGlobs :: IdeOptions -> [String] -watchedGlobs opts = [ "**/*." ++ extIncBoot | ext <- optExtensions opts, extIncBoot <- [ext, ext ++ "-boot"]] - --- | Installs the 'getFileExists' rules. --- Provides a fast implementation if client supports dynamic watched files. --- Creates a global state as a side effect in that case. -fileExistsRules :: Maybe (LanguageContextEnv c) -> VFSHandle -> Rules () -fileExistsRules lspEnv vfs = do - supportsWatchedFiles <- case lspEnv of - Just lspEnv' -> liftIO $ runLspT lspEnv' $ do - ClientCapabilities {_workspace} <- getClientCapabilities - case () of - _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace - , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles - , Just True <- _dynamicRegistration - -> pure True - _ -> pure False - Nothing -> pure False - -- Create the global always, although it should only be used if we have fast rules. - -- But there's a chance someone will send unexpected notifications anyway, - -- e.g. https://github.com/haskell/ghcide/issues/599 - addIdeGlobal . FileExistsMapVar =<< liftIO (newVar []) - - extras <- getShakeExtrasRules - opts <- liftIO $ getIdeOptionsIO extras - let globs = watchedGlobs opts - - if supportsWatchedFiles - then fileExistsRulesFast globs vfs - else fileExistsRulesSlow vfs - --- Requires an lsp client that provides WatchedFiles notifications, but assumes that this has already been checked. -fileExistsRulesFast :: [String] -> VFSHandle -> Rules () -fileExistsRulesFast globs vfs = - let patterns = fmap Glob.compile globs - fpMatches fp = any (\p -> Glob.match p fp) patterns - in defineEarlyCutoff $ \GetFileExists file -> do - isWf <- isWorkspaceFile file - if isWf && fpMatches (fromNormalizedFilePath file) - then fileExistsFast vfs file - else fileExistsSlow vfs file - -{- Note [Invalidating file existence results] -We have two mechanisms for getting file existence information: -- The file existence cache -- The VFS lookup - -Both of these affect the results of the 'GetFileExists' rule, so we need to make sure it -is invalidated properly when things change. - -For the file existence cache, we manually flush the results of 'GetFileExists' when we -modify it (i.e. when a notification comes from the client). This is faster than using -'alwaysRerun' in the 'fileExistsFast', and we need it to be as fast as possible. - -For the VFS lookup, however, we won't get prompted to flush the result, so instead -we use 'alwaysRerun'. --} - -fileExistsFast :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool)) -fileExistsFast vfs file = do - -- Could in principle use 'alwaysRerun' here, but it's too slwo, See Note [Invalidating file existence results] - mp <- getFileExistsMapUntracked - - let mbFilesWatched = HashMap.lookup file mp - exist <- case mbFilesWatched of - Just exist -> pure exist - -- We don't know about it: use the slow route. - -- Note that we do *not* call 'fileExistsSlow', as that would trigger 'alwaysRerun'. - Nothing -> liftIO $ getFileExistsVFS vfs file - pure (summarizeExists exist, ([], Just exist)) - -summarizeExists :: Bool -> Maybe BS.ByteString -summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty - -fileExistsRulesSlow :: VFSHandle -> Rules () -fileExistsRulesSlow vfs = - defineEarlyCutoff $ \GetFileExists file -> fileExistsSlow vfs file - -fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool)) -fileExistsSlow vfs file = do - -- See Note [Invalidating file existence results] - alwaysRerun - exist <- liftIO $ getFileExistsVFS vfs file - pure (summarizeExists exist, ([], Just exist)) - -getFileExistsVFS :: VFSHandle -> NormalizedFilePath -> IO Bool -getFileExistsVFS vfs file = do - -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute - -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly - -- cached 'No' rather than an exception in the wrong place - handle (\(_ :: IOException) -> return False) $ - (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^ - Dir.doesFileExist (fromNormalizedFilePath file) +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Development.IDE.Core.FileExists + ( fileExistsRules + , modifyFileExists + , getFileExists + , watchedGlobs + , GetFileExists(..) + ) +where + +import Control.Concurrent.Strict +import Control.Exception +import Control.Monad.Extra +import qualified Data.ByteString as BS +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Maybe +import Development.IDE.Core.FileStore +import Development.IDE.Core.IdeConfiguration +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Shake +import Development.IDE.Types.Location +import Development.IDE.Types.Options +import Development.Shake +import Language.LSP.Server hiding (getVirtualFile) +import Language.LSP.Types +import Language.LSP.Types.Capabilities +import qualified System.Directory as Dir +import qualified System.FilePath.Glob as Glob + +{- Note [File existence cache and LSP file watchers] +Some LSP servers provide the ability to register file watches with the client, which will then notify +us of file changes. Some clients can do this more efficiently than us, or generally it's a tricky +problem + +Here we use this to maintain a quick lookup cache of file existence. How this works is: +- On startup, if the client supports it we ask it to watch some files (see below). +- When those files are created or deleted (we can also see change events, but we don't +care since we're only caching existence here) we get a notification from the client. +- The notification handler calls 'modifyFileExists' to update our cache. + +This means that the cache will only ever work for the files we have set up a watcher for. +So we pick the set that we mostly care about and which are likely to change existence +most often: the source files of the project (as determined by the source extensions +we're configured to care about). + +For all other files we fall back to the slow path. + +There are a few failure modes to think about: + +1. The client doesn't send us the notifications we asked for. + +There's not much we can do in this case: the whole point is to rely on the client so +we don't do the checking ourselves. If the client lets us down, we will just be wrong. + +2. Races between registering watchers, getting notifications, and file changes. + +If a file changes status between us asking for notifications and the client actually +setting up the notifications, we might not get told about it. But this is a relatively +small race window around startup, so we just don't worry about it. + +3. Using the fast path for files that we aren't watching. + +In this case we will fall back to the slow path, but cache that result forever (since +it won't get invalidated by a client notification). To prevent this we guard the +fast path by a check that the path also matches our watching patterns. +-} + +-- See Note [File existence cache and LSP file watchers] +-- | A map for tracking the file existence. +-- If a path maps to 'True' then it exists; if it maps to 'False' then it doesn't exist'; and +-- if it's not in the map then we don't know. +type FileExistsMap = (HashMap NormalizedFilePath Bool) + +-- | A wrapper around a mutable 'FileExistsState' +newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap) + +instance IsIdeGlobal FileExistsMapVar + +-- | Grab the current global value of 'FileExistsMap' without acquiring a dependency +getFileExistsMapUntracked :: Action FileExistsMap +getFileExistsMapUntracked = do + FileExistsMapVar v <- getIdeGlobalAction + liftIO $ readVar v + +-- | Modify the global store of file exists. +modifyFileExists :: IdeState -> [FileEvent] -> IO () +modifyFileExists state changes = do + FileExistsMapVar var <- getIdeGlobalState state + changesMap <- evaluate $ HashMap.fromList $ + [ (toNormalizedFilePath' f, newState) + | FileEvent uri change <- changes + , Just f <- [uriToFilePath uri] + , Just newState <- [fromChange change] + ] + -- Masked to ensure that the previous values are flushed together with the map update + mask $ \_ -> do + -- update the map + void $ modifyVar' var $ HashMap.union changesMap + -- See Note [Invalidating file existence results] + -- flush previous values + mapM_ (deleteValue (shakeExtras state) GetFileExists) (HashMap.keys changesMap) + +fromChange :: FileChangeType -> Maybe Bool +fromChange FcCreated = Just True +fromChange FcDeleted = Just True +fromChange FcChanged = Nothing + +------------------------------------------------------------------------------------- + +-- | Returns True if the file exists +-- Note that a file is not considered to exist unless it is saved to disk. +-- In particular, VFS existence is not enough. +-- Consider the following example: +-- 1. The file @A.hs@ containing the line @import B@ is added to the files of interest +-- Since @B.hs@ is neither open nor exists, GetLocatedImports finds Nothing +-- 2. The editor creates a new buffer @B.hs@ +-- Unless the editor also sends a @DidChangeWatchedFile@ event, ghcide will not pick it up +-- Most editors, e.g. VSCode, only send the event when the file is saved to disk. +getFileExists :: NormalizedFilePath -> Action Bool +getFileExists fp = use_ GetFileExists fp + +{- Note [Which files should we watch?] +The watcher system gives us a lot of flexibility: we can set multiple watchers, and they can all watch on glob +patterns. + +We used to have a quite precise system, where we would register a watcher for a single file path only (and always) +when we actually looked to see if it existed. The downside of this is that it sends a *lot* of notifications +to the client (thousands on a large project), and this could lock up some clients like emacs +(https://github.com/emacs-lsp/lsp-mode/issues/2165). + +Now we take the opposite approach: we register a single, quite general watcher that looks for all files +with a predefined set of extensions. The consequences are: +- The client will have to watch more files. This is usually not too bad, since the pattern is a single glob, +and the clients typically call out to an optimized implementation of file watching that understands globs. +- The client will send us a lot more notifications. This isn't too bad in practice, since although +we're watching a lot of files in principle, they don't get created or destroyed that often. +- We won't ever hit the fast lookup path for files which aren't in our watch pattern, since the only way +files get into our map is when the client sends us a notification about them because we're watching them. +This is fine so long as we're watching the files we check most often, i.e. source files. +-} + +-- | The list of file globs that we ask the client to watch. +watchedGlobs :: IdeOptions -> [String] +watchedGlobs opts = [ "**/*." ++ ext | ext <- allExtensions opts] + +allExtensions :: IdeOptions -> [String] +allExtensions opts = [extIncBoot | ext <- optExtensions opts, extIncBoot <- [ext, ext ++ "-boot"]] + +-- | Installs the 'getFileExists' rules. +-- Provides a fast implementation if client supports dynamic watched files. +-- Creates a global state as a side effect in that case. +fileExistsRules :: Maybe (LanguageContextEnv c) -> VFSHandle -> Rules () +fileExistsRules lspEnv vfs = do + supportsWatchedFiles <- case lspEnv of + Just lspEnv' -> liftIO $ runLspT lspEnv' $ do + ClientCapabilities {_workspace} <- getClientCapabilities + case () of + _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace + , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles + , Just True <- _dynamicRegistration + -> pure True + _ -> pure False + Nothing -> pure False + -- Create the global always, although it should only be used if we have fast rules. + -- But there's a chance someone will send unexpected notifications anyway, + -- e.g. https://github.com/haskell/ghcide/issues/599 + addIdeGlobal . FileExistsMapVar =<< liftIO (newVar []) + + extras <- getShakeExtrasRules + opts <- liftIO $ getIdeOptionsIO extras + let globs = watchedGlobs opts + patterns = fmap Glob.compile globs + fpMatches fp = any (`Glob.match`fp) patterns + isWatched = if supportsWatchedFiles + then \f -> do + isWF <- isWorkspaceFile f + return $ isWF && fpMatches (fromNormalizedFilePath f) + else const $ pure False + + if supportsWatchedFiles + then fileExistsRulesFast isWatched vfs + else fileExistsRulesSlow vfs + + fileStoreRules vfs isWatched + +-- Requires an lsp client that provides WatchedFiles notifications, but assumes that this has already been checked. +fileExistsRulesFast :: (NormalizedFilePath -> Action Bool) -> VFSHandle -> Rules () +fileExistsRulesFast isWatched vfs = + defineEarlyCutoff $ RuleNoDiagnostics $ \GetFileExists file -> do + isWF <- isWatched file + if isWF + then fileExistsFast vfs file + else fileExistsSlow vfs file + +{- Note [Invalidating file existence results] +We have two mechanisms for getting file existence information: +- The file existence cache +- The VFS lookup + +Both of these affect the results of the 'GetFileExists' rule, so we need to make sure it +is invalidated properly when things change. + +For the file existence cache, we manually flush the results of 'GetFileExists' when we +modify it (i.e. when a notification comes from the client). This is faster than using +'alwaysRerun' in the 'fileExistsFast', and we need it to be as fast as possible. + +For the VFS lookup, however, we won't get prompted to flush the result, so instead +we use 'alwaysRerun'. +-} + +fileExistsFast :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool) +fileExistsFast vfs file = do + -- Could in principle use 'alwaysRerun' here, but it's too slwo, See Note [Invalidating file existence results] + mp <- getFileExistsMapUntracked + + let mbFilesWatched = HashMap.lookup file mp + exist <- case mbFilesWatched of + Just exist -> pure exist + -- We don't know about it: use the slow route. + -- Note that we do *not* call 'fileExistsSlow', as that would trigger 'alwaysRerun'. + Nothing -> liftIO $ getFileExistsVFS vfs file + pure (summarizeExists exist, Just exist) + +summarizeExists :: Bool -> Maybe BS.ByteString +summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty + +fileExistsRulesSlow :: VFSHandle -> Rules () +fileExistsRulesSlow vfs = + defineEarlyCutoff $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow vfs file + +fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool) +fileExistsSlow vfs file = do + -- See Note [Invalidating file existence results] + alwaysRerun + exist <- liftIO $ getFileExistsVFS vfs file + pure (summarizeExists exist, Just exist) + +getFileExistsVFS :: VFSHandle -> NormalizedFilePath -> IO Bool +getFileExistsVFS vfs file = do + -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute + -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly + -- cached 'No' rather than an exception in the wrong place + handle (\(_ :: IOException) -> return False) $ + (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^ + Dir.doesFileExist (fromNormalizedFilePath file) diff --git a/src/Development/IDE/Core/FileStore.hs b/src/Development/IDE/Core/FileStore.hs --- a/src/Development/IDE/Core/FileStore.hs +++ b/src/Development/IDE/Core/FileStore.hs @@ -1,242 +1,312 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} - -module Development.IDE.Core.FileStore( - getFileContents, - getVirtualFile, - setFileModified, - setSomethingModified, - fileStoreRules, - modificationTime, - typecheckParents, - VFSHandle, - makeVFSHandle, - makeLSPVFSHandle, - isFileOfInterestRule - ) where - -import Development.IDE.GHC.Orphans() -import Development.IDE.Core.Shake -import Control.Concurrent.Extra -import Control.Concurrent.STM (atomically) -import Control.Concurrent.STM.TQueue (writeTQueue) -import qualified Data.Map.Strict as Map -import qualified Data.HashMap.Strict as HM -import Data.Maybe -import qualified Data.Text as T -import Control.Monad.Extra -import Development.Shake -import Development.Shake.Classes -import Control.Exception -import Data.Either.Extra -import Data.Int (Int64) -import Data.Time -import System.IO.Error -import qualified Data.ByteString.Char8 as BS -import Development.IDE.Types.Diagnostics -import Development.IDE.Types.Location -import Development.IDE.Core.OfInterest (getFilesOfInterest) -import Development.IDE.Core.RuleTypes -import Development.IDE.Types.Options -import qualified Data.Rope.UTF16 as Rope -import Development.IDE.Import.DependencyInformation -import Ide.Plugin.Config (CheckParents(..)) -import HieDb.Create (deleteMissingRealFiles) - -#ifdef mingw32_HOST_OS -import qualified System.Directory as Dir -#else -import Data.Time.Clock.System (systemToUTCTime, SystemTime(MkSystemTime)) -import Foreign.Ptr -import Foreign.C.String -import Foreign.C.Types -import Foreign.Marshal (alloca) -import Foreign.Storable -import qualified System.Posix.Error as Posix -#endif - -import qualified Development.IDE.Types.Logger as L - -import Language.LSP.Server hiding (getVirtualFile) -import qualified Language.LSP.Server as LSP -import Language.LSP.VFS - -makeVFSHandle :: IO VFSHandle -makeVFSHandle = do - vfsVar <- newVar (1, Map.empty) - pure VFSHandle - { getVirtualFile = \uri -> do - (_nextVersion, vfs) <- readVar vfsVar - pure $ Map.lookup uri vfs - , setVirtualFileContents = Just $ \uri content -> - modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $ - case content of - Nothing -> Map.delete uri vfs - -- The second version number is only used in persistFileVFS which we do not use so we set it to 0. - Just content -> Map.insert uri (VirtualFile nextVersion 0 (Rope.fromText content)) vfs - } - -makeLSPVFSHandle :: LanguageContextEnv c -> VFSHandle -makeLSPVFSHandle lspEnv = VFSHandle - { getVirtualFile = runLspT lspEnv . LSP.getVirtualFile - , setVirtualFileContents = Nothing - } - - -isFileOfInterestRule :: Rules () -isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do - filesOfInterest <- getFilesOfInterest - let res = maybe NotFOI IsFOI $ f `HM.lookup` filesOfInterest - return (Just $ BS.pack $ show $ hash res, ([], Just res)) - -getModificationTimeRule :: VFSHandle -> Rules () -getModificationTimeRule vfs = - defineEarlyCutoff $ \(GetModificationTime_ missingFileDiags) file -> do - let file' = fromNormalizedFilePath file - let wrap time@(l,s) = (Just $ BS.pack $ show time, ([], Just $ ModificationTime l s)) - alwaysRerun - mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file - case mbVirtual of - Just (virtualFileVersion -> ver) -> - pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver)) - Nothing -> liftIO $ fmap wrap (getModTime file') - `catch` \(e :: IOException) -> do - let err | isDoesNotExistError e = "File does not exist: " ++ file' - | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e - diag = ideErrorText file (T.pack err) - if isDoesNotExistError e && not missingFileDiags - then return (Nothing, ([], Nothing)) - else return (Nothing, ([diag], Nothing)) - --- Dir.getModificationTime is surprisingly slow since it performs --- a ton of conversions. Since we do not actually care about --- the format of the time, we can get away with something cheaper. --- For now, we only try to do this on Unix systems where it seems to get the --- time spent checking file modifications (which happens on every change) --- from > 0.5s to ~0.15s. --- We might also want to try speeding this up on Windows at some point. --- TODO leverage DidChangeWatchedFile lsp notifications on clients that --- support them, as done for GetFileExists -getModTime :: FilePath -> IO (Int64, Int64) -getModTime f = -#ifdef mingw32_HOST_OS - do time <- Dir.getModificationTime f - let !day = fromInteger $ toModifiedJulianDay $ utctDay time - !dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time - pure (day, dayTime) -#else - withCString f $ \f' -> - alloca $ \secPtr -> - alloca $ \nsecPtr -> do - Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr - CTime sec <- peek secPtr - CLong nsec <- peek nsecPtr - pure (sec, nsec) - --- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow --- as doing the FFI call ourselves :(. -foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int -#endif - -modificationTime :: FileVersion -> Maybe UTCTime -modificationTime VFSVersion{} = Nothing -modificationTime (ModificationTime large small) = Just $ internalTimeToUTCTime large small - -internalTimeToUTCTime :: Int64 -> Int64 -> UTCTime -internalTimeToUTCTime large small = -#ifdef mingw32_HOST_OS - UTCTime (ModifiedJulianDay $ fromIntegral large) (picosecondsToDiffTime $ fromIntegral small) -#else - systemToUTCTime $ MkSystemTime large (fromIntegral small) -#endif - -getFileContentsRule :: VFSHandle -> Rules () -getFileContentsRule vfs = - define $ \GetFileContents file -> do - -- need to depend on modification time to introduce a dependency with Cutoff - time <- use_ GetModificationTime file - res <- liftIO $ ideTryIOException file $ do - mbVirtual <- getVirtualFile vfs $ filePathToUri' file - pure $ Rope.toText . _text <$> mbVirtual - case res of - Left err -> return ([err], Nothing) - Right contents -> return ([], Just (time, contents)) - -ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a) -ideTryIOException fp act = - mapLeft - (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e) - <$> try act - --- | Returns the modification time and the contents. --- For VFS paths, the modification time is the current time. -getFileContents :: NormalizedFilePath -> Action (UTCTime, Maybe T.Text) -getFileContents f = do - (fv, txt) <- use_ GetFileContents f - modTime <- case modificationTime fv of - Just t -> pure t - Nothing -> do - foi <- use_ IsFileOfInterest f - liftIO $ case foi of - IsFOI Modified{} -> getCurrentTime - _ -> do - (large,small) <- getModTime $ fromNormalizedFilePath f - pure $ internalTimeToUTCTime large small - return (modTime, txt) - -fileStoreRules :: VFSHandle -> Rules () -fileStoreRules vfs = do - addIdeGlobal vfs - getModificationTimeRule vfs - getFileContentsRule vfs - isFileOfInterestRule - --- | Note that some buffer for a specific file has been modified but not --- with what changes. -setFileModified :: IdeState - -> Bool -- ^ Was the file saved? - -> NormalizedFilePath - -> IO () -setFileModified state saved nfp = do - ideOptions <- getIdeOptionsIO $ shakeExtras state - doCheckParents <- optCheckParents ideOptions - let checkParents = case doCheckParents of - AlwaysCheck -> True - CheckOnSaveAndClose -> saved - _ -> False - VFSHandle{..} <- getIdeGlobalState state - when (isJust setVirtualFileContents) $ - fail "setFileModified can't be called on this type of VFSHandle" - shakeRestart state [] - when checkParents $ - typecheckParents state nfp - -typecheckParents :: IdeState -> NormalizedFilePath -> IO () -typecheckParents state nfp = void $ shakeEnqueue (shakeExtras state) parents - where parents = mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction nfp) - -typecheckParentsAction :: NormalizedFilePath -> Action () -typecheckParentsAction nfp = do - revs <- transitiveReverseDependencies nfp <$> useNoFile_ GetModuleGraph - logger <- logger <$> getShakeExtras - let log = L.logInfo logger . T.pack - case revs of - Nothing -> liftIO $ log $ "Could not identify reverse dependencies for " ++ show nfp - Just rs -> do - liftIO $ (log $ "Typechecking reverse dependencies for " ++ show nfp ++ ": " ++ show revs) - `catch` \(e :: SomeException) -> log (show e) - () <$ uses GetModIface rs - --- | Note that some buffer somewhere has been modified, but don't say what. --- Only valid if the virtual file system was initialised by LSP, as that --- independently tracks which files are modified. -setSomethingModified :: IdeState -> IO () -setSomethingModified state = do - VFSHandle{..} <- getIdeGlobalState state - when (isJust setVirtualFileContents) $ - fail "setSomethingModified can't be called on this type of VFSHandle" - -- Update database to remove any files that might have been renamed/deleted - atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) deleteMissingRealFiles - void $ shakeRestart state [] +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +module Development.IDE.Core.FileStore( + getFileContents, + getVirtualFile, + setFileModified, + setSomethingModified, + fileStoreRules, + modificationTime, + typecheckParents, + VFSHandle, + makeVFSHandle, + makeLSPVFSHandle, + isFileOfInterestRule, + resetFileStore, + resetInterfaceStore, + getModificationTimeImpl, + addIdeGlobal, + getFileContentsImpl + ) where + +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TQueue (writeTQueue) +import Control.Concurrent.Strict +import Control.Exception +import Control.Monad.Extra +import qualified Data.ByteString as BS +import Data.Either.Extra +import qualified Data.HashMap.Strict as HM +import Data.Int (Int64) +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.Rope.UTF16 as Rope +import qualified Data.Text as T +import Data.Time +import Development.IDE.Core.OfInterest (OfInterestVar (..), + getFilesOfInterest) +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Shake +import Development.IDE.GHC.Orphans () +import Development.IDE.Import.DependencyInformation +import Development.IDE.Types.Diagnostics +import Development.IDE.Types.Location +import Development.IDE.Types.Options +import Development.Shake +import HieDb.Create (deleteMissingRealFiles) +import Ide.Plugin.Config (CheckParents (..)) +import System.IO.Error + +#ifdef mingw32_HOST_OS +import qualified System.Directory as Dir +#else +import Data.Time.Clock.System (SystemTime (MkSystemTime), + systemToUTCTime) +import Foreign.C.String +import Foreign.C.Types +import Foreign.Marshal (alloca) +import Foreign.Ptr +import Foreign.Storable +import qualified System.Posix.Error as Posix +#endif + +import qualified Development.IDE.Types.Logger as L + +import qualified Data.Binary as B +import qualified Data.ByteString.Lazy as LBS +import Language.LSP.Server hiding + (getVirtualFile) +import qualified Language.LSP.Server as LSP +import Language.LSP.Types (FileChangeType (FcChanged), + FileEvent (FileEvent), + toNormalizedFilePath, + uriToFilePath) +import Language.LSP.VFS +import System.FilePath + +makeVFSHandle :: IO VFSHandle +makeVFSHandle = do + vfsVar <- newVar (1, Map.empty) + pure VFSHandle + { getVirtualFile = \uri -> do + (_nextVersion, vfs) <- readVar vfsVar + pure $ Map.lookup uri vfs + , setVirtualFileContents = Just $ \uri content -> + void $ modifyVar' vfsVar $ \(nextVersion, vfs) -> (nextVersion + 1, ) $ + case content of + Nothing -> Map.delete uri vfs + -- The second version number is only used in persistFileVFS which we do not use so we set it to 0. + Just content -> Map.insert uri (VirtualFile nextVersion 0 (Rope.fromText content)) vfs + } + +makeLSPVFSHandle :: LanguageContextEnv c -> VFSHandle +makeLSPVFSHandle lspEnv = VFSHandle + { getVirtualFile = runLspT lspEnv . LSP.getVirtualFile + , setVirtualFileContents = Nothing + } + + +isFileOfInterestRule :: Rules () +isFileOfInterestRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest f -> do + filesOfInterest <- getFilesOfInterest + let foi = maybe NotFOI IsFOI $ f `HM.lookup` filesOfInterest + fp = summarize foi + res = (Just fp, Just foi) + return res + where + summarize NotFOI = BS.singleton 0 + summarize (IsFOI OnDisk) = BS.singleton 1 + summarize (IsFOI (Modified False)) = BS.singleton 2 + summarize (IsFOI (Modified True)) = BS.singleton 3 + + +getModificationTimeRule :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules () +getModificationTimeRule vfs isWatched = defineEarlyCutoff $ Rule $ \(GetModificationTime_ missingFileDiags) file -> + getModificationTimeImpl vfs isWatched missingFileDiags file + +getModificationTimeImpl :: VFSHandle + -> (NormalizedFilePath -> Action Bool) + -> Bool + -> NormalizedFilePath + -> Action + (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion)) +getModificationTimeImpl vfs isWatched missingFileDiags file = do + let file' = fromNormalizedFilePath file + let wrap time@(l,s) = (Just $ LBS.toStrict $ B.encode time, ([], Just $ ModificationTime l s)) + mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file + -- we use 'getVirtualFile' to discriminate FOIs so make that + -- dependency explicit by using the IsFileOfInterest rule + _ <- use_ IsFileOfInterest file + case mbVirtual of + Just (virtualFileVersion -> ver) -> do + alwaysRerun + pure (Just $ LBS.toStrict $ B.encode ver, ([], Just $ VFSVersion ver)) + Nothing -> do + isWF <- isWatched file + unless (isWF || isInterface file) alwaysRerun + liftIO $ fmap wrap (getModTime file') + `catch` \(e :: IOException) -> do + let err | isDoesNotExistError e = "File does not exist: " ++ file' + | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e + diag = ideErrorText file (T.pack err) + if isDoesNotExistError e && not missingFileDiags + then return (Nothing, ([], Nothing)) + else return (Nothing, ([diag], Nothing)) + +-- | Interface files cannot be watched, since they live outside the workspace. +-- But interface files are private, in that only HLS writes them. +-- So we implement watching ourselves, and bypass the need for alwaysRerun. +isInterface :: NormalizedFilePath -> Bool +isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hi-boot"] + +-- | Reset the GetModificationTime state of interface files +resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> IO () +resetInterfaceStore state f = do + deleteValue state (GetModificationTime_ True) f + deleteValue state (GetModificationTime_ False) f + +-- | Reset the GetModificationTime state of watched files +resetFileStore :: IdeState -> [FileEvent] -> IO () +resetFileStore ideState changes = mask $ \_ -> + forM_ changes $ \(FileEvent uri c) -> + case c of + FcChanged + | Just f <- uriToFilePath uri + -> do + -- we record FOIs document versions in all the stored values + -- so NEVER reset FOIs to avoid losing their versions + OfInterestVar foisVar <- getIdeGlobalExtras (shakeExtras ideState) + fois <- readVar foisVar + unless (HM.member (toNormalizedFilePath f) fois) $ do + deleteValue (shakeExtras ideState) (GetModificationTime_ True) (toNormalizedFilePath' f) + deleteValue (shakeExtras ideState) (GetModificationTime_ False) (toNormalizedFilePath' f) + _ -> pure () + +-- Dir.getModificationTime is surprisingly slow since it performs +-- a ton of conversions. Since we do not actually care about +-- the format of the time, we can get away with something cheaper. +-- For now, we only try to do this on Unix systems where it seems to get the +-- time spent checking file modifications (which happens on every change) +-- from > 0.5s to ~0.15s. +-- We might also want to try speeding this up on Windows at some point. +-- TODO leverage DidChangeWatchedFile lsp notifications on clients that +-- support them, as done for GetFileExists +getModTime :: FilePath -> IO (Int64, Int64) +getModTime f = +#ifdef mingw32_HOST_OS + do time <- Dir.getModificationTime f + let !day = fromInteger $ toModifiedJulianDay $ utctDay time + !dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time + pure (day, dayTime) +#else + withCString f $ \f' -> + alloca $ \secPtr -> + alloca $ \nsecPtr -> do + Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr + CTime sec <- peek secPtr + CLong nsec <- peek nsecPtr + pure (sec, nsec) + +-- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow +-- as doing the FFI call ourselves :(. +foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int +#endif + +modificationTime :: FileVersion -> Maybe UTCTime +modificationTime VFSVersion{} = Nothing +modificationTime (ModificationTime large small) = Just $ internalTimeToUTCTime large small + +internalTimeToUTCTime :: Int64 -> Int64 -> UTCTime +internalTimeToUTCTime large small = +#ifdef mingw32_HOST_OS + UTCTime (ModifiedJulianDay $ fromIntegral large) (picosecondsToDiffTime $ fromIntegral small) +#else + systemToUTCTime $ MkSystemTime large (fromIntegral small) +#endif + +getFileContentsRule :: VFSHandle -> Rules () +getFileContentsRule vfs = define $ \GetFileContents file -> getFileContentsImpl vfs file + +getFileContentsImpl + :: VFSHandle + -> NormalizedFilePath + -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe T.Text)) +getFileContentsImpl vfs file = do + -- need to depend on modification time to introduce a dependency with Cutoff + time <- use_ GetModificationTime file + res <- liftIO $ ideTryIOException file $ do + mbVirtual <- getVirtualFile vfs $ filePathToUri' file + pure $ Rope.toText . _text <$> mbVirtual + case res of + Left err -> return ([err], Nothing) + Right contents -> return ([], Just (time, contents)) + +ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a) +ideTryIOException fp act = + mapLeft + (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e) + <$> try act + +-- | Returns the modification time and the contents. +-- For VFS paths, the modification time is the current time. +getFileContents :: NormalizedFilePath -> Action (UTCTime, Maybe T.Text) +getFileContents f = do + (fv, txt) <- use_ GetFileContents f + modTime <- case modificationTime fv of + Just t -> pure t + Nothing -> do + foi <- use_ IsFileOfInterest f + liftIO $ case foi of + IsFOI Modified{} -> getCurrentTime + _ -> do + (large,small) <- getModTime $ fromNormalizedFilePath f + pure $ internalTimeToUTCTime large small + return (modTime, txt) + +fileStoreRules :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules () +fileStoreRules vfs isWatched = do + addIdeGlobal vfs + getModificationTimeRule vfs isWatched + getFileContentsRule vfs + isFileOfInterestRule + +-- | Note that some buffer for a specific file has been modified but not +-- with what changes. +setFileModified :: IdeState + -> Bool -- ^ Was the file saved? + -> NormalizedFilePath + -> IO () +setFileModified state saved nfp = do + ideOptions <- getIdeOptionsIO $ shakeExtras state + doCheckParents <- optCheckParents ideOptions + let checkParents = case doCheckParents of + AlwaysCheck -> True + CheckOnSaveAndClose -> saved + _ -> False + VFSHandle{..} <- getIdeGlobalState state + when (isJust setVirtualFileContents) $ + fail "setFileModified can't be called on this type of VFSHandle" + shakeRestart state [] + when checkParents $ + typecheckParents state nfp + +typecheckParents :: IdeState -> NormalizedFilePath -> IO () +typecheckParents state nfp = void $ shakeEnqueue (shakeExtras state) parents + where parents = mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction nfp) + +typecheckParentsAction :: NormalizedFilePath -> Action () +typecheckParentsAction nfp = do + revs <- transitiveReverseDependencies nfp <$> useNoFile_ GetModuleGraph + logger <- logger <$> getShakeExtras + let log = L.logInfo logger . T.pack + case revs of + Nothing -> liftIO $ log $ "Could not identify reverse dependencies for " ++ show nfp + Just rs -> do + liftIO $ (log $ "Typechecking reverse dependencies for " ++ show nfp ++ ": " ++ show revs) + `catch` \(e :: SomeException) -> log (show e) + () <$ uses GetModIface rs + +-- | Note that some buffer somewhere has been modified, but don't say what. +-- Only valid if the virtual file system was initialised by LSP, as that +-- independently tracks which files are modified. +setSomethingModified :: IdeState -> IO () +setSomethingModified state = do + VFSHandle{..} <- getIdeGlobalState state + when (isJust setVirtualFileContents) $ + fail "setSomethingModified can't be called on this type of VFSHandle" + -- Update database to remove any files that might have been renamed/deleted + atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) deleteMissingRealFiles + void $ shakeRestart state [] diff --git a/src/Development/IDE/Core/IdeConfiguration.hs b/src/Development/IDE/Core/IdeConfiguration.hs --- a/src/Development/IDE/Core/IdeConfiguration.hs +++ b/src/Development/IDE/Core/IdeConfiguration.hs @@ -1,91 +1,91 @@ -{-# LANGUAGE DuplicateRecordFields #-} -module Development.IDE.Core.IdeConfiguration - ( IdeConfiguration(..) - , registerIdeConfiguration - , getIdeConfiguration - , parseConfiguration - , parseWorkspaceFolder - , isWorkspaceFile - , modifyWorkspaceFolders - , modifyClientSettings - , getClientSettings - ) -where - -import Control.Concurrent.Extra -import Control.Monad -import Data.Hashable (Hashed, hashed, unhashed) -import Data.HashSet (HashSet, singleton) -import Data.Text (Text, isPrefixOf) -import Data.Aeson.Types (Value) -import Development.IDE.Core.Shake -import Development.IDE.Types.Location -import Development.Shake -import Language.LSP.Types -import System.FilePath (isRelative) - --- | Lsp client relevant configuration details -data IdeConfiguration = IdeConfiguration - { workspaceFolders :: HashSet NormalizedUri - , clientSettings :: Hashed (Maybe Value) - } - deriving (Show) - -newtype IdeConfigurationVar = IdeConfigurationVar {unIdeConfigurationRef :: Var IdeConfiguration} - -instance IsIdeGlobal IdeConfigurationVar - -registerIdeConfiguration :: ShakeExtras -> IdeConfiguration -> IO () -registerIdeConfiguration extras = - addIdeGlobalExtras extras . IdeConfigurationVar <=< newVar - -getIdeConfiguration :: Action IdeConfiguration -getIdeConfiguration = - getIdeGlobalAction >>= liftIO . readVar . unIdeConfigurationRef - -parseConfiguration :: InitializeParams -> IdeConfiguration -parseConfiguration InitializeParams {..} = - IdeConfiguration {..} - where - workspaceFolders = - foldMap (singleton . toNormalizedUri) _rootUri - <> (foldMap . foldMap) - (singleton . parseWorkspaceFolder) - _workspaceFolders - clientSettings = hashed _initializationOptions - -parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri -parseWorkspaceFolder = - toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text) - -modifyWorkspaceFolders - :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO () -modifyWorkspaceFolders ide f = modifyIdeConfiguration ide f' - where f' (IdeConfiguration ws initOpts) = IdeConfiguration (f ws) initOpts - -modifyClientSettings - :: IdeState -> (Maybe Value -> Maybe Value) -> IO () -modifyClientSettings ide f = modifyIdeConfiguration ide f' - where f' (IdeConfiguration ws clientSettings) = - IdeConfiguration ws (hashed . f . unhashed $ clientSettings) - -modifyIdeConfiguration - :: IdeState -> (IdeConfiguration -> IdeConfiguration) -> IO () -modifyIdeConfiguration ide f = do - IdeConfigurationVar var <- getIdeGlobalState ide - modifyVar_ var (pure . f) - -isWorkspaceFile :: NormalizedFilePath -> Action Bool -isWorkspaceFile file = - if isRelative (fromNormalizedFilePath file) - then return True - else do - IdeConfiguration {..} <- getIdeConfiguration - let toText = getUri . fromNormalizedUri - return $ - any - (\root -> toText root `isPrefixOf` toText (filePathToUri' file)) - workspaceFolders - -getClientSettings :: Action (Maybe Value) -getClientSettings = unhashed . clientSettings <$> getIdeConfiguration +{-# LANGUAGE DuplicateRecordFields #-} +module Development.IDE.Core.IdeConfiguration + ( IdeConfiguration(..) + , registerIdeConfiguration + , getIdeConfiguration + , parseConfiguration + , parseWorkspaceFolder + , isWorkspaceFile + , modifyWorkspaceFolders + , modifyClientSettings + , getClientSettings + ) +where + +import Control.Concurrent.Strict +import Control.Monad +import Data.Aeson.Types (Value) +import Data.HashSet (HashSet, singleton) +import Data.Hashable (Hashed, hashed, unhashed) +import Data.Text (Text, isPrefixOf) +import Development.IDE.Core.Shake +import Development.IDE.Types.Location +import Development.Shake +import Language.LSP.Types +import System.FilePath (isRelative) + +-- | Lsp client relevant configuration details +data IdeConfiguration = IdeConfiguration + { workspaceFolders :: HashSet NormalizedUri + , clientSettings :: Hashed (Maybe Value) + } + deriving (Show) + +newtype IdeConfigurationVar = IdeConfigurationVar {unIdeConfigurationRef :: Var IdeConfiguration} + +instance IsIdeGlobal IdeConfigurationVar + +registerIdeConfiguration :: ShakeExtras -> IdeConfiguration -> IO () +registerIdeConfiguration extras = + addIdeGlobalExtras extras . IdeConfigurationVar <=< newVar + +getIdeConfiguration :: Action IdeConfiguration +getIdeConfiguration = + getIdeGlobalAction >>= liftIO . readVar . unIdeConfigurationRef + +parseConfiguration :: InitializeParams -> IdeConfiguration +parseConfiguration InitializeParams {..} = + IdeConfiguration {..} + where + workspaceFolders = + foldMap (singleton . toNormalizedUri) _rootUri + <> (foldMap . foldMap) + (singleton . parseWorkspaceFolder) + _workspaceFolders + clientSettings = hashed _initializationOptions + +parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri +parseWorkspaceFolder = + toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text) + +modifyWorkspaceFolders + :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO () +modifyWorkspaceFolders ide f = modifyIdeConfiguration ide f' + where f' (IdeConfiguration ws initOpts) = IdeConfiguration (f ws) initOpts + +modifyClientSettings + :: IdeState -> (Maybe Value -> Maybe Value) -> IO () +modifyClientSettings ide f = modifyIdeConfiguration ide f' + where f' (IdeConfiguration ws clientSettings) = + IdeConfiguration ws (hashed . f . unhashed $ clientSettings) + +modifyIdeConfiguration + :: IdeState -> (IdeConfiguration -> IdeConfiguration) -> IO () +modifyIdeConfiguration ide f = do + IdeConfigurationVar var <- getIdeGlobalState ide + void $ modifyVar' var f + +isWorkspaceFile :: NormalizedFilePath -> Action Bool +isWorkspaceFile file = + if isRelative (fromNormalizedFilePath file) + then return True + else do + IdeConfiguration {..} <- getIdeConfiguration + let toText = getUri . fromNormalizedUri + return $ + any + (\root -> toText root `isPrefixOf` toText (filePathToUri' file)) + workspaceFolders + +getClientSettings :: Action (Maybe Value) +getClientSettings = unhashed . clientSettings <$> getIdeConfiguration diff --git a/src/Development/IDE/Core/OfInterest.hs b/src/Development/IDE/Core/OfInterest.hs --- a/src/Development/IDE/Core/OfInterest.hs +++ b/src/Development/IDE/Core/OfInterest.hs @@ -1,121 +1,119 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Utilities and state for the files of interest - those which are currently --- open in the editor. The useful function is 'getFilesOfInterest'. -module Development.IDE.Core.OfInterest( - ofInterestRules, - getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest, - kick, FileOfInterestStatus(..) - ) where - -import Control.Concurrent.Extra -import Data.Binary -import Data.Hashable -import Control.DeepSeq -import GHC.Generics -import Data.Typeable -import qualified Data.ByteString.UTF8 as BS -import Control.Exception -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Text as T -import Data.Tuple.Extra -import Development.Shake -import Control.Monad - -import Development.IDE.Types.Exports -import Development.IDE.Types.Location -import Development.IDE.Types.Logger -import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake -import Data.Maybe (catMaybes) -import Data.List.Extra (nubOrd) -import Development.IDE.Import.DependencyInformation -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Class -import Development.IDE.Types.Options - -newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) -instance IsIdeGlobal OfInterestVar - -type instance RuleResult GetFilesOfInterest = HashMap NormalizedFilePath FileOfInterestStatus - -data GetFilesOfInterest = GetFilesOfInterest - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetFilesOfInterest -instance NFData GetFilesOfInterest -instance Binary GetFilesOfInterest - - --- | The rule that initialises the files of interest state. -ofInterestRules :: Rules () -ofInterestRules = do - addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty) - defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do - alwaysRerun - filesOfInterest <- getFilesOfInterestUntracked - pure (Just $ BS.fromString $ show filesOfInterest, ([], Just filesOfInterest)) - - --- | Get the files that are open in the IDE. -getFilesOfInterest :: Action (HashMap NormalizedFilePath FileOfInterestStatus) -getFilesOfInterest = useNoFile_ GetFilesOfInterest - - - ------------------------------------------------------------- --- Exposed API - --- | Set the files-of-interest - not usually necessary or advisable. --- The LSP client will keep this information up to date. -setFilesOfInterest :: IdeState -> HashMap NormalizedFilePath FileOfInterestStatus -> IO () -setFilesOfInterest state files = modifyFilesOfInterest state (const files) - -getFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus) -getFilesOfInterestUntracked = do - OfInterestVar var <- getIdeGlobalAction - liftIO $ readVar var - --- | Modify the files-of-interest - not usually necessary or advisable. --- The LSP client will keep this information up to date. -modifyFilesOfInterest - :: IdeState - -> (HashMap NormalizedFilePath FileOfInterestStatus -> HashMap NormalizedFilePath FileOfInterestStatus) - -> IO () -modifyFilesOfInterest state f = do - OfInterestVar var <- getIdeGlobalState state - files <- modifyVar var $ pure . dupe . f - logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashMap.toList files) - --- | Typecheck all the files of interest. --- Could be improved -kick :: Action () -kick = do - files <- HashMap.keys <$> getFilesOfInterest - ShakeExtras{progressUpdate} <- getShakeExtras - liftIO $ progressUpdate KickStarted - - -- Update the exports map for FOIs - (results, ()) <- par (uses GenerateCore files) (void $ uses GetHieAst files) - - -- Update the exports map for non FOIs - -- We can skip this if checkProject is True, assuming they never change under our feet. - IdeOptions{ optCheckProject = doCheckProject } <- getIdeOptions - checkProject <- liftIO doCheckProject - ifaces <- if checkProject then return Nothing else runMaybeT $ do - deps <- MaybeT $ sequence <$> uses GetDependencies files - hiResults <- lift $ uses GetModIface (nubOrd $ foldMap transitiveModuleDeps deps) - return $ map hirModIface $ catMaybes hiResults - - ShakeExtras{exportsMap} <- getShakeExtras - let mguts = catMaybes results - !exportsMap' = createExportsMapMg mguts - !exportsMap'' = maybe mempty createExportsMap ifaces - liftIO $ modifyVar_ exportsMap $ evaluate . (exportsMap'' <>) . (exportsMap' <>) - - liftIO $ progressUpdate KickCompleted - +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Utilities and state for the files of interest - those which are currently +-- open in the editor. The useful function is 'getFilesOfInterest'. +module Development.IDE.Core.OfInterest( + ofInterestRules, + getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest, + kick, FileOfInterestStatus(..), + OfInterestVar(..) + ) where + +import Control.Concurrent.Strict +import Control.DeepSeq +import Control.Exception +import Control.Monad +import Data.Binary +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Hashable +import qualified Data.Text as T +import Data.Typeable +import Development.Shake +import GHC.Generics + +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import qualified Data.ByteString.Lazy as LBS +import Data.List.Extra (nubOrd) +import Data.Maybe (catMaybes) +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Shake +import Development.IDE.Import.DependencyInformation +import Development.IDE.Types.Exports +import Development.IDE.Types.Location +import Development.IDE.Types.Logger +import Development.IDE.Types.Options + +newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) +instance IsIdeGlobal OfInterestVar + +type instance RuleResult GetFilesOfInterest = HashMap NormalizedFilePath FileOfInterestStatus + +data GetFilesOfInterest = GetFilesOfInterest + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetFilesOfInterest +instance NFData GetFilesOfInterest +instance Binary GetFilesOfInterest + + +-- | The rule that initialises the files of interest state. +ofInterestRules :: Rules () +ofInterestRules = do + addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty) + defineEarlyCutoff $ RuleNoDiagnostics $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do + alwaysRerun + filesOfInterest <- getFilesOfInterestUntracked + let !cutoff = LBS.toStrict $ encode $ HashMap.toList filesOfInterest + pure (Just cutoff, Just filesOfInterest) + +-- | Get the files that are open in the IDE. +getFilesOfInterest :: Action (HashMap NormalizedFilePath FileOfInterestStatus) +getFilesOfInterest = useNoFile_ GetFilesOfInterest + +------------------------------------------------------------ +-- Exposed API + +-- | Set the files-of-interest - not usually necessary or advisable. +-- The LSP client will keep this information up to date. +setFilesOfInterest :: IdeState -> HashMap NormalizedFilePath FileOfInterestStatus -> IO () +setFilesOfInterest state files = modifyFilesOfInterest state (const files) + +getFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus) +getFilesOfInterestUntracked = do + OfInterestVar var <- getIdeGlobalAction + liftIO $ readVar var + +-- | Modify the files-of-interest - not usually necessary or advisable. +-- The LSP client will keep this information up to date. +modifyFilesOfInterest + :: IdeState + -> (HashMap NormalizedFilePath FileOfInterestStatus -> HashMap NormalizedFilePath FileOfInterestStatus) + -> IO () +modifyFilesOfInterest state f = do + OfInterestVar var <- getIdeGlobalState state + files <- modifyVar' var f + logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashMap.toList files) + +-- | Typecheck all the files of interest. +-- Could be improved +kick :: Action () +kick = do + files <- HashMap.keys <$> getFilesOfInterest + ShakeExtras{progressUpdate} <- getShakeExtras + liftIO $ progressUpdate KickStarted + + -- Update the exports map for FOIs + (results, ()) <- par (uses GenerateCore files) (void $ uses GetHieAst files) + + -- Update the exports map for non FOIs + -- We can skip this if checkProject is True, assuming they never change under our feet. + IdeOptions{ optCheckProject = doCheckProject } <- getIdeOptions + checkProject <- liftIO doCheckProject + ifaces <- if checkProject then return Nothing else runMaybeT $ do + deps <- MaybeT $ sequence <$> uses GetDependencies files + hiResults <- lift $ uses GetModIface (nubOrd $ foldMap transitiveModuleDeps deps) + return $ map hirModIface $ catMaybes hiResults + + ShakeExtras{exportsMap} <- getShakeExtras + let mguts = catMaybes results + !exportsMap' = createExportsMapMg mguts + !exportsMap'' = maybe mempty createExportsMap ifaces + void $ liftIO $ modifyVar' exportsMap $ (exportsMap'' <>) . (exportsMap' <>) + + liftIO $ progressUpdate KickCompleted + diff --git a/src/Development/IDE/Core/PositionMapping.hs b/src/Development/IDE/Core/PositionMapping.hs --- a/src/Development/IDE/Core/PositionMapping.hs +++ b/src/Development/IDE/Core/PositionMapping.hs @@ -1,213 +1,213 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 -module Development.IDE.Core.PositionMapping - ( PositionMapping(..) - , PositionResult(..) - , lowerRange - , upperRange - , positionResultToMaybe - , fromCurrentPosition - , toCurrentPosition - , PositionDelta(..) - , addDelta - , idDelta - , mkDelta - , toCurrentRange - , fromCurrentRange - , applyChange - , zeroMapping - , deltaFromDiff - -- toCurrent and fromCurrent are mainly exposed for testing - , toCurrent - , fromCurrent - ) where - -import Control.Monad -import qualified Data.Text as T -import Language.LSP.Types -import Data.List -import Data.Algorithm.Diff -import Data.Bifunctor -import Control.DeepSeq -import qualified Data.Vector.Unboxed as V - --- | Either an exact position, or the range of text that was substituted -data PositionResult a - = PositionRange -- ^ Fields need to be non-strict otherwise bind is exponential - { unsafeLowerRange :: a - , unsafeUpperRange :: a } - | PositionExact !a - deriving (Eq,Ord,Show,Functor) - -lowerRange :: PositionResult a -> a -lowerRange (PositionExact a) = a -lowerRange (PositionRange lower _) = lower - -upperRange :: PositionResult a -> a -upperRange (PositionExact a) = a -upperRange (PositionRange _ upper) = upper - -positionResultToMaybe :: PositionResult a -> Maybe a -positionResultToMaybe (PositionExact a) = Just a -positionResultToMaybe _ = Nothing - -instance Applicative PositionResult where - pure = PositionExact - (PositionExact f) <*> a = fmap f a - (PositionRange f g) <*> (PositionExact a) = PositionRange (f a) (g a) - (PositionRange f g) <*> (PositionRange lower upper) = PositionRange (f lower) (g upper) - -instance Monad PositionResult where - (PositionExact a) >>= f = f a - (PositionRange lower upper) >>= f = PositionRange lower' upper' - where - lower' = lowerRange $ f lower - upper' = upperRange $ f upper - --- The position delta is the difference between two versions -data PositionDelta = PositionDelta - { toDelta :: !(Position -> PositionResult Position) - , fromDelta :: !(Position -> PositionResult Position) - } - -instance Show PositionDelta where - show PositionDelta{} = "PositionDelta{..}" - -instance NFData PositionDelta where - rnf (PositionDelta a b) = a `seq` b `seq` () - -fromCurrentPosition :: PositionMapping -> Position -> Maybe Position -fromCurrentPosition (PositionMapping pm) = positionResultToMaybe . fromDelta pm - -toCurrentPosition :: PositionMapping -> Position -> Maybe Position -toCurrentPosition (PositionMapping pm) = positionResultToMaybe . toDelta pm - --- A position mapping is the difference from the current version to --- a specific version -newtype PositionMapping = PositionMapping PositionDelta - -toCurrentRange :: PositionMapping -> Range -> Maybe Range -toCurrentRange mapping (Range a b) = - Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b - -fromCurrentRange :: PositionMapping -> Range -> Maybe Range -fromCurrentRange mapping (Range a b) = - Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b - -zeroMapping :: PositionMapping -zeroMapping = PositionMapping idDelta - --- | Compose two position mappings. Composes in the same way as function --- composition (ie the second argument is applyed to the position first). -composeDelta :: PositionDelta - -> PositionDelta - -> PositionDelta -composeDelta (PositionDelta to1 from1) (PositionDelta to2 from2) = - PositionDelta (to1 <=< to2) - (from1 >=> from2) - -idDelta :: PositionDelta -idDelta = PositionDelta pure pure - --- | Convert a set of changes into a delta from k to k + 1 -mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta -mkDelta cs = foldl' applyChange idDelta cs - --- | Add a new delta onto a Mapping k n to make a Mapping (k - 1) n -addDelta :: PositionDelta -> PositionMapping -> PositionMapping -addDelta delta (PositionMapping pm) = PositionMapping (composeDelta delta pm) - -applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta -applyChange PositionDelta{..} (TextDocumentContentChangeEvent (Just r) _ t) = PositionDelta - { toDelta = toCurrent r t <=< toDelta - , fromDelta = fromDelta <=< fromCurrent r t - } -applyChange posMapping _ = posMapping - -toCurrent :: Range -> T.Text -> Position -> PositionResult Position -toCurrent (Range start@(Position startLine startColumn) end@(Position endLine endColumn)) t (Position line column) - | line < startLine || line == startLine && column < startColumn = - -- Position is before the change and thereby unchanged. - PositionExact $ Position line column - | line > endLine || line == endLine && column >= endColumn = - -- Position is after the change so increase line and column number - -- as necessary. - PositionExact $ newLine `seq` newColumn `seq` Position newLine newColumn - | otherwise = PositionRange start end - -- Position is in the region that was changed. - where - lineDiff = linesNew - linesOld - linesNew = T.count "\n" t - linesOld = endLine - startLine - newEndColumn - | linesNew == 0 = startColumn + T.length t - | otherwise = T.length $ T.takeWhileEnd (/= '\n') t - newColumn - | line == endLine = column + newEndColumn - endColumn - | otherwise = column - newLine = line + lineDiff - -fromCurrent :: Range -> T.Text -> Position -> PositionResult Position -fromCurrent (Range start@(Position startLine startColumn) end@(Position endLine endColumn)) t (Position line column) - | line < startLine || line == startLine && column < startColumn = - -- Position is before the change and thereby unchanged - PositionExact $ Position line column - | line > newEndLine || line == newEndLine && column >= newEndColumn = - -- Position is after the change so increase line and column number - -- as necessary. - PositionExact $ newLine `seq` newColumn `seq` Position newLine newColumn - | otherwise = PositionRange start end - -- Position is in the region that was changed. - where - lineDiff = linesNew - linesOld - linesNew = T.count "\n" t - linesOld = endLine - startLine - newEndLine = endLine + lineDiff - newEndColumn - | linesNew == 0 = startColumn + T.length t - | otherwise = T.length $ T.takeWhileEnd (/= '\n') t - newColumn - | line == newEndLine = column - (newEndColumn - endColumn) - | otherwise = column - newLine = line - lineDiff - -deltaFromDiff :: T.Text -> T.Text -> PositionDelta -deltaFromDiff (T.lines -> old) (T.lines -> new) = - PositionDelta (lookupPos lnew o2nPrevs o2nNexts old2new) (lookupPos lold n2oPrevs n2oNexts new2old) - where - !lnew = length new - !lold = length old - - diff = getDiff old new - - (V.fromList -> !old2new, V.fromList -> !new2old) = go diff 0 0 - - -- Compute previous and next lines that mapped successfully - !o2nPrevs = V.prescanl' f (-1) old2new - !o2nNexts = V.prescanr' (flip f) lnew old2new - - !n2oPrevs = V.prescanl' f (-1) new2old - !n2oNexts = V.prescanr' (flip f) lold new2old - - f :: Int -> Int -> Int - f !a !b = if b == -1 then a else b - - lookupPos :: Int -> V.Vector Int -> V.Vector Int -> V.Vector Int -> Position -> PositionResult Position - lookupPos end prevs nexts xs (Position line col) - | line < 0 = PositionRange (Position 0 0) (Position 0 0) - | line >= V.length xs = PositionRange (Position end 0) (Position end 0) - | otherwise = case V.unsafeIndex xs line of - -1 -> - -- look for the previous and next lines that mapped successfully - let !prev = 1 + V.unsafeIndex prevs line - !next = V.unsafeIndex nexts line - in PositionRange (Position prev 0) (Position next 0) - line' -> PositionExact (Position line' col) - - -- Construct a mapping between lines in the diff - -- -1 for unsucessful mapping - go :: [Diff T.Text] -> Int -> Int -> ([Int], [Int]) - go [] _ _ = ([],[]) - go (Both _ _ : xs) !lold !lnew = bimap (lnew :) (lold :) $ go xs (lold+1) (lnew+1) - go (First _ : xs) !lold !lnew = first (-1 :) $ go xs (lold+1) lnew - go (Second _ : xs) !lold !lnew = second (-1 :) $ go xs lold (lnew+1) +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 +module Development.IDE.Core.PositionMapping + ( PositionMapping(..) + , PositionResult(..) + , lowerRange + , upperRange + , positionResultToMaybe + , fromCurrentPosition + , toCurrentPosition + , PositionDelta(..) + , addDelta + , idDelta + , mkDelta + , toCurrentRange + , fromCurrentRange + , applyChange + , zeroMapping + , deltaFromDiff + -- toCurrent and fromCurrent are mainly exposed for testing + , toCurrent + , fromCurrent + ) where + +import Control.DeepSeq +import Control.Monad +import Data.Algorithm.Diff +import Data.Bifunctor +import Data.List +import qualified Data.Text as T +import qualified Data.Vector.Unboxed as V +import Language.LSP.Types + +-- | Either an exact position, or the range of text that was substituted +data PositionResult a + = PositionRange -- ^ Fields need to be non-strict otherwise bind is exponential + { unsafeLowerRange :: a + , unsafeUpperRange :: a } + | PositionExact !a + deriving (Eq,Ord,Show,Functor) + +lowerRange :: PositionResult a -> a +lowerRange (PositionExact a) = a +lowerRange (PositionRange lower _) = lower + +upperRange :: PositionResult a -> a +upperRange (PositionExact a) = a +upperRange (PositionRange _ upper) = upper + +positionResultToMaybe :: PositionResult a -> Maybe a +positionResultToMaybe (PositionExact a) = Just a +positionResultToMaybe _ = Nothing + +instance Applicative PositionResult where + pure = PositionExact + (PositionExact f) <*> a = fmap f a + (PositionRange f g) <*> (PositionExact a) = PositionRange (f a) (g a) + (PositionRange f g) <*> (PositionRange lower upper) = PositionRange (f lower) (g upper) + +instance Monad PositionResult where + (PositionExact a) >>= f = f a + (PositionRange lower upper) >>= f = PositionRange lower' upper' + where + lower' = lowerRange $ f lower + upper' = upperRange $ f upper + +-- The position delta is the difference between two versions +data PositionDelta = PositionDelta + { toDelta :: !(Position -> PositionResult Position) + , fromDelta :: !(Position -> PositionResult Position) + } + +instance Show PositionDelta where + show PositionDelta{} = "PositionDelta{..}" + +instance NFData PositionDelta where + rnf (PositionDelta a b) = a `seq` b `seq` () + +fromCurrentPosition :: PositionMapping -> Position -> Maybe Position +fromCurrentPosition (PositionMapping pm) = positionResultToMaybe . fromDelta pm + +toCurrentPosition :: PositionMapping -> Position -> Maybe Position +toCurrentPosition (PositionMapping pm) = positionResultToMaybe . toDelta pm + +-- A position mapping is the difference from the current version to +-- a specific version +newtype PositionMapping = PositionMapping PositionDelta + +toCurrentRange :: PositionMapping -> Range -> Maybe Range +toCurrentRange mapping (Range a b) = + Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b + +fromCurrentRange :: PositionMapping -> Range -> Maybe Range +fromCurrentRange mapping (Range a b) = + Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b + +zeroMapping :: PositionMapping +zeroMapping = PositionMapping idDelta + +-- | Compose two position mappings. Composes in the same way as function +-- composition (ie the second argument is applyed to the position first). +composeDelta :: PositionDelta + -> PositionDelta + -> PositionDelta +composeDelta (PositionDelta to1 from1) (PositionDelta to2 from2) = + PositionDelta (to1 <=< to2) + (from1 >=> from2) + +idDelta :: PositionDelta +idDelta = PositionDelta pure pure + +-- | Convert a set of changes into a delta from k to k + 1 +mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta +mkDelta cs = foldl' applyChange idDelta cs + +-- | Add a new delta onto a Mapping k n to make a Mapping (k - 1) n +addDelta :: PositionDelta -> PositionMapping -> PositionMapping +addDelta delta (PositionMapping pm) = PositionMapping (composeDelta delta pm) + +applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta +applyChange PositionDelta{..} (TextDocumentContentChangeEvent (Just r) _ t) = PositionDelta + { toDelta = toCurrent r t <=< toDelta + , fromDelta = fromDelta <=< fromCurrent r t + } +applyChange posMapping _ = posMapping + +toCurrent :: Range -> T.Text -> Position -> PositionResult Position +toCurrent (Range start@(Position startLine startColumn) end@(Position endLine endColumn)) t (Position line column) + | line < startLine || line == startLine && column < startColumn = + -- Position is before the change and thereby unchanged. + PositionExact $ Position line column + | line > endLine || line == endLine && column >= endColumn = + -- Position is after the change so increase line and column number + -- as necessary. + PositionExact $ newLine `seq` newColumn `seq` Position newLine newColumn + | otherwise = PositionRange start end + -- Position is in the region that was changed. + where + lineDiff = linesNew - linesOld + linesNew = T.count "\n" t + linesOld = endLine - startLine + newEndColumn + | linesNew == 0 = startColumn + T.length t + | otherwise = T.length $ T.takeWhileEnd (/= '\n') t + newColumn + | line == endLine = column + newEndColumn - endColumn + | otherwise = column + newLine = line + lineDiff + +fromCurrent :: Range -> T.Text -> Position -> PositionResult Position +fromCurrent (Range start@(Position startLine startColumn) end@(Position endLine endColumn)) t (Position line column) + | line < startLine || line == startLine && column < startColumn = + -- Position is before the change and thereby unchanged + PositionExact $ Position line column + | line > newEndLine || line == newEndLine && column >= newEndColumn = + -- Position is after the change so increase line and column number + -- as necessary. + PositionExact $ newLine `seq` newColumn `seq` Position newLine newColumn + | otherwise = PositionRange start end + -- Position is in the region that was changed. + where + lineDiff = linesNew - linesOld + linesNew = T.count "\n" t + linesOld = endLine - startLine + newEndLine = endLine + lineDiff + newEndColumn + | linesNew == 0 = startColumn + T.length t + | otherwise = T.length $ T.takeWhileEnd (/= '\n') t + newColumn + | line == newEndLine = column - (newEndColumn - endColumn) + | otherwise = column + newLine = line - lineDiff + +deltaFromDiff :: T.Text -> T.Text -> PositionDelta +deltaFromDiff (T.lines -> old) (T.lines -> new) = + PositionDelta (lookupPos lnew o2nPrevs o2nNexts old2new) (lookupPos lold n2oPrevs n2oNexts new2old) + where + !lnew = length new + !lold = length old + + diff = getDiff old new + + (V.fromList -> !old2new, V.fromList -> !new2old) = go diff 0 0 + + -- Compute previous and next lines that mapped successfully + !o2nPrevs = V.prescanl' f (-1) old2new + !o2nNexts = V.prescanr' (flip f) lnew old2new + + !n2oPrevs = V.prescanl' f (-1) new2old + !n2oNexts = V.prescanr' (flip f) lold new2old + + f :: Int -> Int -> Int + f !a !b = if b == -1 then a else b + + lookupPos :: Int -> V.Vector Int -> V.Vector Int -> V.Vector Int -> Position -> PositionResult Position + lookupPos end prevs nexts xs (Position line col) + | line < 0 = PositionRange (Position 0 0) (Position 0 0) + | line >= V.length xs = PositionRange (Position end 0) (Position end 0) + | otherwise = case V.unsafeIndex xs line of + -1 -> + -- look for the previous and next lines that mapped successfully + let !prev = 1 + V.unsafeIndex prevs line + !next = V.unsafeIndex nexts line + in PositionRange (Position prev 0) (Position next 0) + line' -> PositionExact (Position line' col) + + -- Construct a mapping between lines in the diff + -- -1 for unsucessful mapping + go :: [Diff T.Text] -> Int -> Int -> ([Int], [Int]) + go [] _ _ = ([],[]) + go (Both _ _ : xs) !lold !lnew = bimap (lnew :) (lold :) $ go xs (lold+1) (lnew+1) + go (First _ : xs) !lold !lnew = first (-1 :) $ go xs (lold+1) lnew + go (Second _ : xs) !lold !lnew = second (-1 :) $ go xs lold (lnew+1) diff --git a/src/Development/IDE/Core/Preprocessor.hs b/src/Development/IDE/Core/Preprocessor.hs --- a/src/Development/IDE/Core/Preprocessor.hs +++ b/src/Development/IDE/Core/Preprocessor.hs @@ -1,227 +1,229 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -module Development.IDE.Core.Preprocessor - ( preprocessor - ) where - -import Development.IDE.GHC.CPP -import Development.IDE.GHC.Orphans() -import Development.IDE.GHC.Compat -import GhcMonad -import StringBuffer as SB - -import Data.List.Extra -import System.FilePath -import System.IO.Extra -import Data.Char -import qualified HeaderInfo as Hdr -import Development.IDE.Types.Diagnostics -import Development.IDE.Types.Location -import Development.IDE.GHC.Error -import SysTools (Option (..), runUnlit, runPp) -import Control.Monad.Trans.Except -import qualified GHC.LanguageExtensions as LangExt -import Data.Maybe -import Control.Exception.Safe (catch, throw) -import Data.IORef (IORef, modifyIORef, newIORef, readIORef) -import Data.Text (Text) -import qualified Data.Text as T -import Outputable (showSDoc) -import Control.DeepSeq (NFData(rnf)) -import Control.Exception (evaluate) -import HscTypes (HscEnv(hsc_dflags)) - - --- | Given a file and some contents, apply any necessary preprocessors, --- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies. -preprocessor :: HscEnv -> FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] IO (StringBuffer, DynFlags) -preprocessor env filename mbContents = do - -- Perform unlit - (isOnDisk, contents) <- - if isLiterate filename then do - let dflags = hsc_dflags env - newcontent <- liftIO $ runLhs dflags filename mbContents - return (False, newcontent) - else do - contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents - let isOnDisk = isNothing mbContents - return (isOnDisk, contents) - - -- Perform cpp - dflags <- ExceptT $ parsePragmasIntoDynFlags env filename contents - (isOnDisk, contents, dflags) <- - if not $ xopt LangExt.Cpp dflags then - return (isOnDisk, contents, dflags) - else do - cppLogs <- liftIO $ newIORef [] - contents <- ExceptT - $ (Right <$> (runCpp dflags {log_action = logAction cppLogs} filename - $ if isOnDisk then Nothing else Just contents)) - `catch` - ( \(e :: GhcException) -> do - logs <- readIORef cppLogs - case diagsFromCPPLogs filename (reverse logs) of - [] -> throw e - diags -> return $ Left diags - ) - dflags <- ExceptT $ parsePragmasIntoDynFlags env filename contents - return (False, contents, dflags) - - -- Perform preprocessor - if not $ gopt Opt_Pp dflags then - return (contents, dflags) - else do - contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents - dflags <- ExceptT $ parsePragmasIntoDynFlags env filename contents - return (contents, dflags) - where - logAction :: IORef [CPPLog] -> LogAction - logAction cppLogs dflags _reason severity srcSpan _style msg = do - let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg - modifyIORef cppLogs (log :) - - -data CPPLog = CPPLog Severity SrcSpan Text - deriving (Show) - - -data CPPDiag - = CPPDiag - { cdRange :: Range, - cdSeverity :: Maybe DiagnosticSeverity, - cdMessage :: [Text] - } - deriving (Show) - - -diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic] -diagsFromCPPLogs filename logs = - map (\d -> (toNormalizedFilePath' filename, ShowDiag, cppDiagToDiagnostic d)) $ - go [] logs - where - -- On errors, CPP calls logAction with a real span for the initial log and - -- then additional informational logs with `UnhelpfulSpan`. Collect those - -- informational log messages and attaches them to the initial log message. - go :: [CPPDiag] -> [CPPLog] -> [CPPDiag] - go acc [] = reverse $ map (\d -> d {cdMessage = reverse $ cdMessage d}) acc - go acc (CPPLog sev (RealSrcSpan span) msg : logs) = - let diag = CPPDiag (realSrcSpanToRange span) (toDSeverity sev) [msg] - in go (diag : acc) logs - go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) = - go (diag {cdMessage = msg : cdMessage diag} : diags) logs - go [] (CPPLog _sev (UnhelpfulSpan _) _msg : logs) = go [] logs - cppDiagToDiagnostic :: CPPDiag -> Diagnostic - cppDiagToDiagnostic d = - Diagnostic - { _range = cdRange d, - _severity = cdSeverity d, - _code = Nothing, - _source = Just "CPP", - _message = T.unlines $ cdMessage d, - _relatedInformation = Nothing, - _tags = Nothing - } - - -isLiterate :: FilePath -> Bool -isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"] - - --- | This reads the pragma information directly from the provided buffer. -parsePragmasIntoDynFlags - :: HscEnv - -> FilePath - -> SB.StringBuffer - -> IO (Either [FileDiagnostic] DynFlags) -parsePragmasIntoDynFlags env fp contents = catchSrcErrors dflags0 "pragmas" $ do - let opts = Hdr.getOptions dflags0 contents fp - - -- Force bits that might keep the dflags and stringBuffer alive unnecessarily - evaluate $ rnf opts - - (dflags, _, _) <- parseDynamicFilePragma dflags0 opts - dflags' <- initializePlugins env dflags - return $ disableWarningsAsErrors dflags' - where dflags0 = hsc_dflags env - --- | Run (unlit) literate haskell preprocessor on a file, or buffer if set -runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer -runLhs dflags filename contents = withTempDir $ \dir -> do - let fout = dir takeFileName filename <.> "unlit" - filesrc <- case contents of - Nothing -> return filename - Just cnts -> do - let fsrc = dir takeFileName filename <.> "literate" - withBinaryFile fsrc WriteMode $ \h -> - hPutStringBuffer h cnts - return fsrc - unlit filesrc fout - SB.hGetStringBuffer fout - where - unlit filein fileout = SysTools.runUnlit dflags (args filein fileout) - args filein fileout = [ - SysTools.Option "-h" - , SysTools.Option (escape filename) -- name this file - , SysTools.FileOption "" filein -- input file - , SysTools.FileOption "" fileout ] -- output file - -- taken from ghc's DriverPipeline.hs - escape ('\\':cs) = '\\':'\\': escape cs - escape ('\"':cs) = '\\':'\"': escape cs - escape ('\'':cs) = '\\':'\'': escape cs - escape (c:cs) = c : escape cs - escape [] = [] - --- | Run CPP on a file -runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer -runCpp dflags filename contents = withTempDir $ \dir -> do - let out = dir takeFileName filename <.> "out" - dflags <- pure $ addOptP "-D__GHCIDE__" dflags - - case contents of - Nothing -> do - -- Happy case, file is not modified, so run CPP on it in-place - -- which also makes things like relative #include files work - -- and means location information is correct - doCpp dflags True filename out - liftIO $ SB.hGetStringBuffer out - - Just contents -> do - -- Sad path, we have to create a version of the path in a temp dir - -- __FILE__ macro is wrong, ignoring that for now (likely not a real issue) - - -- Relative includes aren't going to work, so we fix that by adding to the include path. - dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags - - -- Location information is wrong, so we fix that by patching it afterwards. - let inp = dir "___GHCIDE_MAGIC___" - withBinaryFile inp WriteMode $ \h -> - hPutStringBuffer h contents - doCpp dflags True inp out - - -- Fix up the filename in lines like: - -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___" - let tweak x - | Just x <- stripPrefix "# " x - , "___GHCIDE_MAGIC___" `isInfixOf` x - , let num = takeWhile (not . isSpace) x - -- important to use /, and never \ for paths, even on Windows, since then C escapes them - -- and GHC gets all confused - = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\"" - | otherwise = x - stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out - - --- | Run a preprocessor on a file -runPreprocessor :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer -runPreprocessor dflags filename contents = withTempDir $ \dir -> do - let out = dir takeFileName filename <.> "out" - inp <- case contents of - Nothing -> return filename - Just contents -> do - let inp = dir takeFileName filename <.> "hs" - withBinaryFile inp WriteMode $ \h -> - hPutStringBuffer h contents - return inp - runPp dflags [SysTools.Option filename, SysTools.Option inp, SysTools.FileOption "" out] - SB.hGetStringBuffer out +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Development.IDE.Core.Preprocessor + ( preprocessor + ) where + +import Development.IDE.GHC.CPP +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Orphans () +import GhcMonad +import StringBuffer as SB + +import Control.DeepSeq (NFData (rnf)) +import Control.Exception (evaluate) +import Control.Exception.Safe (catch, throw) +import Control.Monad.Trans.Except +import Data.Char +import Data.IORef (IORef, modifyIORef, + newIORef, readIORef) +import Data.List.Extra +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE.GHC.Error +import Development.IDE.Types.Diagnostics +import Development.IDE.Types.Location +import qualified GHC.LanguageExtensions as LangExt +import qualified HeaderInfo as Hdr +import HscTypes (HscEnv (hsc_dflags)) +import Outputable (showSDoc) +import SysTools (Option (..), runPp, + runUnlit) +import System.FilePath +import System.IO.Extra + + +-- | Given a file and some contents, apply any necessary preprocessors, +-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies. +preprocessor :: HscEnv -> FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] IO (StringBuffer, [String], DynFlags) +preprocessor env filename mbContents = do + -- Perform unlit + (isOnDisk, contents) <- + if isLiterate filename then do + let dflags = hsc_dflags env + newcontent <- liftIO $ runLhs dflags filename mbContents + return (False, newcontent) + else do + contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents + let isOnDisk = isNothing mbContents + return (isOnDisk, contents) + + -- Perform cpp + (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents + (isOnDisk, contents, opts, dflags) <- + if not $ xopt LangExt.Cpp dflags then + return (isOnDisk, contents, opts, dflags) + else do + cppLogs <- liftIO $ newIORef [] + contents <- ExceptT + $ (Right <$> (runCpp dflags {log_action = logAction cppLogs} filename + $ if isOnDisk then Nothing else Just contents)) + `catch` + ( \(e :: GhcException) -> do + logs <- readIORef cppLogs + case diagsFromCPPLogs filename (reverse logs) of + [] -> throw e + diags -> return $ Left diags + ) + (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents + return (False, contents, opts, dflags) + + -- Perform preprocessor + if not $ gopt Opt_Pp dflags then + return (contents, opts, dflags) + else do + contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents + (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents + return (contents, opts, dflags) + where + logAction :: IORef [CPPLog] -> LogAction + logAction cppLogs dflags _reason severity srcSpan _style msg = do + let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg + modifyIORef cppLogs (log :) + + +data CPPLog = CPPLog Severity SrcSpan Text + deriving (Show) + + +data CPPDiag + = CPPDiag + { cdRange :: Range, + cdSeverity :: Maybe DiagnosticSeverity, + cdMessage :: [Text] + } + deriving (Show) + + +diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic] +diagsFromCPPLogs filename logs = + map (\d -> (toNormalizedFilePath' filename, ShowDiag, cppDiagToDiagnostic d)) $ + go [] logs + where + -- On errors, CPP calls logAction with a real span for the initial log and + -- then additional informational logs with `UnhelpfulSpan`. Collect those + -- informational log messages and attaches them to the initial log message. + go :: [CPPDiag] -> [CPPLog] -> [CPPDiag] + go acc [] = reverse $ map (\d -> d {cdMessage = reverse $ cdMessage d}) acc + go acc (CPPLog sev (RealSrcSpan span) msg : logs) = + let diag = CPPDiag (realSrcSpanToRange span) (toDSeverity sev) [msg] + in go (diag : acc) logs + go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) = + go (diag {cdMessage = msg : cdMessage diag} : diags) logs + go [] (CPPLog _sev (UnhelpfulSpan _) _msg : logs) = go [] logs + cppDiagToDiagnostic :: CPPDiag -> Diagnostic + cppDiagToDiagnostic d = + Diagnostic + { _range = cdRange d, + _severity = cdSeverity d, + _code = Nothing, + _source = Just "CPP", + _message = T.unlines $ cdMessage d, + _relatedInformation = Nothing, + _tags = Nothing + } + + +isLiterate :: FilePath -> Bool +isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"] + + +-- | This reads the pragma information directly from the provided buffer. +parsePragmasIntoDynFlags + :: HscEnv + -> FilePath + -> SB.StringBuffer + -> IO (Either [FileDiagnostic] ([String], DynFlags)) +parsePragmasIntoDynFlags env fp contents = catchSrcErrors dflags0 "pragmas" $ do + let opts = Hdr.getOptions dflags0 contents fp + + -- Force bits that might keep the dflags and stringBuffer alive unnecessarily + evaluate $ rnf opts + + (dflags, _, _) <- parseDynamicFilePragma dflags0 opts + dflags' <- initializePlugins env dflags + return (map unLoc opts, disableWarningsAsErrors dflags') + where dflags0 = hsc_dflags env + +-- | Run (unlit) literate haskell preprocessor on a file, or buffer if set +runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer +runLhs dflags filename contents = withTempDir $ \dir -> do + let fout = dir takeFileName filename <.> "unlit" + filesrc <- case contents of + Nothing -> return filename + Just cnts -> do + let fsrc = dir takeFileName filename <.> "literate" + withBinaryFile fsrc WriteMode $ \h -> + hPutStringBuffer h cnts + return fsrc + unlit filesrc fout + SB.hGetStringBuffer fout + where + unlit filein fileout = SysTools.runUnlit dflags (args filein fileout) + args filein fileout = [ + SysTools.Option "-h" + , SysTools.Option (escape filename) -- name this file + , SysTools.FileOption "" filein -- input file + , SysTools.FileOption "" fileout ] -- output file + -- taken from ghc's DriverPipeline.hs + escape ('\\':cs) = '\\':'\\': escape cs + escape ('\"':cs) = '\\':'\"': escape cs + escape ('\'':cs) = '\\':'\'': escape cs + escape (c:cs) = c : escape cs + escape [] = [] + +-- | Run CPP on a file +runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer +runCpp dflags filename contents = withTempDir $ \dir -> do + let out = dir takeFileName filename <.> "out" + dflags <- pure $ addOptP "-D__GHCIDE__" dflags + + case contents of + Nothing -> do + -- Happy case, file is not modified, so run CPP on it in-place + -- which also makes things like relative #include files work + -- and means location information is correct + doCpp dflags True filename out + liftIO $ SB.hGetStringBuffer out + + Just contents -> do + -- Sad path, we have to create a version of the path in a temp dir + -- __FILE__ macro is wrong, ignoring that for now (likely not a real issue) + + -- Relative includes aren't going to work, so we fix that by adding to the include path. + dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags + + -- Location information is wrong, so we fix that by patching it afterwards. + let inp = dir "___GHCIDE_MAGIC___" + withBinaryFile inp WriteMode $ \h -> + hPutStringBuffer h contents + doCpp dflags True inp out + + -- Fix up the filename in lines like: + -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___" + let tweak x + | Just x <- stripPrefix "# " x + , "___GHCIDE_MAGIC___" `isInfixOf` x + , let num = takeWhile (not . isSpace) x + -- important to use /, and never \ for paths, even on Windows, since then C escapes them + -- and GHC gets all confused + = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\"" + | otherwise = x + stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out + + +-- | Run a preprocessor on a file +runPreprocessor :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer +runPreprocessor dflags filename contents = withTempDir $ \dir -> do + let out = dir takeFileName filename <.> "out" + inp <- case contents of + Nothing -> return filename + Just contents -> do + let inp = dir takeFileName filename <.> "hs" + withBinaryFile inp WriteMode $ \h -> + hPutStringBuffer h contents + return inp + runPp dflags [SysTools.Option filename, SysTools.Option inp, SysTools.FileOption "" out] + SB.hGetStringBuffer out diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -1,472 +1,517 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} - --- | A Shake implementation of the compiler service, built --- using the "Shaker" abstraction layer for in-memory use. --- -module Development.IDE.Core.RuleTypes( - module Development.IDE.Core.RuleTypes - ) where - -import Control.DeepSeq -import Control.Lens -import Data.Aeson.Types (Value) -import Data.Binary -import Development.IDE.Import.DependencyInformation -import Development.IDE.GHC.Compat hiding (HieFileResult) -import Development.IDE.GHC.Util -import Development.IDE.Types.HscEnvEq (HscEnvEq) -import Development.IDE.Types.KnownTargets -import Data.Hashable -import Data.Typeable -import qualified Data.Map as M -import Development.Shake -import GHC.Generics (Generic) - -import HscTypes (ModGuts, hm_iface, HomeModInfo, hm_linkable) - -import Development.IDE.Spans.Common -import Development.IDE.Spans.LocalBindings -import Development.IDE.Import.FindImports (ArtifactsLocation) -import Data.ByteString (ByteString) -import Language.LSP.Types (NormalizedFilePath) -import TcRnMonad (TcGblEnv) -import qualified Data.ByteString.Char8 as BS -import Development.IDE.Types.Options (IdeGhcSession) -import Data.Text (Text) -import Data.Int (Int64) -import GHC.Serialized (Serialized) - -data LinkableType = ObjectLinkable | BCOLinkable - deriving (Eq,Ord,Show, Generic) -instance Hashable LinkableType -instance NFData LinkableType - --- NOTATION --- Foo+ means Foo for the dependencies --- Foo* means Foo for me and Foo+ - --- | The parse tree for the file using GetFileContents -type instance RuleResult GetParsedModule = ParsedModule - --- | The parse tree for the file using GetFileContents, --- all comments included using Opt_KeepRawTokenStream -type instance RuleResult GetParsedModuleWithComments = ParsedModule - --- | The dependency information produced by following the imports recursively. --- This rule will succeed even if there is an error, e.g., a module could not be located, --- a module could not be parsed or an import cycle. -type instance RuleResult GetDependencyInformation = DependencyInformation - --- | Transitive module and pkg dependencies based on the information produced by GetDependencyInformation. --- This rule is also responsible for calling ReportImportCycles for each file in the transitive closure. -type instance RuleResult GetDependencies = TransitiveDependencies - -type instance RuleResult GetModuleGraph = DependencyInformation - -data GetKnownTargets = GetKnownTargets - deriving (Show, Generic, Eq, Ord) -instance Hashable GetKnownTargets -instance NFData GetKnownTargets -instance Binary GetKnownTargets -type instance RuleResult GetKnownTargets = KnownTargets - --- | Convert to Core, requires TypeCheck* -type instance RuleResult GenerateCore = ModGuts - -data GenerateCore = GenerateCore - deriving (Eq, Show, Typeable, Generic) -instance Hashable GenerateCore -instance NFData GenerateCore -instance Binary GenerateCore - -data GetImportMap = GetImportMap - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetImportMap -instance NFData GetImportMap -instance Binary GetImportMap - -type instance RuleResult GetImportMap = ImportMap -newtype ImportMap = ImportMap - { importMap :: M.Map ModuleName NormalizedFilePath -- ^ Where are the modules imported by this file located? - } deriving stock Show - deriving newtype NFData - -data Splices = Splices - { exprSplices :: [(LHsExpr GhcTc, LHsExpr GhcPs)] - , patSplices :: [(LHsExpr GhcTc, LPat GhcPs)] - , typeSplices :: [(LHsExpr GhcTc, LHsType GhcPs)] - , declSplices :: [(LHsExpr GhcTc, [LHsDecl GhcPs])] - , awSplices :: [(LHsExpr GhcTc, Serialized)] - } - -instance Semigroup Splices where - Splices e p t d aw <> Splices e' p' t' d' aw' = - Splices - (e <> e') - (p <> p') - (t <> t') - (d <> d') - (aw <> aw') - -instance Monoid Splices where - mempty = Splices mempty mempty mempty mempty mempty - -instance NFData Splices where - rnf Splices {..} = - liftRnf rwhnf exprSplices `seq` - liftRnf rwhnf patSplices `seq` - liftRnf rwhnf typeSplices `seq` liftRnf rwhnf declSplices `seq` () - --- | Contains the typechecked module and the OrigNameCache entry for --- that module. -data TcModuleResult = TcModuleResult - { tmrParsed :: ParsedModule - , tmrRenamed :: RenamedSource - , tmrTypechecked :: TcGblEnv - , tmrTopLevelSplices :: Splices - -- ^ Typechecked splice information - , tmrDeferedError :: !Bool - -- ^ Did we defer any type errors for this module? - } -instance Show TcModuleResult where - show = show . pm_mod_summary . tmrParsed - -instance NFData TcModuleResult where - rnf = rwhnf - -tmrModSummary :: TcModuleResult -> ModSummary -tmrModSummary = pm_mod_summary . tmrParsed - -data HiFileResult = HiFileResult - { hirModSummary :: !ModSummary - -- Bang patterns here are important to stop the result retaining - -- a reference to a typechecked module - , hirHomeMod :: !HomeModInfo - -- ^ Includes the Linkable iff we need object files - } - -hiFileFingerPrint :: HiFileResult -> ByteString -hiFileFingerPrint hfr = ifaceBS <> linkableBS - where - ifaceBS = fingerprintToBS . getModuleHash . hirModIface $ hfr -- will always be two bytes - linkableBS = case hm_linkable $ hirHomeMod hfr of - Nothing -> "" - Just l -> BS.pack $ show $ linkableTime l - -hirModIface :: HiFileResult -> ModIface -hirModIface = hm_iface . hirHomeMod - -instance NFData HiFileResult where - rnf = rwhnf - -instance Show HiFileResult where - show = show . hirModSummary - --- | Save the uncompressed AST here, we compress it just before writing to disk -data HieAstResult - = forall a. HAR - { hieModule :: Module - , hieAst :: !(HieASTs a) - , refMap :: RefMap a - -- ^ Lazy because its value only depends on the hieAst, which is bundled in this type - -- Lazyness can't cause leaks here because the lifetime of `refMap` will be the same - -- as that of `hieAst` - , typeRefs :: M.Map Name [RealSrcSpan] - -- ^ type references in this file - , hieKind :: !(HieKind a) - -- ^ Is this hie file loaded from the disk, or freshly computed? - } - -data HieKind a where - HieFromDisk :: !HieFile -> HieKind TypeIndex - HieFresh :: HieKind Type - -instance NFData (HieKind a) where - rnf (HieFromDisk hf) = rnf hf - rnf HieFresh = () - -instance NFData HieAstResult where - rnf (HAR m hf _rm _tr kind) = rnf m `seq` rwhnf hf `seq` rnf kind - -instance Show HieAstResult where - show = show . hieModule - --- | The type checked version of this file, requires TypeCheck+ -type instance RuleResult TypeCheck = TcModuleResult - --- | The uncompressed HieAST -type instance RuleResult GetHieAst = HieAstResult - --- | A IntervalMap telling us what is in scope at each point -type instance RuleResult GetBindings = Bindings - -data DocAndKindMap = DKMap {getDocMap :: !DocMap, getKindMap :: !KindMap} -instance NFData DocAndKindMap where - rnf (DKMap a b) = rwhnf a `seq` rwhnf b - -instance Show DocAndKindMap where - show = const "docmap" - -type instance RuleResult GetDocMap = DocAndKindMap - --- | A GHC session that we reuse. -type instance RuleResult GhcSession = HscEnvEq - --- | A GHC session preloaded with all the dependencies -type instance RuleResult GhcSessionDeps = HscEnvEq - --- | Resolve the imports in a module to the file path of a module in the same package -type instance RuleResult GetLocatedImports = [(Located ModuleName, Maybe ArtifactsLocation)] - --- | This rule is used to report import cycles. It depends on GetDependencyInformation. --- We cannot report the cycles directly from GetDependencyInformation since --- we can only report diagnostics for the current file. -type instance RuleResult ReportImportCycles = () - --- | Read the module interface file from disk. Throws an error for VFS files. --- This is an internal rule, use 'GetModIface' instead. -type instance RuleResult GetModIfaceFromDisk = HiFileResult - --- | GetModIfaceFromDisk and index the `.hie` file into the database. --- This is an internal rule, use 'GetModIface' instead. -type instance RuleResult GetModIfaceFromDiskAndIndex = HiFileResult - --- | Get a module interface details, either from an interface file or a typechecked module -type instance RuleResult GetModIface = HiFileResult - --- | Get a module interface details, without the Linkable --- For better early cuttoff -type instance RuleResult GetModIfaceWithoutLinkable = HiFileResult - --- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk. -type instance RuleResult GetFileContents = (FileVersion, Maybe Text) - --- The Shake key type for getModificationTime queries -data GetModificationTime = GetModificationTime_ - { missingFileDiagnostics :: Bool - -- ^ If false, missing file diagnostics are not reported - } - deriving (Show, Generic) - -instance Eq GetModificationTime where - -- Since the diagnostics are not part of the answer, the query identity is - -- independent from the 'missingFileDiagnostics' field - _ == _ = True - -instance Hashable GetModificationTime where - -- Since the diagnostics are not part of the answer, the query identity is - -- independent from the 'missingFileDiagnostics' field - hashWithSalt salt _ = salt - -instance NFData GetModificationTime -instance Binary GetModificationTime - -pattern GetModificationTime :: GetModificationTime -pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True} - --- | Get the modification time of a file. -type instance RuleResult GetModificationTime = FileVersion - -data FileVersion - = VFSVersion !Int - | ModificationTime - !Int64 -- ^ Large unit (platform dependent, do not make assumptions) - !Int64 -- ^ Small unit (platform dependent, do not make assumptions) - deriving (Show, Generic) - -instance NFData FileVersion - -vfsVersion :: FileVersion -> Maybe Int -vfsVersion (VFSVersion i) = Just i -vfsVersion ModificationTime{} = Nothing - -data GetFileContents = GetFileContents - deriving (Eq, Show, Generic) -instance Hashable GetFileContents -instance NFData GetFileContents -instance Binary GetFileContents - - -data FileOfInterestStatus - = OnDisk - | Modified { firstOpen :: !Bool -- ^ was this file just opened - } - deriving (Eq, Show, Typeable, Generic) -instance Hashable FileOfInterestStatus -instance NFData FileOfInterestStatus -instance Binary FileOfInterestStatus - -data IsFileOfInterestResult = NotFOI | IsFOI FileOfInterestStatus - deriving (Eq, Show, Typeable, Generic) -instance Hashable IsFileOfInterestResult -instance NFData IsFileOfInterestResult -instance Binary IsFileOfInterestResult - -type instance RuleResult IsFileOfInterest = IsFileOfInterestResult - --- | Generate a ModSummary that has enough information to be used to get .hi and .hie files. --- without needing to parse the entire source -type instance RuleResult GetModSummary = (ModSummary,[LImportDecl GhcPs]) - --- | Generate a ModSummary with the timestamps elided, --- for more successful early cutoff -type instance RuleResult GetModSummaryWithoutTimestamps = (ModSummary,[LImportDecl GhcPs]) - -data GetParsedModule = GetParsedModule - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetParsedModule -instance NFData GetParsedModule -instance Binary GetParsedModule - -data GetParsedModuleWithComments = GetParsedModuleWithComments - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetParsedModuleWithComments -instance NFData GetParsedModuleWithComments -instance Binary GetParsedModuleWithComments - -data GetLocatedImports = GetLocatedImports - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetLocatedImports -instance NFData GetLocatedImports -instance Binary GetLocatedImports - --- | Does this module need to be compiled? -type instance RuleResult NeedsCompilation = Maybe LinkableType - -data NeedsCompilation = NeedsCompilation - deriving (Eq, Show, Typeable, Generic) -instance Hashable NeedsCompilation -instance NFData NeedsCompilation -instance Binary NeedsCompilation - -data GetDependencyInformation = GetDependencyInformation - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetDependencyInformation -instance NFData GetDependencyInformation -instance Binary GetDependencyInformation - -data GetModuleGraph = GetModuleGraph - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetModuleGraph -instance NFData GetModuleGraph -instance Binary GetModuleGraph - -data ReportImportCycles = ReportImportCycles - deriving (Eq, Show, Typeable, Generic) -instance Hashable ReportImportCycles -instance NFData ReportImportCycles -instance Binary ReportImportCycles - -data GetDependencies = GetDependencies - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetDependencies -instance NFData GetDependencies -instance Binary GetDependencies - -data TypeCheck = TypeCheck - deriving (Eq, Show, Typeable, Generic) -instance Hashable TypeCheck -instance NFData TypeCheck -instance Binary TypeCheck - -data GetDocMap = GetDocMap - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetDocMap -instance NFData GetDocMap -instance Binary GetDocMap - -data GetHieAst = GetHieAst - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetHieAst -instance NFData GetHieAst -instance Binary GetHieAst - -data GetBindings = GetBindings - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetBindings -instance NFData GetBindings -instance Binary GetBindings - -data GhcSession = GhcSession - deriving (Eq, Show, Typeable, Generic) -instance Hashable GhcSession -instance NFData GhcSession -instance Binary GhcSession - -data GhcSessionDeps = GhcSessionDeps deriving (Eq, Show, Typeable, Generic) -instance Hashable GhcSessionDeps -instance NFData GhcSessionDeps -instance Binary GhcSessionDeps - -data GetModIfaceFromDisk = GetModIfaceFromDisk - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetModIfaceFromDisk -instance NFData GetModIfaceFromDisk -instance Binary GetModIfaceFromDisk - -data GetModIfaceFromDiskAndIndex = GetModIfaceFromDiskAndIndex - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetModIfaceFromDiskAndIndex -instance NFData GetModIfaceFromDiskAndIndex -instance Binary GetModIfaceFromDiskAndIndex - -data GetModIface = GetModIface - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetModIface -instance NFData GetModIface -instance Binary GetModIface - -data GetModIfaceWithoutLinkable = GetModIfaceWithoutLinkable - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetModIfaceWithoutLinkable -instance NFData GetModIfaceWithoutLinkable -instance Binary GetModIfaceWithoutLinkable - -data IsFileOfInterest = IsFileOfInterest - deriving (Eq, Show, Typeable, Generic) -instance Hashable IsFileOfInterest -instance NFData IsFileOfInterest -instance Binary IsFileOfInterest - -data GetModSummaryWithoutTimestamps = GetModSummaryWithoutTimestamps - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetModSummaryWithoutTimestamps -instance NFData GetModSummaryWithoutTimestamps -instance Binary GetModSummaryWithoutTimestamps - -data GetModSummary = GetModSummary - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetModSummary -instance NFData GetModSummary -instance Binary GetModSummary - --- | Get the vscode client settings stored in the ide state -data GetClientSettings = GetClientSettings - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetClientSettings -instance NFData GetClientSettings -instance Binary GetClientSettings - -type instance RuleResult GetClientSettings = Hashed (Maybe Value) - --- A local rule type to get caching. We want to use newCache, but it has --- thread killed exception issues, so we lift it to a full rule. --- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547 -type instance RuleResult GhcSessionIO = IdeGhcSession - -data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic) -instance Hashable GhcSessionIO -instance NFData GhcSessionIO -instance Binary GhcSessionIO - -makeLensesWith - (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) - ''Splices +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +-- | A Shake implementation of the compiler service, built +-- using the "Shaker" abstraction layer for in-memory use. +-- +module Development.IDE.Core.RuleTypes( + module Development.IDE.Core.RuleTypes + ) where + +import Control.DeepSeq +import Control.Lens +import Data.Aeson.Types (Value) +import Data.Binary +import Data.Hashable +import qualified Data.Map as M +import Data.Typeable +import Development.IDE.GHC.Compat hiding + (HieFileResult) +import Development.IDE.GHC.Util +import Development.IDE.Import.DependencyInformation +import Development.IDE.Types.HscEnvEq (HscEnvEq) +import Development.IDE.Types.KnownTargets +import Development.Shake +import GHC.Generics (Generic) + +import HscTypes (HomeModInfo, + ModGuts, + hm_iface, + hm_linkable) + +import qualified Data.Binary as B +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LBS +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time +import Development.IDE.Import.FindImports (ArtifactsLocation) +import Development.IDE.Spans.Common +import Development.IDE.Spans.LocalBindings +import Development.IDE.Types.Diagnostics +import Fingerprint +import GHC.Serialized (Serialized) +import Language.LSP.Types (NormalizedFilePath) +import TcRnMonad (TcGblEnv) + +data LinkableType = ObjectLinkable | BCOLinkable + deriving (Eq,Ord,Show, Generic) +instance Hashable LinkableType +instance NFData LinkableType + +-- NOTATION +-- Foo+ means Foo for the dependencies +-- Foo* means Foo for me and Foo+ + +-- | The parse tree for the file using GetFileContents +type instance RuleResult GetParsedModule = ParsedModule + +-- | The parse tree for the file using GetFileContents, +-- all comments included using Opt_KeepRawTokenStream +type instance RuleResult GetParsedModuleWithComments = ParsedModule + +-- | The dependency information produced by following the imports recursively. +-- This rule will succeed even if there is an error, e.g., a module could not be located, +-- a module could not be parsed or an import cycle. +type instance RuleResult GetDependencyInformation = DependencyInformation + +-- | Transitive module and pkg dependencies based on the information produced by GetDependencyInformation. +-- This rule is also responsible for calling ReportImportCycles for each file in the transitive closure. +type instance RuleResult GetDependencies = TransitiveDependencies + +type instance RuleResult GetModuleGraph = DependencyInformation + +data GetKnownTargets = GetKnownTargets + deriving (Show, Generic, Eq, Ord) +instance Hashable GetKnownTargets +instance NFData GetKnownTargets +instance Binary GetKnownTargets +type instance RuleResult GetKnownTargets = KnownTargets + +-- | Convert to Core, requires TypeCheck* +type instance RuleResult GenerateCore = ModGuts + +data GenerateCore = GenerateCore + deriving (Eq, Show, Typeable, Generic) +instance Hashable GenerateCore +instance NFData GenerateCore +instance Binary GenerateCore + +data GetImportMap = GetImportMap + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetImportMap +instance NFData GetImportMap +instance Binary GetImportMap + +type instance RuleResult GetImportMap = ImportMap +newtype ImportMap = ImportMap + { importMap :: M.Map ModuleName NormalizedFilePath -- ^ Where are the modules imported by this file located? + } deriving stock Show + deriving newtype NFData + +data Splices = Splices + { exprSplices :: [(LHsExpr GhcTc, LHsExpr GhcPs)] + , patSplices :: [(LHsExpr GhcTc, LPat GhcPs)] + , typeSplices :: [(LHsExpr GhcTc, LHsType GhcPs)] + , declSplices :: [(LHsExpr GhcTc, [LHsDecl GhcPs])] + , awSplices :: [(LHsExpr GhcTc, Serialized)] + } + +instance Semigroup Splices where + Splices e p t d aw <> Splices e' p' t' d' aw' = + Splices + (e <> e') + (p <> p') + (t <> t') + (d <> d') + (aw <> aw') + +instance Monoid Splices where + mempty = Splices mempty mempty mempty mempty mempty + +instance NFData Splices where + rnf Splices {..} = + liftRnf rwhnf exprSplices `seq` + liftRnf rwhnf patSplices `seq` + liftRnf rwhnf typeSplices `seq` liftRnf rwhnf declSplices `seq` () + +-- | Contains the typechecked module and the OrigNameCache entry for +-- that module. +data TcModuleResult = TcModuleResult + { tmrParsed :: ParsedModule + , tmrRenamed :: RenamedSource + , tmrTypechecked :: TcGblEnv + , tmrTopLevelSplices :: Splices + -- ^ Typechecked splice information + , tmrDeferedError :: !Bool + -- ^ Did we defer any type errors for this module? + } +instance Show TcModuleResult where + show = show . pm_mod_summary . tmrParsed + +instance NFData TcModuleResult where + rnf = rwhnf + +tmrModSummary :: TcModuleResult -> ModSummary +tmrModSummary = pm_mod_summary . tmrParsed + +data HiFileResult = HiFileResult + { hirModSummary :: !ModSummary + -- Bang patterns here are important to stop the result retaining + -- a reference to a typechecked module + , hirHomeMod :: !HomeModInfo + -- ^ Includes the Linkable iff we need object files + , hirIfaceFp :: ByteString + -- ^ Fingerprint for the ModIface + , hirLinkableFp :: ByteString + -- ^ Fingerprint for the Linkable + } + +hiFileFingerPrint :: HiFileResult -> ByteString +hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> hirLinkableFp + +mkHiFileResult :: ModSummary -> HomeModInfo -> HiFileResult +mkHiFileResult hirModSummary hirHomeMod = HiFileResult{..} + where + hirIfaceFp = fingerprintToBS . getModuleHash . hm_iface $ hirHomeMod -- will always be two bytes + hirLinkableFp = case hm_linkable hirHomeMod of + Nothing -> "" + Just (linkableTime -> l) -> LBS.toStrict $ + B.encode (fromEnum $ utctDay l, fromEnum $ utctDayTime l) + +hirModIface :: HiFileResult -> ModIface +hirModIface = hm_iface . hirHomeMod + +instance NFData HiFileResult where + rnf = rwhnf + +instance Show HiFileResult where + show = show . hirModSummary + +-- | Save the uncompressed AST here, we compress it just before writing to disk +data HieAstResult + = forall a. HAR + { hieModule :: Module + , hieAst :: !(HieASTs a) + , refMap :: RefMap a + -- ^ Lazy because its value only depends on the hieAst, which is bundled in this type + -- Lazyness can't cause leaks here because the lifetime of `refMap` will be the same + -- as that of `hieAst` + , typeRefs :: M.Map Name [RealSrcSpan] + -- ^ type references in this file + , hieKind :: !(HieKind a) + -- ^ Is this hie file loaded from the disk, or freshly computed? + } + +data HieKind a where + HieFromDisk :: !HieFile -> HieKind TypeIndex + HieFresh :: HieKind Type + +instance NFData (HieKind a) where + rnf (HieFromDisk hf) = rnf hf + rnf HieFresh = () + +instance NFData HieAstResult where + rnf (HAR m hf _rm _tr kind) = rnf m `seq` rwhnf hf `seq` rnf kind + +instance Show HieAstResult where + show = show . hieModule + +-- | The type checked version of this file, requires TypeCheck+ +type instance RuleResult TypeCheck = TcModuleResult + +-- | The uncompressed HieAST +type instance RuleResult GetHieAst = HieAstResult + +-- | A IntervalMap telling us what is in scope at each point +type instance RuleResult GetBindings = Bindings + +data DocAndKindMap = DKMap {getDocMap :: !DocMap, getKindMap :: !KindMap} +instance NFData DocAndKindMap where + rnf (DKMap a b) = rwhnf a `seq` rwhnf b + +instance Show DocAndKindMap where + show = const "docmap" + +type instance RuleResult GetDocMap = DocAndKindMap + +-- | A GHC session that we reuse. +type instance RuleResult GhcSession = HscEnvEq + +-- | A GHC session preloaded with all the dependencies +type instance RuleResult GhcSessionDeps = HscEnvEq + +-- | Resolve the imports in a module to the file path of a module in the same package +type instance RuleResult GetLocatedImports = [(Located ModuleName, Maybe ArtifactsLocation)] + +-- | This rule is used to report import cycles. It depends on GetDependencyInformation. +-- We cannot report the cycles directly from GetDependencyInformation since +-- we can only report diagnostics for the current file. +type instance RuleResult ReportImportCycles = () + +-- | Read the module interface file from disk. Throws an error for VFS files. +-- This is an internal rule, use 'GetModIface' instead. +type instance RuleResult GetModIfaceFromDisk = HiFileResult + +-- | GetModIfaceFromDisk and index the `.hie` file into the database. +-- This is an internal rule, use 'GetModIface' instead. +type instance RuleResult GetModIfaceFromDiskAndIndex = HiFileResult + +-- | Get a module interface details, either from an interface file or a typechecked module +type instance RuleResult GetModIface = HiFileResult + +-- | Get a module interface details, without the Linkable +-- For better early cuttoff +type instance RuleResult GetModIfaceWithoutLinkable = HiFileResult + +-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk. +type instance RuleResult GetFileContents = (FileVersion, Maybe Text) + +type instance RuleResult GetFileExists = Bool + + +-- The Shake key type for getModificationTime queries +newtype GetModificationTime = GetModificationTime_ + { missingFileDiagnostics :: Bool + -- ^ If false, missing file diagnostics are not reported + } + deriving (Show, Generic) + +instance Eq GetModificationTime where + -- Since the diagnostics are not part of the answer, the query identity is + -- independent from the 'missingFileDiagnostics' field + _ == _ = True + +instance Hashable GetModificationTime where + -- Since the diagnostics are not part of the answer, the query identity is + -- independent from the 'missingFileDiagnostics' field + hashWithSalt salt _ = salt + +instance NFData GetModificationTime +instance Binary GetModificationTime + +pattern GetModificationTime :: GetModificationTime +pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True} + +-- | Get the modification time of a file. +type instance RuleResult GetModificationTime = FileVersion + +data FileVersion + = VFSVersion !Int + | ModificationTime + !Int64 -- ^ Large unit (platform dependent, do not make assumptions) + !Int64 -- ^ Small unit (platform dependent, do not make assumptions) + deriving (Show, Generic) + +instance NFData FileVersion + +vfsVersion :: FileVersion -> Maybe Int +vfsVersion (VFSVersion i) = Just i +vfsVersion ModificationTime{} = Nothing + +data GetFileContents = GetFileContents + deriving (Eq, Show, Generic) +instance Hashable GetFileContents +instance NFData GetFileContents +instance Binary GetFileContents + +data GetFileExists = GetFileExists + deriving (Eq, Show, Typeable, Generic) + +instance NFData GetFileExists +instance Hashable GetFileExists +instance Binary GetFileExists + +data FileOfInterestStatus + = OnDisk + | Modified { firstOpen :: !Bool -- ^ was this file just opened + } + deriving (Eq, Show, Typeable, Generic) +instance Hashable FileOfInterestStatus +instance NFData FileOfInterestStatus +instance Binary FileOfInterestStatus + +data IsFileOfInterestResult = NotFOI | IsFOI FileOfInterestStatus + deriving (Eq, Show, Typeable, Generic) +instance Hashable IsFileOfInterestResult +instance NFData IsFileOfInterestResult +instance Binary IsFileOfInterestResult + +type instance RuleResult IsFileOfInterest = IsFileOfInterestResult + +data ModSummaryResult = ModSummaryResult + { msrModSummary :: !ModSummary + , msrImports :: [LImportDecl GhcPs] + , msrFingerprint :: !Fingerprint + } + +instance Show ModSummaryResult where + show _ = "" +instance NFData ModSummaryResult where + rnf ModSummaryResult{..} = + rnf msrModSummary `seq` rnf msrImports `seq` rnf msrFingerprint + +-- | Generate a ModSummary that has enough information to be used to get .hi and .hie files. +-- without needing to parse the entire source +type instance RuleResult GetModSummary = ModSummaryResult + +-- | Generate a ModSummary with the timestamps and preprocessed content elided, for more successful early cutoff +type instance RuleResult GetModSummaryWithoutTimestamps = ModSummaryResult + +data GetParsedModule = GetParsedModule + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetParsedModule +instance NFData GetParsedModule +instance Binary GetParsedModule + +data GetParsedModuleWithComments = GetParsedModuleWithComments + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetParsedModuleWithComments +instance NFData GetParsedModuleWithComments +instance Binary GetParsedModuleWithComments + +data GetLocatedImports = GetLocatedImports + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetLocatedImports +instance NFData GetLocatedImports +instance Binary GetLocatedImports + +-- | Does this module need to be compiled? +type instance RuleResult NeedsCompilation = Maybe LinkableType + +data NeedsCompilation = NeedsCompilation + deriving (Eq, Show, Typeable, Generic) +instance Hashable NeedsCompilation +instance NFData NeedsCompilation +instance Binary NeedsCompilation + +data GetDependencyInformation = GetDependencyInformation + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetDependencyInformation +instance NFData GetDependencyInformation +instance Binary GetDependencyInformation + +data GetModuleGraph = GetModuleGraph + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetModuleGraph +instance NFData GetModuleGraph +instance Binary GetModuleGraph + +data ReportImportCycles = ReportImportCycles + deriving (Eq, Show, Typeable, Generic) +instance Hashable ReportImportCycles +instance NFData ReportImportCycles +instance Binary ReportImportCycles + +data GetDependencies = GetDependencies + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetDependencies +instance NFData GetDependencies +instance Binary GetDependencies + +data TypeCheck = TypeCheck + deriving (Eq, Show, Typeable, Generic) +instance Hashable TypeCheck +instance NFData TypeCheck +instance Binary TypeCheck + +data GetDocMap = GetDocMap + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetDocMap +instance NFData GetDocMap +instance Binary GetDocMap + +data GetHieAst = GetHieAst + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetHieAst +instance NFData GetHieAst +instance Binary GetHieAst + +data GetBindings = GetBindings + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetBindings +instance NFData GetBindings +instance Binary GetBindings + +data GhcSession = GhcSession + deriving (Eq, Show, Typeable, Generic) +instance Hashable GhcSession +instance NFData GhcSession +instance Binary GhcSession + +data GhcSessionDeps = GhcSessionDeps deriving (Eq, Show, Typeable, Generic) +instance Hashable GhcSessionDeps +instance NFData GhcSessionDeps +instance Binary GhcSessionDeps + +data GetModIfaceFromDisk = GetModIfaceFromDisk + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetModIfaceFromDisk +instance NFData GetModIfaceFromDisk +instance Binary GetModIfaceFromDisk + +data GetModIfaceFromDiskAndIndex = GetModIfaceFromDiskAndIndex + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetModIfaceFromDiskAndIndex +instance NFData GetModIfaceFromDiskAndIndex +instance Binary GetModIfaceFromDiskAndIndex + +data GetModIface = GetModIface + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetModIface +instance NFData GetModIface +instance Binary GetModIface + +data GetModIfaceWithoutLinkable = GetModIfaceWithoutLinkable + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetModIfaceWithoutLinkable +instance NFData GetModIfaceWithoutLinkable +instance Binary GetModIfaceWithoutLinkable + +data IsFileOfInterest = IsFileOfInterest + deriving (Eq, Show, Typeable, Generic) +instance Hashable IsFileOfInterest +instance NFData IsFileOfInterest +instance Binary IsFileOfInterest + +data GetModSummaryWithoutTimestamps = GetModSummaryWithoutTimestamps + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetModSummaryWithoutTimestamps +instance NFData GetModSummaryWithoutTimestamps +instance Binary GetModSummaryWithoutTimestamps + +data GetModSummary = GetModSummary + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetModSummary +instance NFData GetModSummary +instance Binary GetModSummary + +-- | Get the vscode client settings stored in the ide state +data GetClientSettings = GetClientSettings + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetClientSettings +instance NFData GetClientSettings +instance Binary GetClientSettings + +type instance RuleResult GetClientSettings = Hashed (Maybe Value) + +-- A local rule type to get caching. We want to use newCache, but it has +-- thread killed exception issues, so we lift it to a full rule. +-- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547 +type instance RuleResult GhcSessionIO = IdeGhcSession + +data IdeGhcSession = IdeGhcSession + { loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) + -- ^ Returns the Ghc session and the cradle dependencies + , sessionVersion :: !Int + -- ^ Used as Shake key, versions must be unique and not reused + } + +instance Show IdeGhcSession where show _ = "IdeGhcSession" +instance NFData IdeGhcSession where rnf !_ = () + +data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic) +instance Hashable GhcSessionIO +instance NFData GhcSessionIO +instance Binary GhcSessionIO + +makeLensesWith + (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) + ''Splices diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -1,1140 +1,1157 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DuplicateRecordFields #-} -#include "ghc-api-version.h" - --- | A Shake implementation of the compiler service, built --- using the "Shaker" abstraction layer for in-memory use. --- -module Development.IDE.Core.Rules( - -- * Types - IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..), - Priority(..), GhcSessionIO(..), GetClientSettings(..), - -- * Functions - priorityTypeCheck, - priorityGenerateCore, - priorityFilesOfInterest, - runAction, useE, useNoFileE, usesE, - toIdeResult, - defineNoFile, - defineEarlyCutOffNoFile, - mainRule, - getAtPoint, - getDefinition, - getTypeDefinition, - highlightAtPoint, - refsAtPoint, - workspaceSymbols, - getDependencies, - getParsedModule, - getParsedModuleWithComments, - getClientConfigAction, - -- * Rules - CompiledLinkables(..), - IsHiFileStable(..), - getParsedModuleRule, - getParsedModuleWithCommentsRule, - getLocatedImportsRule, - getDependencyInformationRule, - reportImportCyclesRule, - getDependenciesRule, - typeCheckRule, - getDocMapRule, - loadGhcSession, - getModIfaceFromDiskRule, - getModIfaceRule, - getModIfaceWithoutLinkableRule, - getModSummaryRule, - isHiFileStableRule, - getModuleGraphRule, - knownFilesRule, - getClientSettingsRule, - getHieAstsRule, - getBindingsRule, - needsCompilationRule, - generateCoreRule, - getImportMapRule, - regenerateHiFile, - ghcSessionDepsDefinition, - getParsedModuleDefinition, - typeCheckRuleDefinition, - ) where - -import Fingerprint - -import Data.Aeson (toJSON, Result(Success)) -import Data.Binary hiding (get, put) -import Data.Tuple.Extra -import Control.Monad.Extra -import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe -import Development.IDE.Core.Compile -import Development.IDE.Core.OfInterest -import Development.IDE.Types.Options -import Development.IDE.Spans.Documentation -import Development.IDE.Spans.LocalBindings -import Development.IDE.Import.DependencyInformation -import Development.IDE.Import.FindImports -import Development.IDE.Core.FileExists -import Development.IDE.Core.FileStore (modificationTime, getFileContents) -import Development.IDE.Types.Diagnostics as Diag -import Development.IDE.Types.Location -import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule, writeHieFile, TargetModule, TargetFile) -import Development.IDE.GHC.ExactPrint -import Development.IDE.GHC.Util -import qualified Development.IDE.Types.Logger as L -import Data.Maybe -import Data.Foldable -import qualified Data.IntMap.Strict as IntMap -import Data.IntMap.Strict (IntMap) -import Data.List -import qualified Data.Set as Set -import qualified Data.Map as M -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Development.IDE.GHC.Error -import Development.Shake hiding (Diagnostic) -import Development.IDE.Core.RuleTypes -import qualified Data.ByteString.Char8 as BS -import Development.IDE.Core.PositionMapping -import Language.LSP.Types (DocumentHighlight (..), SymbolInformation(..), SMethod(SCustomMethod)) -import qualified Language.LSP.Server as LSP -import Language.LSP.VFS - -import qualified GHC.LanguageExtensions as LangExt -import HscTypes hiding (TargetModule, TargetFile) -import GHC.Generics(Generic) - -import qualified Development.IDE.Spans.AtPoint as AtPoint -import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.Service -import Development.IDE.Core.Shake -import Development.IDE.Types.HscEnvEq -import Development.Shake.Classes hiding (get, put) -import Control.Monad.Trans.Except (runExceptT,ExceptT,except) -import Control.Concurrent.Async (concurrently) -import Control.Monad.Reader -import Control.Exception.Safe - -import Data.Coerce -import Control.Monad.State -import FastString (FastString(uniq)) -import qualified HeaderInfo as Hdr -import Data.Time (UTCTime(..)) -import Data.Hashable -import qualified Data.HashSet as HashSet -import qualified Data.HashMap.Strict as HM -import TcRnMonad (tcg_dependent_files) -import Data.IORef -import Control.Concurrent.Extra -import Module -import qualified Data.Rope.UTF16 as Rope -import GHC.IO.Encoding -import Data.ByteString.Encoding as T - -import qualified HieDb -import Ide.Plugin.Config -import qualified Data.Aeson.Types as A - --- | This is useful for rules to convert rules that can only produce errors or --- a result into the more general IdeResult type that supports producing --- warnings while also producing a result. -toIdeResult :: Either [FileDiagnostic] v -> IdeResult v -toIdeResult = either (, Nothing) (([],) . Just) - --- | useE is useful to implement functions that aren’t rules but need shortcircuiting --- e.g. getDefinition. -useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping) -useE k = MaybeT . useWithStaleFast k - -useNoFileE :: IdeRule k v => IdeState -> k -> MaybeT IdeAction v -useNoFileE _ide k = fst <$> useE k emptyFilePath - -usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT IdeAction [(v,PositionMapping)] -usesE k = MaybeT . fmap sequence . mapM (useWithStaleFast k) - -defineNoFile :: IdeRule k v => (k -> Action v) -> Rules () -defineNoFile f = define $ \k file -> do - if file == emptyFilePath then do res <- f k; return ([], Just res) else - fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" - -defineEarlyCutOffNoFile :: IdeRule k v => (k -> Action (BS.ByteString, v)) -> Rules () -defineEarlyCutOffNoFile f = defineEarlyCutoff $ \k file -> do - if file == emptyFilePath then do (hash, res) <- f k; return (Just hash, ([], Just res)) else - fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" - ------------------------------------------------------------- --- Core IDE features ------------------------------------------------------------- - --- IMPORTANT NOTE : make sure all rules `useE`d by these have a "Persistent Stale" rule defined, --- so we can quickly answer as soon as the IDE is opened --- Even if we don't have persistent information on disk for these rules, the persistent rule --- should just return an empty result --- It is imperative that the result of the persistent rule succeed in such a case, or we will --- block waiting for the rule to be properly computed. - --- | Try to get hover text for the name under point. -getAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe (Maybe Range, [T.Text])) -getAtPoint file pos = runMaybeT $ do - ide <- ask - opts <- liftIO $ getIdeOptionsIO ide - - (hf, mapping) <- useE GetHieAst file - dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> (runMaybeT $ useE GetDocMap file) - - !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - MaybeT $ pure $ fmap (first (toCurrentRange mapping =<<)) $ AtPoint.atPoint opts hf dkMap pos' - -toCurrentLocations :: PositionMapping -> [Location] -> [Location] -toCurrentLocations mapping = mapMaybe go - where - go (Location uri range) = Location uri <$> toCurrentRange mapping range - --- | Goto Definition. -getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) -getDefinition file pos = runMaybeT $ do - ide <- ask - opts <- liftIO $ getIdeOptionsIO ide - (HAR _ hf _ _ _, mapping) <- useE GetHieAst file - (ImportMap imports, _) <- useE GetImportMap file - !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - hiedb <- lift $ asks hiedb - dbWriter <- lift $ asks hiedbWriter - toCurrentLocations mapping <$> AtPoint.gotoDefinition hiedb (lookupMod dbWriter) opts imports hf pos' - -getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) -getTypeDefinition file pos = runMaybeT $ do - ide <- ask - opts <- liftIO $ getIdeOptionsIO ide - (hf, mapping) <- useE GetHieAst file - !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - hiedb <- lift $ asks hiedb - dbWriter <- lift $ asks hiedbWriter - toCurrentLocations mapping <$> AtPoint.gotoTypeDefinition hiedb (lookupMod dbWriter) opts hf pos' - -highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight]) -highlightAtPoint file pos = runMaybeT $ do - (HAR _ hf rf _ _,mapping) <- useE GetHieAst file - !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - let toCurrentHighlight (DocumentHighlight range t) = flip DocumentHighlight t <$> toCurrentRange mapping range - mapMaybe toCurrentHighlight <$>AtPoint.documentHighlight hf rf pos' - --- Refs are not an IDE action, so it is OK to be slow and (more) accurate -refsAtPoint :: NormalizedFilePath -> Position -> Action [Location] -refsAtPoint file pos = do - ShakeExtras{hiedb} <- getShakeExtras - fs <- HM.keys <$> getFilesOfInterest - asts <- HM.fromList . mapMaybe sequence . zip fs <$> usesWithStale GetHieAst fs - AtPoint.referencesAtPoint hiedb file pos (AtPoint.FOIReferences asts) - -workspaceSymbols :: T.Text -> IdeAction (Maybe [SymbolInformation]) -workspaceSymbols query = runMaybeT $ do - hiedb <- lift $ asks hiedb - res <- liftIO $ HieDb.searchDef hiedb $ T.unpack query - pure $ mapMaybe AtPoint.defRowToSymbolInfo res - ------------------------------------------------------------- --- Exposed API ------------------------------------------------------------- - --- | Eventually this will lookup/generate URIs for files in dependencies, but not in the --- project. Right now, this is just a stub. -lookupMod - :: HieDbWriter -- ^ access the database - -> FilePath -- ^ The `.hie` file we got from the database - -> ModuleName - -> UnitId - -> Bool -- ^ Is this file a boot file? - -> MaybeT IdeAction Uri -lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing - --- | Get all transitive file dependencies of a given module. --- Does not include the file itself. -getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath]) -getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file - -getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString -getSourceFileSource nfp = do - (_, msource) <- getFileContents nfp - case msource of - Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath nfp) - Just source -> pure $ T.encodeUtf8 source - --- | Parse the contents of a haskell file. -getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule) -getParsedModule = use GetParsedModule - --- | Parse the contents of a haskell file, --- ensuring comments are preserved in annotations -getParsedModuleWithComments :: NormalizedFilePath -> Action (Maybe ParsedModule) -getParsedModuleWithComments = use GetParsedModuleWithComments - ------------------------------------------------------------- --- Rules --- These typically go from key to value and are oracles. - -priorityTypeCheck :: Priority -priorityTypeCheck = Priority 0 - -priorityGenerateCore :: Priority -priorityGenerateCore = Priority (-1) - -priorityFilesOfInterest :: Priority -priorityFilesOfInterest = Priority (-2) - --- | WARNING: --- We currently parse the module both with and without Opt_Haddock, and --- return the one with Haddocks if it -- succeeds. However, this may not work --- for hlint or any client code that might need the parsed source with all --- annotations, including comments. --- For that use case you might want to use `getParsedModuleWithCommentsRule` --- See https://github.com/haskell/ghcide/pull/350#discussion_r370878197 --- and https://github.com/mpickering/ghcide/pull/22#issuecomment-625070490 --- GHC wiki about: https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations -getParsedModuleRule :: Rules () -getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do - (ms, _) <- use_ GetModSummary file - sess <- use_ GhcSession file - let hsc = hscEnv sess - opt <- getIdeOptions - - let dflags = ms_hspp_opts ms - mainParse = getParsedModuleDefinition hsc opt file ms - - -- Parse again (if necessary) to capture Haddock parse errors - res@(_, (_,pmod)) <- if gopt Opt_Haddock dflags - then - liftIO mainParse - else do - let haddockParse = getParsedModuleDefinition hsc opt file (withOptHaddock ms) - - -- parse twice, with and without Haddocks, concurrently - -- we cannot ignore Haddock parse errors because files of - -- non-interest are always parsed with Haddocks - -- If we can parse Haddocks, might as well use them - -- - -- HLINT INTEGRATION: might need to save the other parsed module too - ((fp,(diags,res)),(fph,(diagsh,resh))) <- liftIO $ concurrently mainParse haddockParse - - -- Merge haddock and regular diagnostics so we can always report haddock - -- parse errors - let diagsM = mergeParseErrorsHaddock diags diagsh - case resh of - Just _ - | HaddockParse <- optHaddockParse opt - -> pure (fph, (diagsM, resh)) - -- If we fail to parse haddocks, report the haddock diagnostics as well and - -- return the non-haddock parse. - -- This seems to be the correct behaviour because the Haddock flag is added - -- by us and not the user, so our IDE shouldn't stop working because of it. - _ -> pure (fp, (diagsM, res)) - -- Add dependencies on included files - _ <- uses GetModificationTime $ map toNormalizedFilePath' (maybe [] pm_extra_src_files pmod) - pure res - -withOptHaddock :: ModSummary -> ModSummary -withOptHaddock = withOption Opt_Haddock - -withOption :: GeneralFlag -> ModSummary -> ModSummary -withOption opt ms = ms{ms_hspp_opts= gopt_set (ms_hspp_opts ms) opt} - -withoutOption :: GeneralFlag -> ModSummary -> ModSummary -withoutOption opt ms = ms{ms_hspp_opts= gopt_unset (ms_hspp_opts ms) opt} - --- | Given some normal parse errors (first) and some from Haddock (second), merge them. --- Ignore Haddock errors that are in both. Demote Haddock-only errors to warnings. -mergeParseErrorsHaddock :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic] -mergeParseErrorsHaddock normal haddock = normal ++ - [ (a,b,c{_severity = Just DsWarning, _message = fixMessage $ _message c}) - | (a,b,c) <- haddock, Diag._range c `Set.notMember` locations] - where - locations = Set.fromList $ map (Diag._range . thd3) normal - - fixMessage x | "parse error " `T.isPrefixOf` x = "Haddock " <> x - | otherwise = "Haddock: " <> x - --- | This rule provides a ParsedModule preserving all annotations, --- including keywords, punctuation and comments. --- So it is suitable for use cases where you need a perfect edit. -getParsedModuleWithCommentsRule :: Rules () -getParsedModuleWithCommentsRule = defineEarlyCutoff $ \GetParsedModuleWithComments file -> do - (ms, _) <- use_ GetModSummary file - sess <- use_ GhcSession file - opt <- getIdeOptions - - let ms' = withoutOption Opt_Haddock $ withOption Opt_KeepRawTokenStream ms - - liftIO $ getParsedModuleDefinition (hscEnv sess) opt file ms' - -getParsedModuleDefinition :: HscEnv -> IdeOptions -> NormalizedFilePath -> ModSummary -> IO (Maybe BS.ByteString, ([FileDiagnostic], Maybe ParsedModule)) -getParsedModuleDefinition packageState opt file ms = do - let fp = fromNormalizedFilePath file - (diag, res) <- parseModule opt packageState fp ms - case res of - Nothing -> pure (Nothing, (diag, Nothing)) - Just modu -> do - mbFingerprint <- traverse (fmap fingerprintToBS . fingerprintFromStringBuffer) (ms_hspp_buf ms) - pure (mbFingerprint, (diag, Just modu)) - -getLocatedImportsRule :: Rules () -getLocatedImportsRule = - define $ \GetLocatedImports file -> do - (ms,_) <- use_ GetModSummaryWithoutTimestamps file - targets <- useNoFile_ GetKnownTargets - let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms] - env_eq <- use_ GhcSession file - let env = hscEnvWithImportPaths env_eq - let import_dirs = deps env_eq - let dflags = hsc_dflags env - isImplicitCradle = isNothing $ envImportPaths env_eq - dflags <- return $ if isImplicitCradle - then addRelativeImport file (moduleName $ ms_mod ms) dflags - else dflags - opt <- getIdeOptions - let getTargetExists modName nfp - | isImplicitCradle = getFileExists nfp - | HM.member (TargetModule modName) targets - || HM.member (TargetFile nfp) targets - = getFileExists nfp - | otherwise = return False - (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do - diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getTargetExists modName mbPkgName isSource - case diagOrImp of - Left diags -> pure (diags, Just (modName, Nothing)) - Right (FileImport path) -> pure ([], Just (modName, Just path)) - Right PackageImport -> pure ([], Nothing) - let moduleImports = catMaybes imports' - pure (concat diags, Just moduleImports) - -type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action a - -execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1) -execRawDepM act = - execStateT act - ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty - , IntMap.empty - ) - --- | Given a target file path, construct the raw dependency results by following --- imports recursively. -rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation -rawDependencyInformation fs = do - (rdi, ss) <- execRawDepM (goPlural fs) - let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss - return (rdi { rawBootMap = bm }) - where - goPlural ff = do - mss <- lift $ (fmap.fmap) fst <$> uses GetModSummaryWithoutTimestamps ff - zipWithM go ff mss - - go :: NormalizedFilePath -- ^ Current module being processed - -> Maybe ModSummary -- ^ ModSummary of the module - -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId - go f msum = do - -- First check to see if we have already processed the FilePath - -- If we have, just return its Id but don't update any of the state. - -- Otherwise, we need to process its imports. - checkAlreadyProcessed f $ do - let al = modSummaryToArtifactsLocation f msum - -- Get a fresh FilePathId for the new file - fId <- getFreshFid al - -- Adding an edge to the bootmap so we can make sure to - -- insert boot nodes before the real files. - addBootMap al fId - -- Try to parse the imports of the file - importsOrErr <- lift $ use GetLocatedImports f - case importsOrErr of - Nothing -> do - -- File doesn't parse so add the module as a failure into the - -- dependency information, continue processing the other - -- elements in the queue - modifyRawDepInfo (insertImport fId (Left ModuleParseError)) - return fId - Just modImports -> do - -- Get NFPs of the imports which have corresponding files - -- Imports either come locally from a file or from a package. - let (no_file, with_file) = splitImports modImports - (mns, ls) = unzip with_file - -- Recursively process all the imports we just learnt about - -- and get back a list of their FilePathIds - fids <- goPlural $ map artifactFilePath ls - -- Associate together the ModuleName with the FilePathId - let moduleImports' = map (,Nothing) no_file ++ zip mns (map Just fids) - -- Insert into the map the information about this modules - -- imports. - modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports') - return fId - - - checkAlreadyProcessed :: NormalizedFilePath -> RawDepM FilePathId -> RawDepM FilePathId - checkAlreadyProcessed nfp k = do - (rawDepInfo, _) <- get - maybe k return (lookupPathToId (rawPathIdMap rawDepInfo) nfp) - - modifyRawDepInfo :: (RawDependencyInformation -> RawDependencyInformation) -> RawDepM () - modifyRawDepInfo f = modify (first f) - - addBootMap :: ArtifactsLocation -> FilePathId -> RawDepM () - addBootMap al fId = - modify (\(rd, ss) -> (rd, if isBootLocation al - then IntMap.insert (getFilePathId fId) al ss - else ss)) - - getFreshFid :: ArtifactsLocation -> RawDepM FilePathId - getFreshFid al = do - (rawDepInfo, ss) <- get - let (fId, path_map) = getPathId al (rawPathIdMap rawDepInfo) - -- Insert the File into the bootmap if it's a boot module - let rawDepInfo' = rawDepInfo { rawPathIdMap = path_map } - put (rawDepInfo', ss) - return fId - - -- Split in (package imports, local imports) - splitImports :: [(Located ModuleName, Maybe ArtifactsLocation)] - -> ([Located ModuleName], [(Located ModuleName, ArtifactsLocation)]) - splitImports = foldr splitImportsLoop ([],[]) - - splitImportsLoop (imp, Nothing) (ns, ls) = (imp:ns, ls) - splitImportsLoop (imp, Just artifact) (ns, ls) = (ns, (imp,artifact) : ls) - - updateBootMap pm boot_mod_id ArtifactsLocation{..} bm = - if not artifactIsSource - then - let msource_mod_id = lookupPathToId (rawPathIdMap pm) (toNormalizedFilePath' $ dropBootSuffix $ fromNormalizedFilePath artifactFilePath) - in case msource_mod_id of - Just source_mod_id -> insertBootId source_mod_id (FilePathId boot_mod_id) bm - Nothing -> bm - else bm - - dropBootSuffix :: FilePath -> FilePath - dropBootSuffix hs_src = reverse . drop (length @[] "-boot") . reverse $ hs_src - -getDependencyInformationRule :: Rules () -getDependencyInformationRule = - define $ \GetDependencyInformation file -> do - rawDepInfo <- rawDependencyInformation [file] - pure ([], Just $ processDependencyInformation rawDepInfo) - -reportImportCyclesRule :: Rules () -reportImportCyclesRule = - define $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do - DependencyInformation{..} <- use_ GetDependencyInformation file - let fileId = pathToId depPathIdMap file - case IntMap.lookup (getFilePathId fileId) depErrorNodes of - Nothing -> pure [] - Just errs -> do - let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs) - -- Convert cycles of files into cycles of module names - forM cycles $ \(imp, files) -> do - modNames <- forM files $ \fileId -> do - let file = idToPath depPathIdMap fileId - getModuleName file - pure $ toDiag imp $ sort modNames - where cycleErrorInFile f (PartOfCycle imp fs) - | f `elem` fs = Just (imp, fs) - cycleErrorInFile _ _ = Nothing - toDiag imp mods = (fp , ShowDiag , ) $ Diagnostic - { _range = rng - , _severity = Just DsError - , _source = Just "Import cycle detection" - , _message = "Cyclic module dependency between " <> showCycle mods - , _code = Nothing - , _relatedInformation = Nothing - , _tags = Nothing - } - where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp) - fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp) - getModuleName file = do - ms <- fst <$> use_ GetModSummaryWithoutTimestamps file - pure (moduleNameString . moduleName . ms_mod $ ms) - showCycle mods = T.intercalate ", " (map T.pack mods) - --- returns all transitive dependencies in topological order. --- NOTE: result does not include the argument file. -getDependenciesRule :: Rules () -getDependenciesRule = - defineEarlyCutoff $ \GetDependencies file -> do - depInfo <- use_ GetDependencyInformation file - let allFiles = reachableModules depInfo - _ <- uses_ ReportImportCycles allFiles - opts <- getIdeOptions - let mbFingerprints = map (fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts - return (fingerprintToBS . fingerprintFingerprints <$> mbFingerprints, ([], transitiveDeps depInfo file)) - -getHieAstsRule :: Rules () -getHieAstsRule = - define $ \GetHieAst f -> do - tmr <- use_ TypeCheck f - hsc <- hscEnv <$> use_ GhcSession f - getHieAstRuleDefinition f hsc tmr - -persistentHieFileRule :: Rules () -persistentHieFileRule = addPersistentRule GetHieAst $ \file -> runMaybeT $ do - res <- readHieFileForSrcFromDisk file - vfs <- asks vfs - encoding <- liftIO getLocaleEncoding - (currentSource,ver) <- liftIO $ do - mvf <- getVirtualFile vfs $ filePathToUri' file - case mvf of - Nothing -> (,Nothing) . T.decode encoding <$> BS.readFile (fromNormalizedFilePath file) - Just vf -> pure (Rope.toText $ _text vf, Just $ _lsp_version vf) - let refmap = generateReferencesMap . getAsts . hie_asts $ res - del = deltaFromDiff (T.decode encoding $ hie_hs_src res) currentSource - pure (HAR (hie_module res) (hie_asts res) refmap mempty (HieFromDisk res),del,ver) - -getHieAstRuleDefinition :: NormalizedFilePath -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult) -getHieAstRuleDefinition f hsc tmr = do - (diags, masts) <- liftIO $ generateHieAsts hsc tmr - se <- getShakeExtras - - isFoi <- use_ IsFileOfInterest f - diagsWrite <- case isFoi of - IsFOI Modified{firstOpen = False} -> do - when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ - LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $ - toJSON $ fromNormalizedFilePath f - pure [] - _ | Just asts <- masts -> do - source <- getSourceFileSource f - let exports = tcg_exports $ tmrTypechecked tmr - msum = tmrModSummary tmr - liftIO $ writeAndIndexHieFile hsc se msum f exports asts source - _ -> pure [] - - let refmap = generateReferencesMap . getAsts <$> masts - typemap = AtPoint.computeTypeReferences . getAsts <$> masts - pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap <*> typemap <*> pure HieFresh) - -getImportMapRule :: Rules () -getImportMapRule = define $ \GetImportMap f -> do - im <- use GetLocatedImports f - let mkImports fileImports = M.fromList $ mapMaybe (\(m, mfp) -> (unLoc m,) . artifactFilePath <$> mfp) fileImports - pure ([], ImportMap . mkImports <$> im) - --- | Ensure that go to definition doesn't block on startup -persistentImportMapRule :: Rules () -persistentImportMapRule = addPersistentRule GetImportMap $ \_ -> pure $ Just (ImportMap mempty, idDelta, Nothing) - -getBindingsRule :: Rules () -getBindingsRule = - define $ \GetBindings f -> do - HAR{hieKind=kind, refMap=rm} <- use_ GetHieAst f - case kind of - HieFresh -> pure ([], Just $ bindings rm) - HieFromDisk _ -> pure ([], Nothing) - -getDocMapRule :: Rules () -getDocMapRule = - define $ \GetDocMap file -> do - -- Stale data for the scenario where a broken module has previously typechecked - -- but we never generated a DocMap for it - (tmrTypechecked -> tc, _) <- useWithStale_ TypeCheck file - (hscEnv -> hsc, _) <- useWithStale_ GhcSessionDeps file - (HAR{refMap=rf}, _) <- useWithStale_ GetHieAst file - - dkMap <- liftIO $ mkDocMap hsc rf tc - return ([],Just dkMap) - --- | Persistent rule to ensure that hover doesn't block on startup -persistentDocMapRule :: Rules () -persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty, idDelta, Nothing) - -readHieFileForSrcFromDisk :: NormalizedFilePath -> MaybeT IdeAction HieFile -readHieFileForSrcFromDisk file = do - db <- asks hiedb - log <- asks $ L.logDebug . logger - row <- MaybeT $ liftIO $ HieDb.lookupHieFileFromSource db $ fromNormalizedFilePath file - let hie_loc = HieDb.hieModuleHieFile row - liftIO $ log $ "LOADING HIE FILE :" <> T.pack (show file) - exceptToMaybeT $ readHieFileFromDisk hie_loc - -readHieFileFromDisk :: FilePath -> ExceptT SomeException IdeAction HieFile -readHieFileFromDisk hie_loc = do - nc <- asks ideNc - log <- asks $ L.logDebug . logger - res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) hie_loc - liftIO . log $ either (const $ "FAILED LOADING HIE FILE FOR:" <> T.pack (show hie_loc)) - (const $ "SUCCEEDED LOADING HIE FILE FOR:" <> T.pack (show hie_loc)) - res - except res - --- | Typechecks a module. -typeCheckRule :: Rules () -typeCheckRule = define $ \TypeCheck file -> do - pm <- use_ GetParsedModule file - hsc <- hscEnv <$> use_ GhcSessionDeps file - typeCheckRuleDefinition hsc pm - -knownFilesRule :: Rules () -knownFilesRule = defineEarlyCutOffNoFile $ \GetKnownTargets -> do - alwaysRerun - fs <- knownTargets - pure (BS.pack (show $ hash fs), unhashed fs) - -getModuleGraphRule :: Rules () -getModuleGraphRule = defineNoFile $ \GetModuleGraph -> do - fs <- toKnownFiles <$> useNoFile_ GetKnownTargets - rawDepInfo <- rawDependencyInformation (HashSet.toList fs) - pure $ processDependencyInformation rawDepInfo - --- This is factored out so it can be directly called from the GetModIface --- rule. Directly calling this rule means that on the initial load we can --- garbage collect all the intermediate typechecked modules rather than --- retain the information forever in the shake graph. -typeCheckRuleDefinition - :: HscEnv - -> ParsedModule - -> Action (IdeResult TcModuleResult) -typeCheckRuleDefinition hsc pm = do - setPriority priorityTypeCheck - IdeOptions { optDefer = defer } <- getIdeOptions - - linkables_to_keep <- currentLinkables - addUsageDependencies $ liftIO $ - typecheckModule defer hsc linkables_to_keep pm - where - addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult) - addUsageDependencies a = do - r@(_, mtc) <- a - forM_ mtc $ \tc -> do - used_files <- liftIO $ readIORef $ tcg_dependent_files $ tmrTypechecked tc - void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files) - return r - --- | Get all the linkables stored in the graph, i.e. the ones we *do not* need to unload. --- Doesn't actually contain the code, since we don't need it to unload -currentLinkables :: Action [Linkable] -currentLinkables = do - compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction - hm <- liftIO $ readVar compiledLinkables - pure $ map go $ moduleEnvToList hm - where - go (mod, time) = LM time mod [] - -loadGhcSession :: Rules () -loadGhcSession = do - -- This function should always be rerun because it tracks changes - -- to the version of the collection of HscEnv's. - defineEarlyCutOffNoFile $ \GhcSessionIO -> do - alwaysRerun - opts <- getIdeOptions - res <- optGhcSession opts - - let fingerprint = hash (sessionVersion res) - return (BS.pack (show fingerprint), res) - - defineEarlyCutoff $ \GhcSession file -> do - IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO - (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file - - -- add the deps to the Shake graph - let addDependency fp = do - let nfp = toNormalizedFilePath' fp - itExists <- getFileExists nfp - when itExists $ void $ use_ GetModificationTime nfp - mapM_ addDependency deps - - opts <- getIdeOptions - let cutoffHash = - case optShakeFiles opts of - -- optShakeFiles is only set in the DAML case. - -- https://github.com/haskell/ghcide/pull/522#discussion_r428622915 - Just {} -> "" - -- Hash the HscEnvEq returned so cutoff if it didn't change - -- from last time - Nothing -> BS.pack (show (hash (snd val))) - return (Just cutoffHash, val) - - define $ \GhcSessionDeps file -> ghcSessionDepsDefinition file - -ghcSessionDepsDefinition :: NormalizedFilePath -> Action (IdeResult HscEnvEq) -ghcSessionDepsDefinition file = do - env <- use_ GhcSession file - let hsc = hscEnv env - (ms,_) <- use_ GetModSummaryWithoutTimestamps file - deps <- use_ GetDependencies file - let tdeps = transitiveModuleDeps deps - uses_th_qq = - xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags - dflags = ms_hspp_opts ms - ifaces <- if uses_th_qq - then uses_ GetModIface tdeps - else uses_ GetModIfaceWithoutLinkable tdeps - - -- Currently GetDependencies returns things in topological order so A comes before B if A imports B. - -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces. - -- Long-term we might just want to change the order returned by GetDependencies - let inLoadOrder = reverse (map hirHomeMod ifaces) - - session' <- liftIO $ loadModulesHome inLoadOrder <$> setupFinderCache (map hirModSummary ifaces) hsc - - res <- liftIO $ newHscEnvEqWithImportPaths (envImportPaths env) session' [] - return ([], Just res) - --- | Load a iface from disk, or generate it if there isn't one or it is out of date --- This rule also ensures that the `.hie` and `.o` (if needed) files are written out. -getModIfaceFromDiskRule :: Rules () -getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do - (ms,_) <- use_ GetModSummary f - (diags_session, mb_session) <- ghcSessionDepsDefinition f - case mb_session of - Nothing -> return (Nothing, (diags_session, Nothing)) - Just session -> do - sourceModified <- use_ IsHiFileStable f - linkableType <- getLinkableType f - r <- loadInterface (hscEnv session) ms sourceModified linkableType (regenerateHiFile session f ms) - case r of - (diags, Nothing) -> return (Nothing, (diags ++ diags_session, Nothing)) - (diags, Just x) -> do - let !fp = Just $! hiFileFingerPrint x - return (fp, (diags <> diags_session, Just x)) - --- | Check state of hiedb after loading an iface from disk - have we indexed the corresponding `.hie` file? --- This function is responsible for ensuring database consistency --- Whenever we read a `.hi` file, we must check to ensure we have also --- indexed the corresponding `.hie` file. If this is not the case (for example, --- `ghcide` could be killed before indexing finishes), we must re-index the --- `.hie` file. There should be an up2date `.hie` file on --- disk since we are careful to write out the `.hie` file before writing the --- `.hi` file -getModIfaceFromDiskAndIndexRule :: Rules () -getModIfaceFromDiskAndIndexRule = defineEarlyCutoff $ \GetModIfaceFromDiskAndIndex f -> do - x <- use_ GetModIfaceFromDisk f - se@ShakeExtras{hiedb} <- getShakeExtras - - -- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db - let ms = hirModSummary x - hie_loc = ml_hie_file $ ms_location ms - hash <- liftIO $ getFileHash hie_loc - mrow <- liftIO $ HieDb.lookupHieFileFromSource hiedb (fromNormalizedFilePath f) - case mrow of - Just row - | hash == HieDb.modInfoHash (HieDb.hieModInfo row) - , hie_loc == HieDb.hieModuleHieFile row -> do - -- All good, the db has indexed the file - when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ - LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $ - toJSON $ fromNormalizedFilePath f - -- Not in db, must re-index - _ -> do - ehf <- liftIO $ runIdeAction "GetModIfaceFromDiskAndIndex" se $ runExceptT $ - readHieFileFromDisk hie_loc - case ehf of - -- Uh oh, we failed to read the file for some reason, need to regenerate it - Left err -> fail $ "failed to read .hie file " ++ show hie_loc ++ ": " ++ displayException err - -- can just re-index the file we read from disk - Right hf -> liftIO $ do - L.logDebug (logger se) $ "Re-indexing hie file for" <> T.pack (show f) - indexHieFile se ms f hash hf - - let fp = hiFileFingerPrint x - return (Just fp, ([], Just x)) - -isHiFileStableRule :: Rules () -isHiFileStableRule = defineEarlyCutoff $ \IsHiFileStable f -> do - (ms,_) <- use_ GetModSummaryWithoutTimestamps f - let hiFile = toNormalizedFilePath' - $ ml_hi_file $ ms_location ms - mbHiVersion <- use GetModificationTime_{missingFileDiagnostics=False} hiFile - modVersion <- use_ GetModificationTime f - sourceModified <- case mbHiVersion of - Nothing -> pure SourceModified - Just x -> - if modificationTime x < modificationTime modVersion - then pure SourceModified - else do - fileImports <- use_ GetLocatedImports f - let imports = fmap artifactFilePath . snd <$> fileImports - deps <- uses_ IsHiFileStable (catMaybes imports) - pure $ if all (== SourceUnmodifiedAndStable) deps - then SourceUnmodifiedAndStable - else SourceUnmodified - return (Just (BS.pack $ show sourceModified), ([], Just sourceModified)) - -getModSummaryRule :: Rules () -getModSummaryRule = do - defineEarlyCutoff $ \GetModSummary f -> do - session <- hscEnv <$> use_ GhcSession f - let dflags = hsc_dflags session - (modTime, mFileContent) <- getFileContents f - let fp = fromNormalizedFilePath f - modS <- liftIO $ runExceptT $ - getModSummaryFromImports session fp modTime (textToStringBuffer <$> mFileContent) - case modS of - Right res@(ms,_) -> do - let fingerPrint = hash (computeFingerprint f (fromJust $ ms_hspp_buf ms) dflags ms, hashUTC modTime) - return ( Just (BS.pack $ show fingerPrint) , ([], Just res)) - Left diags -> return (Nothing, (diags, Nothing)) - - defineEarlyCutoff $ \GetModSummaryWithoutTimestamps f -> do - ms <- use GetModSummary f - case ms of - Just res@(msWithTimestamps,_) -> do - let ms = msWithTimestamps { - ms_hs_date = error "use GetModSummary instead of GetModSummaryWithoutTimestamps", - ms_hspp_buf = error "use GetModSummary instead of GetModSummaryWithoutTimestamps" - } - dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f - let fp = BS.pack $ show $ hash (computeFingerprint f (fromJust $ ms_hspp_buf msWithTimestamps) dflags ms) - return (Just fp, ([], Just res)) - Nothing -> return (Nothing, ([], Nothing)) - where - -- Compute a fingerprint from the contents of `ModSummary`, - -- eliding the timestamps and other non relevant fields. - computeFingerprint f sb dflags ModSummary{..} = - let fingerPrint = - ( moduleNameString (moduleName ms_mod) - , ms_hspp_file - , map unLoc opts - , ml_hs_file ms_location - , fingerPrintImports ms_srcimps - , fingerPrintImports ms_textual_imps - ) - fingerPrintImports = map (fmap uniq *** (moduleNameString . unLoc)) - opts = Hdr.getOptions dflags sb (fromNormalizedFilePath f) - in fingerPrint - - hashUTC UTCTime{..} = (fromEnum utctDay, fromEnum utctDayTime) - - -generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts) -generateCore runSimplifier file = do - packageState <- hscEnv <$> use_ GhcSessionDeps file - tm <- use_ TypeCheck file - setPriority priorityGenerateCore - liftIO $ compileModule runSimplifier packageState (tmrModSummary tm) (tmrTypechecked tm) - -generateCoreRule :: Rules () -generateCoreRule = - define $ \GenerateCore -> generateCore (RunSimplifier True) - -getModIfaceRule :: Rules () -getModIfaceRule = defineEarlyCutoff $ \GetModIface f -> do - fileOfInterest <- use_ IsFileOfInterest f - res@(_,(_,mhmi)) <- case fileOfInterest of - IsFOI status -> do - -- Never load from disk for files of interest - tmr <- use_ TypeCheck f - linkableType <- getLinkableType f - hsc <- hscEnv <$> use_ GhcSessionDeps f - let compile = fmap ([],) $ use GenerateCore f - (diags, !hiFile) <- compileToObjCodeIfNeeded hsc linkableType compile tmr - let fp = hiFileFingerPrint <$> hiFile - hiDiags <- case hiFile of - Just hiFile - | OnDisk <- status - , not (tmrDeferedError tmr) -> liftIO $ writeHiFile hsc hiFile - _ -> pure [] - return (fp, (diags++hiDiags, hiFile)) - NotFOI -> do - hiFile <- use GetModIfaceFromDiskAndIndex f - let fp = hiFileFingerPrint <$> hiFile - return (fp, ([], hiFile)) - - -- Record the linkable so we know not to unload it - whenJust (hm_linkable . hirHomeMod =<< mhmi) $ \(LM time mod _) -> do - compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction - liftIO $ modifyVar_ compiledLinkables $ \old -> pure $ extendModuleEnv old mod time - pure res - -getModIfaceWithoutLinkableRule :: Rules () -getModIfaceWithoutLinkableRule = defineEarlyCutoff $ \GetModIfaceWithoutLinkable f -> do - mhfr <- use GetModIface f - let mhfr' = fmap (\x -> x{ hirHomeMod = (hirHomeMod x){ hm_linkable = Just (error msg) } }) mhfr - msg = "tried to look at linkable for GetModIfaceWithoutLinkable for " ++ show f - pure (fingerprintToBS . getModuleHash . hirModIface <$> mhfr', ([],mhfr')) - --- | Also generates and indexes the `.hie` file, along with the `.o` file if needed --- Invariant maintained is that if the `.hi` file was successfully written, then the --- `.hie` and `.o` file (if needed) were also successfully written -regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> ModSummary -> Maybe LinkableType -> Action ([FileDiagnostic], Maybe HiFileResult) -regenerateHiFile sess f ms compNeeded = do - let hsc = hscEnv sess - opt <- getIdeOptions - - -- Embed haddocks in the interface file - (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt f (withOptHaddock ms) - (diags, mb_pm) <- case mb_pm of - Just _ -> return (diags, mb_pm) - Nothing -> do - -- if parsing fails, try parsing again with Haddock turned off - (_, (diagsNoHaddock, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt f ms - return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm) - case mb_pm of - Nothing -> return (diags, Nothing) - Just pm -> do - -- Invoke typechecking directly to update it without incurring a dependency - -- on the parsed module and the typecheck rules - (diags', mtmr) <- typeCheckRuleDefinition hsc pm - case mtmr of - Nothing -> pure (diags', Nothing) - Just tmr -> do - - -- compile writes .o file - let compile = compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr - - -- Bang pattern is important to avoid leaking 'tmr' - (diags'', !res) <- liftIO $ compileToObjCodeIfNeeded hsc compNeeded compile tmr - - -- Write hi file - hiDiags <- case res of - Just !hiFile -> do - - -- Write hie file. Do this before writing the .hi file to - -- ensure that we always have a up2date .hie file if we have - -- a .hi file - se <- getShakeExtras - (gDiags, masts) <- liftIO $ generateHieAsts hsc tmr - source <- getSourceFileSource f - wDiags <- forM masts $ \asts -> - liftIO $ writeAndIndexHieFile hsc se (tmrModSummary tmr) f (tcg_exports $ tmrTypechecked tmr) asts source - - -- We don't write the `.hi` file if there are defered errors, since we won't get - -- accurate diagnostics next time if we do - hiDiags <- if not $ tmrDeferedError tmr - then liftIO $ writeHiFile hsc hiFile - else pure [] - - pure (hiDiags <> gDiags <> concat wDiags) - Nothing -> pure [] - - - return (diags <> diags' <> diags'' <> hiDiags, res) - - -type CompileMod m = m (IdeResult ModGuts) - --- | HscEnv should have deps included already -compileToObjCodeIfNeeded :: MonadIO m => HscEnv -> Maybe LinkableType -> CompileMod m -> TcModuleResult -> m (IdeResult HiFileResult) -compileToObjCodeIfNeeded hsc Nothing _ tmr = liftIO $ do - res <- mkHiFileResultNoCompile hsc tmr - pure ([], Just $! res) -compileToObjCodeIfNeeded hsc (Just linkableType) getGuts tmr = do - (diags, mguts) <- getGuts - case mguts of - Nothing -> pure (diags, Nothing) - Just guts -> do - (diags', !res) <- liftIO $ mkHiFileResultCompile hsc tmr guts linkableType - pure (diags++diags', res) - -getClientSettingsRule :: Rules () -getClientSettingsRule = defineEarlyCutOffNoFile $ \GetClientSettings -> do - alwaysRerun - settings <- clientSettings <$> getIdeConfiguration - return (BS.pack . show . hash $ settings, settings) - --- | Returns the client configurarion stored in the IdeState. --- You can use this function to access it from shake Rules -getClientConfigAction :: Config -- ^ default value - -> Action Config -getClientConfigAction defValue = do - mbVal <- unhashed <$> useNoFile_ GetClientSettings - case A.parse (parseConfig defValue) <$> mbVal of - Just (Success c) -> return c - _ -> return defValue - --- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH -getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) -getLinkableType f = use_ NeedsCompilation f - -needsCompilationRule :: Rules () -needsCompilationRule = defineEarlyCutoff $ \NeedsCompilation file -> do - graph <- useNoFile GetModuleGraph - res <- case graph of - -- Treat as False if some reverse dependency header fails to parse - Nothing -> pure Nothing - Just depinfo -> case immediateReverseDependencies file depinfo of - -- If we fail to get immediate reverse dependencies, fail with an error message - Nothing -> fail $ "Failed to get the immediate reverse dependencies of " ++ show file - Just revdeps -> do - -- It's important to use stale data here to avoid wasted work. - -- if NeedsCompilation fails for a module M its result will be under-approximated - -- to False in its dependencies. However, if M actually used TH, this will - -- cause a re-evaluation of GetModIface for all dependencies - -- (since we don't need to generate object code anymore). - -- Once M is fixed we will discover that we actually needed all the object code - -- that we just threw away, and thus have to recompile all dependencies once - -- again, this time keeping the object code. - -- A file needs to be compiled if any file that depends on it uses TemplateHaskell or needs to be compiled - (ms,_) <- fst <$> useWithStale_ GetModSummaryWithoutTimestamps file - (modsums,needsComps) <- par (map (fmap (fst . fst)) <$> usesWithStale GetModSummaryWithoutTimestamps revdeps) - (uses NeedsCompilation revdeps) - pure $ computeLinkableType ms modsums (map join needsComps) - - pure (Just $ BS.pack $ show $ hash res, ([], Just res)) - where - uses_th_qq (ms_hspp_opts -> dflags) = - xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags - - unboxed_tuples_or_sums (ms_hspp_opts -> d) = - xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d - - computeLinkableType :: ModSummary -> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType - computeLinkableType this deps xs - | Just ObjectLinkable `elem` xs = Just ObjectLinkable -- If any dependent needs object code, so do we - | Just BCOLinkable `elem` xs = Just this_type -- If any dependent needs bytecode, then we need to be compiled - | any (maybe False uses_th_qq) deps = Just this_type -- If any dependent needs TH, then we need to be compiled - | otherwise = Nothing -- If none of these conditions are satisfied, we don't need to compile - where - -- How should we compile this module? (assuming we do in fact need to compile it) - -- Depends on whether it uses unboxed tuples or sums - this_type -#if defined(GHC_PATCHED_UNBOXED_BYTECODE) - = BCOLinkable -#else - | unboxed_tuples_or_sums this = ObjectLinkable - | otherwise = BCOLinkable -#endif - --- | Tracks which linkables are current, so we don't need to unload them -newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) } -instance IsIdeGlobal CompiledLinkables - --- | A rule that wires per-file rules together -mainRule :: Rules () -mainRule = do - linkables <- liftIO $ newVar emptyModuleEnv - addIdeGlobal $ CompiledLinkables linkables - getParsedModuleRule - getParsedModuleWithCommentsRule - getLocatedImportsRule - getDependencyInformationRule - reportImportCyclesRule - getDependenciesRule - typeCheckRule - getDocMapRule - loadGhcSession - getModIfaceFromDiskRule - getModIfaceFromDiskAndIndexRule - getModIfaceRule - getModIfaceWithoutLinkableRule - getModSummaryRule - isHiFileStableRule - getModuleGraphRule - knownFilesRule - getClientSettingsRule - getHieAstsRule - getBindingsRule - needsCompilationRule - generateCoreRule - getImportMapRule - getAnnotatedParsedSourceRule - persistentHieFileRule - persistentDocMapRule - persistentImportMapRule - --- | Given the path to a module src file, this rule returns True if the --- corresponding `.hi` file is stable, that is, if it is newer --- than the src file, and all its dependencies are stable too. -data IsHiFileStable = IsHiFileStable - deriving (Eq, Show, Typeable, Generic) -instance Hashable IsHiFileStable -instance NFData IsHiFileStable -instance Binary IsHiFileStable - -type instance RuleResult IsHiFileStable = SourceModified +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +#include "ghc-api-version.h" + +-- | A Shake implementation of the compiler service, built +-- using the "Shaker" abstraction layer for in-memory use. +-- +module Development.IDE.Core.Rules( + -- * Types + IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..), + Priority(..), GhcSessionIO(..), GetClientSettings(..), + -- * Functions + priorityTypeCheck, + priorityGenerateCore, + priorityFilesOfInterest, + runAction, useE, useNoFileE, usesE, + toIdeResult, + defineNoFile, + defineEarlyCutOffNoFile, + mainRule, + getAtPoint, + getDefinition, + getTypeDefinition, + highlightAtPoint, + refsAtPoint, + workspaceSymbols, + getDependencies, + getParsedModule, + getParsedModuleWithComments, + getClientConfigAction, + -- * Rules + CompiledLinkables(..), + IsHiFileStable(..), + getParsedModuleRule, + getParsedModuleWithCommentsRule, + getLocatedImportsRule, + getDependencyInformationRule, + reportImportCyclesRule, + getDependenciesRule, + typeCheckRule, + getDocMapRule, + loadGhcSession, + getModIfaceFromDiskRule, + getModIfaceRule, + getModIfaceWithoutLinkableRule, + getModSummaryRule, + isHiFileStableRule, + getModuleGraphRule, + knownFilesRule, + getClientSettingsRule, + getHieAstsRule, + getBindingsRule, + needsCompilationRule, + generateCoreRule, + getImportMapRule, + regenerateHiFile, + ghcSessionDepsDefinition, + getParsedModuleDefinition, + typeCheckRuleDefinition, + ) where + +import Fingerprint + +import Control.Monad.Extra +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import Data.Aeson (Result (Success), + toJSON) +import Data.Binary hiding (get, put) +import qualified Data.ByteString as BS +import Data.Foldable +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.List +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Tuple.Extra +import Development.IDE.Core.Compile +import Development.IDE.Core.FileExists +import Development.IDE.Core.FileStore (getFileContents, + modificationTime, resetInterfaceStore) +import Development.IDE.Core.OfInterest +import Development.IDE.Core.PositionMapping +import Development.IDE.Core.RuleTypes +import Development.IDE.GHC.Compat hiding + (TargetFile, + TargetModule, + parseModule, + typecheckModule, + writeHieFile) +import Development.IDE.GHC.Error +import Development.IDE.GHC.ExactPrint +import Development.IDE.GHC.Util +import Development.IDE.Import.DependencyInformation +import Development.IDE.Import.FindImports +import Development.IDE.Spans.Documentation +import Development.IDE.Spans.LocalBindings +import Development.IDE.Types.Diagnostics as Diag +import Development.IDE.Types.Location +import qualified Development.IDE.Types.Logger as L +import Development.IDE.Types.Options +import Development.Shake hiding + (Diagnostic) +import qualified Language.LSP.Server as LSP +import Language.LSP.Types (DocumentHighlight (..), + SMethod (SCustomMethod), + SymbolInformation (..)) +import Language.LSP.VFS + +import GHC.Generics (Generic) +import qualified GHC.LanguageExtensions as LangExt +import HscTypes hiding + (TargetFile, + TargetModule) + +import Control.Concurrent.Async (concurrently) +import Control.Exception.Safe +import Control.Monad.Reader +import Control.Monad.Trans.Except (ExceptT, except, + runExceptT) +import Development.IDE.Core.IdeConfiguration +import Development.IDE.Core.Service +import Development.IDE.Core.Shake +import qualified Development.IDE.Spans.AtPoint as AtPoint +import Development.IDE.Types.HscEnvEq +import Development.Shake.Classes hiding (get, put) + +import Control.Concurrent.Strict +import Control.Monad.State +import Data.ByteString.Encoding as T +import Data.Coerce +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HashSet +import Data.Hashable +import Data.IORef +import qualified Data.Rope.UTF16 as Rope +import Data.Time (UTCTime (..)) +import GHC.IO.Encoding +import Module +import TcRnMonad (tcg_dependent_files) + +import qualified Data.Aeson.Types as A +import qualified HieDb +import Ide.Plugin.Config +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Binary as B + +-- | This is useful for rules to convert rules that can only produce errors or +-- a result into the more general IdeResult type that supports producing +-- warnings while also producing a result. +toIdeResult :: Either [FileDiagnostic] v -> IdeResult v +toIdeResult = either (, Nothing) (([],) . Just) + +-- | useE is useful to implement functions that aren’t rules but need shortcircuiting +-- e.g. getDefinition. +useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping) +useE k = MaybeT . useWithStaleFast k + +useNoFileE :: IdeRule k v => IdeState -> k -> MaybeT IdeAction v +useNoFileE _ide k = fst <$> useE k emptyFilePath + +usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT IdeAction [(v,PositionMapping)] +usesE k = MaybeT . fmap sequence . mapM (useWithStaleFast k) + +defineNoFile :: IdeRule k v => (k -> Action v) -> Rules () +defineNoFile f = defineNoDiagnostics $ \k file -> do + if file == emptyFilePath then do res <- f k; return (Just res) else + fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" + +defineEarlyCutOffNoFile :: IdeRule k v => (k -> Action (BS.ByteString, v)) -> Rules () +defineEarlyCutOffNoFile f = defineEarlyCutoff $ RuleNoDiagnostics $ \k file -> do + if file == emptyFilePath then do (hash, res) <- f k; return (Just hash, Just res) else + fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" + +------------------------------------------------------------ +-- Core IDE features +------------------------------------------------------------ + +-- IMPORTANT NOTE : make sure all rules `useE`d by these have a "Persistent Stale" rule defined, +-- so we can quickly answer as soon as the IDE is opened +-- Even if we don't have persistent information on disk for these rules, the persistent rule +-- should just return an empty result +-- It is imperative that the result of the persistent rule succeed in such a case, or we will +-- block waiting for the rule to be properly computed. + +-- | Try to get hover text for the name under point. +getAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe (Maybe Range, [T.Text])) +getAtPoint file pos = runMaybeT $ do + ide <- ask + opts <- liftIO $ getIdeOptionsIO ide + + (hf, mapping) <- useE GetHieAst file + dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> (runMaybeT $ useE GetDocMap file) + + !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) + MaybeT $ pure $ fmap (first (toCurrentRange mapping =<<)) $ AtPoint.atPoint opts hf dkMap pos' + +toCurrentLocations :: PositionMapping -> [Location] -> [Location] +toCurrentLocations mapping = mapMaybe go + where + go (Location uri range) = Location uri <$> toCurrentRange mapping range + +-- | Goto Definition. +getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) +getDefinition file pos = runMaybeT $ do + ide <- ask + opts <- liftIO $ getIdeOptionsIO ide + (HAR _ hf _ _ _, mapping) <- useE GetHieAst file + (ImportMap imports, _) <- useE GetImportMap file + !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) + hiedb <- lift $ asks hiedb + dbWriter <- lift $ asks hiedbWriter + toCurrentLocations mapping <$> AtPoint.gotoDefinition hiedb (lookupMod dbWriter) opts imports hf pos' + +getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) +getTypeDefinition file pos = runMaybeT $ do + ide <- ask + opts <- liftIO $ getIdeOptionsIO ide + (hf, mapping) <- useE GetHieAst file + !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) + hiedb <- lift $ asks hiedb + dbWriter <- lift $ asks hiedbWriter + toCurrentLocations mapping <$> AtPoint.gotoTypeDefinition hiedb (lookupMod dbWriter) opts hf pos' + +highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight]) +highlightAtPoint file pos = runMaybeT $ do + (HAR _ hf rf _ _,mapping) <- useE GetHieAst file + !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) + let toCurrentHighlight (DocumentHighlight range t) = flip DocumentHighlight t <$> toCurrentRange mapping range + mapMaybe toCurrentHighlight <$>AtPoint.documentHighlight hf rf pos' + +-- Refs are not an IDE action, so it is OK to be slow and (more) accurate +refsAtPoint :: NormalizedFilePath -> Position -> Action [Location] +refsAtPoint file pos = do + ShakeExtras{hiedb} <- getShakeExtras + fs <- HM.keys <$> getFilesOfInterest + asts <- HM.fromList . mapMaybe sequence . zip fs <$> usesWithStale GetHieAst fs + AtPoint.referencesAtPoint hiedb file pos (AtPoint.FOIReferences asts) + +workspaceSymbols :: T.Text -> IdeAction (Maybe [SymbolInformation]) +workspaceSymbols query = runMaybeT $ do + hiedb <- lift $ asks hiedb + res <- liftIO $ HieDb.searchDef hiedb $ T.unpack query + pure $ mapMaybe AtPoint.defRowToSymbolInfo res + +------------------------------------------------------------ +-- Exposed API +------------------------------------------------------------ + +-- | Eventually this will lookup/generate URIs for files in dependencies, but not in the +-- project. Right now, this is just a stub. +lookupMod + :: HieDbWriter -- ^ access the database + -> FilePath -- ^ The `.hie` file we got from the database + -> ModuleName + -> UnitId + -> Bool -- ^ Is this file a boot file? + -> MaybeT IdeAction Uri +lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing + +-- | Get all transitive file dependencies of a given module. +-- Does not include the file itself. +getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath]) +getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file + +getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString +getSourceFileSource nfp = do + (_, msource) <- getFileContents nfp + case msource of + Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath nfp) + Just source -> pure $ T.encodeUtf8 source + +-- | Parse the contents of a haskell file. +getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule) +getParsedModule = use GetParsedModule + +-- | Parse the contents of a haskell file, +-- ensuring comments are preserved in annotations +getParsedModuleWithComments :: NormalizedFilePath -> Action (Maybe ParsedModule) +getParsedModuleWithComments = use GetParsedModuleWithComments + +------------------------------------------------------------ +-- Rules +-- These typically go from key to value and are oracles. + +priorityTypeCheck :: Priority +priorityTypeCheck = Priority 0 + +priorityGenerateCore :: Priority +priorityGenerateCore = Priority (-1) + +priorityFilesOfInterest :: Priority +priorityFilesOfInterest = Priority (-2) + +-- | WARNING: +-- We currently parse the module both with and without Opt_Haddock, and +-- return the one with Haddocks if it -- succeeds. However, this may not work +-- for hlint or any client code that might need the parsed source with all +-- annotations, including comments. +-- For that use case you might want to use `getParsedModuleWithCommentsRule` +-- See https://github.com/haskell/ghcide/pull/350#discussion_r370878197 +-- and https://github.com/mpickering/ghcide/pull/22#issuecomment-625070490 +-- GHC wiki about: https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations +getParsedModuleRule :: Rules () +getParsedModuleRule = + -- this rule does not have early cutoff since all its dependencies already have it + define $ \GetParsedModule file -> do + ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary file + sess <- use_ GhcSession file + let hsc = hscEnv sess + opt <- getIdeOptions + + let dflags = ms_hspp_opts ms + mainParse = getParsedModuleDefinition hsc opt file ms + + -- Parse again (if necessary) to capture Haddock parse errors + res@(_,pmod) <- if gopt Opt_Haddock dflags + then + liftIO mainParse + else do + let haddockParse = getParsedModuleDefinition hsc opt file (withOptHaddock ms) + + -- parse twice, with and without Haddocks, concurrently + -- we cannot ignore Haddock parse errors because files of + -- non-interest are always parsed with Haddocks + -- If we can parse Haddocks, might as well use them + -- + -- HLINT INTEGRATION: might need to save the other parsed module too + ((diags,res),(diagsh,resh)) <- liftIO $ concurrently mainParse haddockParse + + -- Merge haddock and regular diagnostics so we can always report haddock + -- parse errors + let diagsM = mergeParseErrorsHaddock diags diagsh + case resh of + Just _ + | HaddockParse <- optHaddockParse opt + -> pure (diagsM, resh) + -- If we fail to parse haddocks, report the haddock diagnostics as well and + -- return the non-haddock parse. + -- This seems to be the correct behaviour because the Haddock flag is added + -- by us and not the user, so our IDE shouldn't stop working because of it. + _ -> pure (diagsM, res) + -- Add dependencies on included files + _ <- uses GetModificationTime $ map toNormalizedFilePath' (maybe [] pm_extra_src_files pmod) + pure res + +withOptHaddock :: ModSummary -> ModSummary +withOptHaddock = withOption Opt_Haddock + +withOption :: GeneralFlag -> ModSummary -> ModSummary +withOption opt ms = ms{ms_hspp_opts= gopt_set (ms_hspp_opts ms) opt} + +withoutOption :: GeneralFlag -> ModSummary -> ModSummary +withoutOption opt ms = ms{ms_hspp_opts= gopt_unset (ms_hspp_opts ms) opt} + +-- | Given some normal parse errors (first) and some from Haddock (second), merge them. +-- Ignore Haddock errors that are in both. Demote Haddock-only errors to warnings. +mergeParseErrorsHaddock :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic] +mergeParseErrorsHaddock normal haddock = normal ++ + [ (a,b,c{_severity = Just DsWarning, _message = fixMessage $ _message c}) + | (a,b,c) <- haddock, Diag._range c `Set.notMember` locations] + where + locations = Set.fromList $ map (Diag._range . thd3) normal + + fixMessage x | "parse error " `T.isPrefixOf` x = "Haddock " <> x + | otherwise = "Haddock: " <> x + +-- | This rule provides a ParsedModule preserving all annotations, +-- including keywords, punctuation and comments. +-- So it is suitable for use cases where you need a perfect edit. +getParsedModuleWithCommentsRule :: Rules () +getParsedModuleWithCommentsRule = + -- The parse diagnostics are owned by the GetParsedModule rule + -- For this reason, this rule does not produce any diagnostics + defineNoDiagnostics $ \GetParsedModuleWithComments file -> do + ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary file + sess <- use_ GhcSession file + opt <- getIdeOptions + + let ms' = withoutOption Opt_Haddock $ withOption Opt_KeepRawTokenStream ms + + liftIO $ snd <$> getParsedModuleDefinition (hscEnv sess) opt file ms' + +getParsedModuleDefinition + :: HscEnv + -> IdeOptions + -> NormalizedFilePath + -> ModSummary -> IO ([FileDiagnostic], Maybe ParsedModule) +getParsedModuleDefinition packageState opt file ms = do + let fp = fromNormalizedFilePath file + (diag, res) <- parseModule opt packageState fp ms + case res of + Nothing -> pure (diag, Nothing) + Just modu -> pure (diag, Just modu) + +getLocatedImportsRule :: Rules () +getLocatedImportsRule = + define $ \GetLocatedImports file -> do + ModSummaryResult{msrModSummary = ms} <- use_ GetModSummaryWithoutTimestamps file + targets <- useNoFile_ GetKnownTargets + let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms] + env_eq <- use_ GhcSession file + let env = hscEnvWithImportPaths env_eq + let import_dirs = deps env_eq + let dflags = hsc_dflags env + isImplicitCradle = isNothing $ envImportPaths env_eq + dflags <- return $ if isImplicitCradle + then addRelativeImport file (moduleName $ ms_mod ms) dflags + else dflags + opt <- getIdeOptions + let getTargetExists modName nfp + | isImplicitCradle = getFileExists nfp + | HM.member (TargetModule modName) targets + || HM.member (TargetFile nfp) targets + = getFileExists nfp + | otherwise = return False + (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do + diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getTargetExists modName mbPkgName isSource + case diagOrImp of + Left diags -> pure (diags, Just (modName, Nothing)) + Right (FileImport path) -> pure ([], Just (modName, Just path)) + Right PackageImport -> pure ([], Nothing) + let moduleImports = catMaybes imports' + pure (concat diags, Just moduleImports) + +type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action a + +execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1) +execRawDepM act = + execStateT act + ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty + , IntMap.empty + ) + +-- | Given a target file path, construct the raw dependency results by following +-- imports recursively. +rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation +rawDependencyInformation fs = do + (rdi, ss) <- execRawDepM (goPlural fs) + let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss + return (rdi { rawBootMap = bm }) + where + goPlural ff = do + mss <- lift $ (fmap.fmap) msrModSummary <$> uses GetModSummaryWithoutTimestamps ff + zipWithM go ff mss + + go :: NormalizedFilePath -- ^ Current module being processed + -> Maybe ModSummary -- ^ ModSummary of the module + -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId + go f msum = do + -- First check to see if we have already processed the FilePath + -- If we have, just return its Id but don't update any of the state. + -- Otherwise, we need to process its imports. + checkAlreadyProcessed f $ do + let al = modSummaryToArtifactsLocation f msum + -- Get a fresh FilePathId for the new file + fId <- getFreshFid al + -- Adding an edge to the bootmap so we can make sure to + -- insert boot nodes before the real files. + addBootMap al fId + -- Try to parse the imports of the file + importsOrErr <- lift $ use GetLocatedImports f + case importsOrErr of + Nothing -> do + -- File doesn't parse so add the module as a failure into the + -- dependency information, continue processing the other + -- elements in the queue + modifyRawDepInfo (insertImport fId (Left ModuleParseError)) + return fId + Just modImports -> do + -- Get NFPs of the imports which have corresponding files + -- Imports either come locally from a file or from a package. + let (no_file, with_file) = splitImports modImports + (mns, ls) = unzip with_file + -- Recursively process all the imports we just learnt about + -- and get back a list of their FilePathIds + fids <- goPlural $ map artifactFilePath ls + -- Associate together the ModuleName with the FilePathId + let moduleImports' = map (,Nothing) no_file ++ zip mns (map Just fids) + -- Insert into the map the information about this modules + -- imports. + modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports') + return fId + + + checkAlreadyProcessed :: NormalizedFilePath -> RawDepM FilePathId -> RawDepM FilePathId + checkAlreadyProcessed nfp k = do + (rawDepInfo, _) <- get + maybe k return (lookupPathToId (rawPathIdMap rawDepInfo) nfp) + + modifyRawDepInfo :: (RawDependencyInformation -> RawDependencyInformation) -> RawDepM () + modifyRawDepInfo f = modify (first f) + + addBootMap :: ArtifactsLocation -> FilePathId -> RawDepM () + addBootMap al fId = + modify (\(rd, ss) -> (rd, if isBootLocation al + then IntMap.insert (getFilePathId fId) al ss + else ss)) + + getFreshFid :: ArtifactsLocation -> RawDepM FilePathId + getFreshFid al = do + (rawDepInfo, ss) <- get + let (fId, path_map) = getPathId al (rawPathIdMap rawDepInfo) + -- Insert the File into the bootmap if it's a boot module + let rawDepInfo' = rawDepInfo { rawPathIdMap = path_map } + put (rawDepInfo', ss) + return fId + + -- Split in (package imports, local imports) + splitImports :: [(Located ModuleName, Maybe ArtifactsLocation)] + -> ([Located ModuleName], [(Located ModuleName, ArtifactsLocation)]) + splitImports = foldr splitImportsLoop ([],[]) + + splitImportsLoop (imp, Nothing) (ns, ls) = (imp:ns, ls) + splitImportsLoop (imp, Just artifact) (ns, ls) = (ns, (imp,artifact) : ls) + + updateBootMap pm boot_mod_id ArtifactsLocation{..} bm = + if not artifactIsSource + then + let msource_mod_id = lookupPathToId (rawPathIdMap pm) (toNormalizedFilePath' $ dropBootSuffix $ fromNormalizedFilePath artifactFilePath) + in case msource_mod_id of + Just source_mod_id -> insertBootId source_mod_id (FilePathId boot_mod_id) bm + Nothing -> bm + else bm + + dropBootSuffix :: FilePath -> FilePath + dropBootSuffix hs_src = reverse . drop (length @[] "-boot") . reverse $ hs_src + +getDependencyInformationRule :: Rules () +getDependencyInformationRule = + define $ \GetDependencyInformation file -> do + rawDepInfo <- rawDependencyInformation [file] + pure ([], Just $ processDependencyInformation rawDepInfo) + +reportImportCyclesRule :: Rules () +reportImportCyclesRule = + define $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do + DependencyInformation{..} <- use_ GetDependencyInformation file + let fileId = pathToId depPathIdMap file + case IntMap.lookup (getFilePathId fileId) depErrorNodes of + Nothing -> pure [] + Just errs -> do + let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs) + -- Convert cycles of files into cycles of module names + forM cycles $ \(imp, files) -> do + modNames <- forM files $ \fileId -> do + let file = idToPath depPathIdMap fileId + getModuleName file + pure $ toDiag imp $ sort modNames + where cycleErrorInFile f (PartOfCycle imp fs) + | f `elem` fs = Just (imp, fs) + cycleErrorInFile _ _ = Nothing + toDiag imp mods = (fp , ShowDiag , ) $ Diagnostic + { _range = rng + , _severity = Just DsError + , _source = Just "Import cycle detection" + , _message = "Cyclic module dependency between " <> showCycle mods + , _code = Nothing + , _relatedInformation = Nothing + , _tags = Nothing + } + where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp) + fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp) + getModuleName file = do + ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps file + pure (moduleNameString . moduleName . ms_mod $ ms) + showCycle mods = T.intercalate ", " (map T.pack mods) + +-- returns all transitive dependencies in topological order. +-- NOTE: result does not include the argument file. +getDependenciesRule :: Rules () +getDependenciesRule = + defineEarlyCutoff $ RuleNoDiagnostics $ \GetDependencies file -> do + depInfo <- use_ GetDependencyInformation file + let allFiles = reachableModules depInfo + _ <- uses_ ReportImportCycles allFiles + opts <- getIdeOptions + let mbFingerprints = map (fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts + return (fingerprintToBS . fingerprintFingerprints <$> mbFingerprints, transitiveDeps depInfo file) + +getHieAstsRule :: Rules () +getHieAstsRule = + define $ \GetHieAst f -> do + tmr <- use_ TypeCheck f + hsc <- hscEnv <$> use_ GhcSession f + getHieAstRuleDefinition f hsc tmr + +persistentHieFileRule :: Rules () +persistentHieFileRule = addPersistentRule GetHieAst $ \file -> runMaybeT $ do + res <- readHieFileForSrcFromDisk file + vfs <- asks vfs + encoding <- liftIO getLocaleEncoding + (currentSource,ver) <- liftIO $ do + mvf <- getVirtualFile vfs $ filePathToUri' file + case mvf of + Nothing -> (,Nothing) . T.decode encoding <$> BS.readFile (fromNormalizedFilePath file) + Just vf -> pure (Rope.toText $ _text vf, Just $ _lsp_version vf) + let refmap = generateReferencesMap . getAsts . hie_asts $ res + del = deltaFromDiff (T.decode encoding $ hie_hs_src res) currentSource + pure (HAR (hie_module res) (hie_asts res) refmap mempty (HieFromDisk res),del,ver) + +getHieAstRuleDefinition :: NormalizedFilePath -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult) +getHieAstRuleDefinition f hsc tmr = do + (diags, masts) <- liftIO $ generateHieAsts hsc tmr + se <- getShakeExtras + + isFoi <- use_ IsFileOfInterest f + diagsWrite <- case isFoi of + IsFOI Modified{firstOpen = False} -> do + when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ + LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $ + toJSON $ fromNormalizedFilePath f + pure [] + _ | Just asts <- masts -> do + source <- getSourceFileSource f + let exports = tcg_exports $ tmrTypechecked tmr + msum = tmrModSummary tmr + liftIO $ writeAndIndexHieFile hsc se msum f exports asts source + _ -> pure [] + + let refmap = generateReferencesMap . getAsts <$> masts + typemap = AtPoint.computeTypeReferences . getAsts <$> masts + pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap <*> typemap <*> pure HieFresh) + +getImportMapRule :: Rules () +getImportMapRule = define $ \GetImportMap f -> do + im <- use GetLocatedImports f + let mkImports fileImports = M.fromList $ mapMaybe (\(m, mfp) -> (unLoc m,) . artifactFilePath <$> mfp) fileImports + pure ([], ImportMap . mkImports <$> im) + +-- | Ensure that go to definition doesn't block on startup +persistentImportMapRule :: Rules () +persistentImportMapRule = addPersistentRule GetImportMap $ \_ -> pure $ Just (ImportMap mempty, idDelta, Nothing) + +getBindingsRule :: Rules () +getBindingsRule = + define $ \GetBindings f -> do + HAR{hieKind=kind, refMap=rm} <- use_ GetHieAst f + case kind of + HieFresh -> pure ([], Just $ bindings rm) + HieFromDisk _ -> pure ([], Nothing) + +getDocMapRule :: Rules () +getDocMapRule = + define $ \GetDocMap file -> do + -- Stale data for the scenario where a broken module has previously typechecked + -- but we never generated a DocMap for it + (tmrTypechecked -> tc, _) <- useWithStale_ TypeCheck file + (hscEnv -> hsc, _) <- useWithStale_ GhcSessionDeps file + (HAR{refMap=rf}, _) <- useWithStale_ GetHieAst file + + dkMap <- liftIO $ mkDocMap hsc rf tc + return ([],Just dkMap) + +-- | Persistent rule to ensure that hover doesn't block on startup +persistentDocMapRule :: Rules () +persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty, idDelta, Nothing) + +readHieFileForSrcFromDisk :: NormalizedFilePath -> MaybeT IdeAction HieFile +readHieFileForSrcFromDisk file = do + db <- asks hiedb + log <- asks $ L.logDebug . logger + row <- MaybeT $ liftIO $ HieDb.lookupHieFileFromSource db $ fromNormalizedFilePath file + let hie_loc = HieDb.hieModuleHieFile row + liftIO $ log $ "LOADING HIE FILE :" <> T.pack (show file) + exceptToMaybeT $ readHieFileFromDisk hie_loc + +readHieFileFromDisk :: FilePath -> ExceptT SomeException IdeAction HieFile +readHieFileFromDisk hie_loc = do + nc <- asks ideNc + log <- asks $ L.logDebug . logger + res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) hie_loc + liftIO . log $ either (const $ "FAILED LOADING HIE FILE FOR:" <> T.pack (show hie_loc)) + (const $ "SUCCEEDED LOADING HIE FILE FOR:" <> T.pack (show hie_loc)) + res + except res + +-- | Typechecks a module. +typeCheckRule :: Rules () +typeCheckRule = define $ \TypeCheck file -> do + pm <- use_ GetParsedModule file + hsc <- hscEnv <$> use_ GhcSessionDeps file + typeCheckRuleDefinition hsc pm + +knownFilesRule :: Rules () +knownFilesRule = defineEarlyCutOffNoFile $ \GetKnownTargets -> do + alwaysRerun + fs <- knownTargets + pure (LBS.toStrict $ B.encode $ hash fs, unhashed fs) + +getModuleGraphRule :: Rules () +getModuleGraphRule = defineNoFile $ \GetModuleGraph -> do + fs <- toKnownFiles <$> useNoFile_ GetKnownTargets + rawDepInfo <- rawDependencyInformation (HashSet.toList fs) + pure $ processDependencyInformation rawDepInfo + +-- This is factored out so it can be directly called from the GetModIface +-- rule. Directly calling this rule means that on the initial load we can +-- garbage collect all the intermediate typechecked modules rather than +-- retain the information forever in the shake graph. +typeCheckRuleDefinition + :: HscEnv + -> ParsedModule + -> Action (IdeResult TcModuleResult) +typeCheckRuleDefinition hsc pm = do + setPriority priorityTypeCheck + IdeOptions { optDefer = defer } <- getIdeOptions + + linkables_to_keep <- currentLinkables + addUsageDependencies $ liftIO $ + typecheckModule defer hsc linkables_to_keep pm + where + addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult) + addUsageDependencies a = do + r@(_, mtc) <- a + forM_ mtc $ \tc -> do + used_files <- liftIO $ readIORef $ tcg_dependent_files $ tmrTypechecked tc + void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files) + return r + +-- | Get all the linkables stored in the graph, i.e. the ones we *do not* need to unload. +-- Doesn't actually contain the code, since we don't need it to unload +currentLinkables :: Action [Linkable] +currentLinkables = do + compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction + hm <- liftIO $ readVar compiledLinkables + pure $ map go $ moduleEnvToList hm + where + go (mod, time) = LM time mod [] + +loadGhcSession :: Rules () +loadGhcSession = do + -- This function should always be rerun because it tracks changes + -- to the version of the collection of HscEnv's. + defineEarlyCutOffNoFile $ \GhcSessionIO -> do + alwaysRerun + opts <- getIdeOptions + res <- optGhcSession opts + + let fingerprint = LBS.toStrict $ B.encode $ hash (sessionVersion res) + return (fingerprint, res) + + defineEarlyCutoff $ Rule $ \GhcSession file -> do + IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO + (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file + + -- add the deps to the Shake graph + let addDependency fp = do + let nfp = toNormalizedFilePath' fp + itExists <- getFileExists nfp + when itExists $ void $ use_ GetModificationTime nfp + mapM_ addDependency deps + + opts <- getIdeOptions + let cutoffHash = + case optShakeFiles opts of + -- optShakeFiles is only set in the DAML case. + -- https://github.com/haskell/ghcide/pull/522#discussion_r428622915 + Just {} -> "" + -- Hash the HscEnvEq returned so cutoff if it didn't change + -- from last time + Nothing -> LBS.toStrict $ B.encode (hash (snd val)) + return (Just cutoffHash, val) + + define $ \GhcSessionDeps file -> ghcSessionDepsDefinition file + +ghcSessionDepsDefinition :: NormalizedFilePath -> Action (IdeResult HscEnvEq) +ghcSessionDepsDefinition file = do + env <- use_ GhcSession file + let hsc = hscEnv env + ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps file + deps <- use_ GetDependencies file + let tdeps = transitiveModuleDeps deps + uses_th_qq = + xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags + dflags = ms_hspp_opts ms + ifaces <- if uses_th_qq + then uses_ GetModIface tdeps + else uses_ GetModIfaceWithoutLinkable tdeps + + -- Currently GetDependencies returns things in topological order so A comes before B if A imports B. + -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces. + -- Long-term we might just want to change the order returned by GetDependencies + let inLoadOrder = reverse (map hirHomeMod ifaces) + + session' <- liftIO $ loadModulesHome inLoadOrder <$> setupFinderCache (map hirModSummary ifaces) hsc + + res <- liftIO $ newHscEnvEqWithImportPaths (envImportPaths env) session' [] + return ([], Just res) + +-- | Load a iface from disk, or generate it if there isn't one or it is out of date +-- This rule also ensures that the `.hie` and `.o` (if needed) files are written out. +getModIfaceFromDiskRule :: Rules () +getModIfaceFromDiskRule = defineEarlyCutoff $ Rule $ \GetModIfaceFromDisk f -> do + ms <- msrModSummary <$> use_ GetModSummary f + (diags_session, mb_session) <- ghcSessionDepsDefinition f + case mb_session of + Nothing -> return (Nothing, (diags_session, Nothing)) + Just session -> do + sourceModified <- use_ IsHiFileStable f + linkableType <- getLinkableType f + r <- loadInterface (hscEnv session) ms sourceModified linkableType (regenerateHiFile session f ms) + case r of + (diags, Nothing) -> return (Nothing, (diags ++ diags_session, Nothing)) + (diags, Just x) -> do + let !fp = Just $! hiFileFingerPrint x + return (fp, (diags <> diags_session, Just x)) + +-- | Check state of hiedb after loading an iface from disk - have we indexed the corresponding `.hie` file? +-- This function is responsible for ensuring database consistency +-- Whenever we read a `.hi` file, we must check to ensure we have also +-- indexed the corresponding `.hie` file. If this is not the case (for example, +-- `ghcide` could be killed before indexing finishes), we must re-index the +-- `.hie` file. There should be an up2date `.hie` file on +-- disk since we are careful to write out the `.hie` file before writing the +-- `.hi` file +getModIfaceFromDiskAndIndexRule :: Rules () +getModIfaceFromDiskAndIndexRule = + -- doesn't need early cutoff since all its dependencies already have it + defineNoDiagnostics $ \GetModIfaceFromDiskAndIndex f -> do + x <- use_ GetModIfaceFromDisk f + se@ShakeExtras{hiedb} <- getShakeExtras + + -- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db + let ms = hirModSummary x + hie_loc = ml_hie_file $ ms_location ms + hash <- liftIO $ getFileHash hie_loc + mrow <- liftIO $ HieDb.lookupHieFileFromSource hiedb (fromNormalizedFilePath f) + case mrow of + Just row + | hash == HieDb.modInfoHash (HieDb.hieModInfo row) + , hie_loc == HieDb.hieModuleHieFile row -> do + -- All good, the db has indexed the file + when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ + LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $ + toJSON $ fromNormalizedFilePath f + -- Not in db, must re-index + _ -> do + ehf <- liftIO $ runIdeAction "GetModIfaceFromDiskAndIndex" se $ runExceptT $ + readHieFileFromDisk hie_loc + case ehf of + -- Uh oh, we failed to read the file for some reason, need to regenerate it + Left err -> fail $ "failed to read .hie file " ++ show hie_loc ++ ": " ++ displayException err + -- can just re-index the file we read from disk + Right hf -> liftIO $ do + L.logDebug (logger se) $ "Re-indexing hie file for" <> T.pack (fromNormalizedFilePath f) + indexHieFile se ms f hash hf + + return (Just x) + +isHiFileStableRule :: Rules () +isHiFileStableRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsHiFileStable f -> do + ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps f + let hiFile = toNormalizedFilePath' + $ ml_hi_file $ ms_location ms + mbHiVersion <- use GetModificationTime_{missingFileDiagnostics=False} hiFile + modVersion <- use_ GetModificationTime f + sourceModified <- case mbHiVersion of + Nothing -> pure SourceModified + Just x -> + if modificationTime x < modificationTime modVersion + then pure SourceModified + else do + fileImports <- use_ GetLocatedImports f + let imports = fmap artifactFilePath . snd <$> fileImports + deps <- uses_ IsHiFileStable (catMaybes imports) + pure $ if all (== SourceUnmodifiedAndStable) deps + then SourceUnmodifiedAndStable + else SourceUnmodified + return (Just (summarize sourceModified), Just sourceModified) + where + summarize SourceModified = BS.singleton 1 + summarize SourceUnmodified = BS.singleton 2 + summarize SourceUnmodifiedAndStable = BS.singleton 3 + +getModSummaryRule :: Rules () +getModSummaryRule = do + defineEarlyCutoff $ Rule $ \GetModSummary f -> do + session <- hscEnv <$> use_ GhcSession f + (modTime, mFileContent) <- getFileContents f + let fp = fromNormalizedFilePath f + modS <- liftIO $ runExceptT $ + getModSummaryFromImports session fp modTime (textToStringBuffer <$> mFileContent) + case modS of + Right res -> do + bufFingerPrint <- liftIO $ + fingerprintFromStringBuffer $ fromJust $ ms_hspp_buf $ msrModSummary res + let fingerPrint = fingerprintFingerprints + [ msrFingerprint res, bufFingerPrint ] + return ( Just (fingerprintToBS fingerPrint) , ([], Just res)) + Left diags -> return (Nothing, (diags, Nothing)) + + defineEarlyCutoff $ RuleNoDiagnostics $ \GetModSummaryWithoutTimestamps f -> do + ms <- use GetModSummary f + case ms of + Just res@ModSummaryResult{..} -> do + let ms = msrModSummary { + ms_hs_date = error "use GetModSummary instead of GetModSummaryWithoutTimestamps", + ms_hspp_buf = error "use GetModSummary instead of GetModSummaryWithoutTimestamps" + } + fp = fingerprintToBS msrFingerprint + return (Just fp, Just res{msrModSummary = ms}) + Nothing -> return (Nothing, Nothing) + +generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts) +generateCore runSimplifier file = do + packageState <- hscEnv <$> use_ GhcSessionDeps file + tm <- use_ TypeCheck file + setPriority priorityGenerateCore + liftIO $ compileModule runSimplifier packageState (tmrModSummary tm) (tmrTypechecked tm) + +generateCoreRule :: Rules () +generateCoreRule = + define $ \GenerateCore -> generateCore (RunSimplifier True) + +getModIfaceRule :: Rules () +getModIfaceRule = defineEarlyCutoff $ Rule $ \GetModIface f -> do + fileOfInterest <- use_ IsFileOfInterest f + res@(_,(_,mhmi)) <- case fileOfInterest of + IsFOI status -> do + -- Never load from disk for files of interest + tmr <- use_ TypeCheck f + linkableType <- getLinkableType f + hsc <- hscEnv <$> use_ GhcSessionDeps f + let compile = fmap ([],) $ use GenerateCore f + (diags, !hiFile) <- compileToObjCodeIfNeeded hsc linkableType compile tmr + let fp = hiFileFingerPrint <$> hiFile + hiDiags <- case hiFile of + Just hiFile + | OnDisk <- status + , not (tmrDeferedError tmr) -> writeHiFileAction hsc hiFile + _ -> pure [] + return (fp, (diags++hiDiags, hiFile)) + NotFOI -> do + hiFile <- use GetModIfaceFromDiskAndIndex f + let fp = hiFileFingerPrint <$> hiFile + return (fp, ([], hiFile)) + + -- Record the linkable so we know not to unload it + whenJust (hm_linkable . hirHomeMod =<< mhmi) $ \(LM time mod _) -> do + compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction + liftIO $ void $ modifyVar' compiledLinkables $ \old -> extendModuleEnv old mod time + pure res + +getModIfaceWithoutLinkableRule :: Rules () +getModIfaceWithoutLinkableRule = defineEarlyCutoff $ RuleNoDiagnostics $ \GetModIfaceWithoutLinkable f -> do + mhfr <- use GetModIface f + let mhfr' = fmap (\x -> x{ hirHomeMod = (hirHomeMod x){ hm_linkable = Just (error msg) } }) mhfr + msg = "tried to look at linkable for GetModIfaceWithoutLinkable for " ++ show f + pure (hirIfaceFp <$> mhfr', mhfr') + +-- | Also generates and indexes the `.hie` file, along with the `.o` file if needed +-- Invariant maintained is that if the `.hi` file was successfully written, then the +-- `.hie` and `.o` file (if needed) were also successfully written +regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> ModSummary -> Maybe LinkableType -> Action ([FileDiagnostic], Maybe HiFileResult) +regenerateHiFile sess f ms compNeeded = do + let hsc = hscEnv sess + opt <- getIdeOptions + + -- Embed haddocks in the interface file + (diags, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f (withOptHaddock ms) + (diags, mb_pm) <- case mb_pm of + Just _ -> return (diags, mb_pm) + Nothing -> do + -- if parsing fails, try parsing again with Haddock turned off + (diagsNoHaddock, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f ms + return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm) + case mb_pm of + Nothing -> return (diags, Nothing) + Just pm -> do + -- Invoke typechecking directly to update it without incurring a dependency + -- on the parsed module and the typecheck rules + (diags', mtmr) <- typeCheckRuleDefinition hsc pm + case mtmr of + Nothing -> pure (diags', Nothing) + Just tmr -> do + + -- compile writes .o file + let compile = compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr + + -- Bang pattern is important to avoid leaking 'tmr' + (diags'', !res) <- liftIO $ compileToObjCodeIfNeeded hsc compNeeded compile tmr + + -- Write hi file + hiDiags <- case res of + Just !hiFile -> do + + -- Write hie file. Do this before writing the .hi file to + -- ensure that we always have a up2date .hie file if we have + -- a .hi file + se <- getShakeExtras + (gDiags, masts) <- liftIO $ generateHieAsts hsc tmr + source <- getSourceFileSource f + wDiags <- forM masts $ \asts -> + liftIO $ writeAndIndexHieFile hsc se (tmrModSummary tmr) f (tcg_exports $ tmrTypechecked tmr) asts source + + -- We don't write the `.hi` file if there are defered errors, since we won't get + -- accurate diagnostics next time if we do + hiDiags <- if not $ tmrDeferedError tmr + then writeHiFileAction hsc hiFile + else pure [] + + pure (hiDiags <> gDiags <> concat wDiags) + Nothing -> pure [] + + + return (diags <> diags' <> diags'' <> hiDiags, res) + + +type CompileMod m = m (IdeResult ModGuts) + +-- | HscEnv should have deps included already +compileToObjCodeIfNeeded :: MonadIO m => HscEnv -> Maybe LinkableType -> CompileMod m -> TcModuleResult -> m (IdeResult HiFileResult) +compileToObjCodeIfNeeded hsc Nothing _ tmr = liftIO $ do + res <- mkHiFileResultNoCompile hsc tmr + pure ([], Just $! res) +compileToObjCodeIfNeeded hsc (Just linkableType) getGuts tmr = do + (diags, mguts) <- getGuts + case mguts of + Nothing -> pure (diags, Nothing) + Just guts -> do + (diags', !res) <- liftIO $ mkHiFileResultCompile hsc tmr guts linkableType + pure (diags++diags', res) + +getClientSettingsRule :: Rules () +getClientSettingsRule = defineEarlyCutOffNoFile $ \GetClientSettings -> do + alwaysRerun + settings <- clientSettings <$> getIdeConfiguration + return (LBS.toStrict $ B.encode $ hash settings, settings) + +-- | Returns the client configurarion stored in the IdeState. +-- You can use this function to access it from shake Rules +getClientConfigAction :: Config -- ^ default value + -> Action Config +getClientConfigAction defValue = do + mbVal <- unhashed <$> useNoFile_ GetClientSettings + case A.parse (parseConfig defValue) <$> mbVal of + Just (Success c) -> return c + _ -> return defValue + +-- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH +getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) +getLinkableType f = use_ NeedsCompilation f + +needsCompilationRule :: Rules () +needsCompilationRule = defineEarlyCutoff $ RuleNoDiagnostics $ \NeedsCompilation file -> do + graph <- useNoFile GetModuleGraph + res <- case graph of + -- Treat as False if some reverse dependency header fails to parse + Nothing -> pure Nothing + Just depinfo -> case immediateReverseDependencies file depinfo of + -- If we fail to get immediate reverse dependencies, fail with an error message + Nothing -> fail $ "Failed to get the immediate reverse dependencies of " ++ show file + Just revdeps -> do + -- It's important to use stale data here to avoid wasted work. + -- if NeedsCompilation fails for a module M its result will be under-approximated + -- to False in its dependencies. However, if M actually used TH, this will + -- cause a re-evaluation of GetModIface for all dependencies + -- (since we don't need to generate object code anymore). + -- Once M is fixed we will discover that we actually needed all the object code + -- that we just threw away, and thus have to recompile all dependencies once + -- again, this time keeping the object code. + -- A file needs to be compiled if any file that depends on it uses TemplateHaskell or needs to be compiled + ms <- msrModSummary . fst <$> useWithStale_ GetModSummaryWithoutTimestamps file + (modsums,needsComps) <- + par (map (fmap (msrModSummary . fst)) <$> usesWithStale GetModSummaryWithoutTimestamps revdeps) + (uses NeedsCompilation revdeps) + pure $ computeLinkableType ms modsums (map join needsComps) + + pure (Just $ LBS.toStrict $ B.encode $ hash res, Just res) + where + uses_th_qq (ms_hspp_opts -> dflags) = + xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags + + unboxed_tuples_or_sums (ms_hspp_opts -> d) = + xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d + + computeLinkableType :: ModSummary -> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType + computeLinkableType this deps xs + | Just ObjectLinkable `elem` xs = Just ObjectLinkable -- If any dependent needs object code, so do we + | Just BCOLinkable `elem` xs = Just this_type -- If any dependent needs bytecode, then we need to be compiled + | any (maybe False uses_th_qq) deps = Just this_type -- If any dependent needs TH, then we need to be compiled + | otherwise = Nothing -- If none of these conditions are satisfied, we don't need to compile + where + -- How should we compile this module? (assuming we do in fact need to compile it) + -- Depends on whether it uses unboxed tuples or sums + this_type +#if defined(GHC_PATCHED_UNBOXED_BYTECODE) + = BCOLinkable +#else + | unboxed_tuples_or_sums this = ObjectLinkable + | otherwise = BCOLinkable +#endif + +-- | Tracks which linkables are current, so we don't need to unload them +newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) } +instance IsIdeGlobal CompiledLinkables + +writeHiFileAction :: HscEnv -> HiFileResult -> Action [FileDiagnostic] +writeHiFileAction hsc hiFile = do + extras <- getShakeExtras + let targetPath = ml_hi_file $ ms_location $ hirModSummary hiFile + liftIO $ do + resetInterfaceStore extras $ toNormalizedFilePath' targetPath + writeHiFile hsc hiFile + +-- | A rule that wires per-file rules together +mainRule :: Rules () +mainRule = do + linkables <- liftIO $ newVar emptyModuleEnv + addIdeGlobal $ CompiledLinkables linkables + getParsedModuleRule + getParsedModuleWithCommentsRule + getLocatedImportsRule + getDependencyInformationRule + reportImportCyclesRule + getDependenciesRule + typeCheckRule + getDocMapRule + loadGhcSession + getModIfaceFromDiskRule + getModIfaceFromDiskAndIndexRule + getModIfaceRule + getModIfaceWithoutLinkableRule + getModSummaryRule + isHiFileStableRule + getModuleGraphRule + knownFilesRule + getClientSettingsRule + getHieAstsRule + getBindingsRule + needsCompilationRule + generateCoreRule + getImportMapRule + getAnnotatedParsedSourceRule + persistentHieFileRule + persistentDocMapRule + persistentImportMapRule + +-- | Given the path to a module src file, this rule returns True if the +-- corresponding `.hi` file is stable, that is, if it is newer +-- than the src file, and all its dependencies are stable too. +data IsHiFileStable = IsHiFileStable + deriving (Eq, Show, Typeable, Generic) +instance Hashable IsHiFileStable +instance NFData IsHiFileStable +instance Binary IsHiFileStable + +type instance RuleResult IsHiFileStable = SourceModified diff --git a/src/Development/IDE/Core/Service.hs b/src/Development/IDE/Core/Service.hs --- a/src/Development/IDE/Core/Service.hs +++ b/src/Development/IDE/Core/Service.hs @@ -1,82 +1,80 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} - --- | A Shake implementation of the compiler service, built --- using the "Shaker" abstraction layer for in-memory use. --- -module Development.IDE.Core.Service( - getIdeOptions, getIdeOptionsIO, - IdeState, initialise, shutdown, - runAction, - writeProfile, - getDiagnostics, - ideLogger, - updatePositionMapping, - ) where - -import Development.IDE.Core.Debouncer -import Development.IDE.Core.FileExists (fileExistsRules) -import Development.IDE.Core.FileStore (fileStoreRules) -import Development.IDE.Core.OfInterest -import Development.IDE.Types.Logger as Logger -import Development.IDE.Types.Options (IdeOptions (..)) -import Development.Shake -import Ide.Plugin.Config -import qualified Language.LSP.Server as LSP -import qualified Language.LSP.Types as LSP - -import Control.Monad -import Development.IDE.Core.Shake - - ------------------------------------------------------------- --- Exposed API - --- | Initialise the Compiler Service. -initialise :: Config - -> Rules () - -> Maybe (LSP.LanguageContextEnv Config) - -> Logger - -> Debouncer LSP.NormalizedUri - -> IdeOptions - -> VFSHandle - -> HieDb - -> IndexQueue - -> IO IdeState -initialise defaultConfig mainRule lspEnv logger debouncer options vfs hiedb hiedbChan = - shakeOpen - lspEnv - defaultConfig - logger - debouncer - (optShakeProfiling options) - (optReportProgress options) - (optTesting options) - hiedb - hiedbChan - vfs - (optShakeOptions options) - $ do - addIdeGlobal $ GlobalIdeOptions options - fileStoreRules vfs - ofInterestRules - fileExistsRules lspEnv vfs - mainRule - -writeProfile :: IdeState -> FilePath -> IO () -writeProfile = shakeProfile - --- | Shutdown the Compiler Service. -shutdown :: IdeState -> IO () -shutdown = shakeShut - --- This will return as soon as the result of the action is --- available. There might still be other rules running at this point, --- e.g., the ofInterestRule. -runAction :: String -> IdeState -> Action a -> IO a -runAction herald ide act = - join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Info act) +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +-- | A Shake implementation of the compiler service, built +-- using the "Shaker" abstraction layer for in-memory use. +-- +module Development.IDE.Core.Service( + getIdeOptions, getIdeOptionsIO, + IdeState, initialise, shutdown, + runAction, + writeProfile, + getDiagnostics, + ideLogger, + updatePositionMapping, + ) where + +import Development.IDE.Core.Debouncer +import Development.IDE.Core.FileExists (fileExistsRules) +import Development.IDE.Core.OfInterest +import Development.IDE.Types.Logger as Logger +import Development.IDE.Types.Options (IdeOptions (..)) +import Development.Shake +import Ide.Plugin.Config +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Types as LSP + +import Control.Monad +import Development.IDE.Core.Shake + + +------------------------------------------------------------ +-- Exposed API + +-- | Initialise the Compiler Service. +initialise :: Config + -> Rules () + -> Maybe (LSP.LanguageContextEnv Config) + -> Logger + -> Debouncer LSP.NormalizedUri + -> IdeOptions + -> VFSHandle + -> HieDb + -> IndexQueue + -> IO IdeState +initialise defaultConfig mainRule lspEnv logger debouncer options vfs hiedb hiedbChan = + shakeOpen + lspEnv + defaultConfig + logger + debouncer + (optShakeProfiling options) + (optReportProgress options) + (optTesting options) + hiedb + hiedbChan + vfs + (optShakeOptions options) + $ do + addIdeGlobal $ GlobalIdeOptions options + ofInterestRules + fileExistsRules lspEnv vfs + mainRule + +writeProfile :: IdeState -> FilePath -> IO () +writeProfile = shakeProfile + +-- | Shutdown the Compiler Service. +shutdown :: IdeState -> IO () +shutdown = shakeShut + +-- This will return as soon as the result of the action is +-- available. There might still be other rules running at this point, +-- e.g., the ofInterestRule. +runAction :: String -> IdeState -> Action a -> IO a +runAction herald ide act = + join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Info act) diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -1,1153 +1,1185 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE PolyKinds #-} - --- | A Shake implementation of the compiler service. --- --- There are two primary locations where data lives, and both of --- these contain much the same data: --- --- * The Shake database (inside 'shakeDb') stores a map of shake keys --- to shake values. In our case, these are all of type 'Q' to 'A'. --- During a single run all the values in the Shake database are consistent --- so are used in conjunction with each other, e.g. in 'uses'. --- --- * The 'Values' type stores a map of keys to values. These values are --- always stored as real Haskell values, whereas Shake serialises all 'A' values --- between runs. To deserialise a Shake value, we just consult Values. -module Development.IDE.Core.Shake( - IdeState, shakeExtras, - ShakeExtras(..), getShakeExtras, getShakeExtrasRules, - KnownTargets, Target(..), toKnownFiles, - IdeRule, IdeResult, - GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics), - shakeOpen, shakeShut, - shakeRestart, - shakeEnqueue, - shakeProfile, - use, useNoFile, uses, useWithStaleFast, useWithStaleFast', delayedAction, - FastResult(..), - use_, useNoFile_, uses_, - useWithStale, usesWithStale, - useWithStale_, usesWithStale_, - BadDependency(..), - define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, - getDiagnostics, - mRunLspT, mRunLspTCallback, - getHiddenDiagnostics, - IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction, - getIdeGlobalExtras, - getIdeOptions, - getIdeOptionsIO, - GlobalIdeOptions(..), - getClientConfig, - getPluginConfig, - garbageCollect, - knownTargets, - setPriority, - ideLogger, - actionLogger, - FileVersion(..), - Priority(..), - updatePositionMapping, - deleteValue, - OnDiskRule(..), - WithProgressFunc, WithIndefiniteProgressFunc, - ProgressEvent(..), - DelayedAction, mkDelayedAction, - IdeAction(..), runIdeAction, - mkUpdater, - -- Exposed for testing. - Q(..), - IndexQueue, - HieDb, - HieDbWriter(..), - VFSHandle(..), - addPersistentRule - ) where - -import Development.Shake hiding (ShakeValue, doesFileExist, Info) -import Development.Shake.Database -import Development.Shake.Classes -import Development.Shake.Rule -import qualified Data.HashMap.Strict as HMap -import qualified Data.Map.Strict as Map -import qualified Data.ByteString.Char8 as BS -import Data.Dynamic -import Data.Maybe -import Data.Map.Strict (Map) -import Data.List.Extra (partition, takeEnd) -import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Vector (Vector) -import qualified Data.Vector as Vector -import Data.Tuple.Extra -import Data.Unique -import Development.IDE.Core.Debouncer -import Development.IDE.GHC.Compat (NameCacheUpdater(..), upNameCache ) -import Development.IDE.GHC.Orphans () -import Development.IDE.Core.PositionMapping -import Development.IDE.Core.RuleTypes -import Development.IDE.Types.Action -import Development.IDE.Types.Logger hiding (Priority) -import Development.IDE.Types.KnownTargets -import Development.IDE.Types.Shake -import qualified Development.IDE.Types.Logger as Logger -import Language.LSP.Diagnostics -import qualified Data.SortedList as SL -import Development.IDE.Types.Diagnostics -import Development.IDE.Types.Exports -import Development.IDE.Types.Location -import Development.IDE.Types.Options -import Control.Concurrent.Async -import Control.Concurrent.Extra -import Control.Concurrent.STM -import Control.DeepSeq -import System.Time.Extra -import Data.Typeable -import qualified Language.LSP.Server as LSP -import qualified Language.LSP.Types as LSP -import System.FilePath hiding (makeRelative) -import qualified Development.Shake as Shake -import Control.Monad.Extra -import Data.Time -import GHC.Generics -import Language.LSP.Types -import qualified Control.Monad.STM as STM -import Control.Monad.IO.Class -import Control.Monad.Reader -import Control.Monad.Trans.Maybe -import Data.Traversable -import Data.Hashable -import Development.IDE.Core.Tracing -import Language.LSP.VFS - -import Data.IORef -import NameCache -import UniqSupply -import PrelInfo -import Language.LSP.Types.Capabilities -import OpenTelemetry.Eventlog -import GHC.Fingerprint - -import HieDb.Types -import Control.Exception.Extra hiding (bracket_) -import UnliftIO.Exception (bracket_) -import Ide.Plugin.Config -import Data.Default -import qualified Ide.PluginUtils as HLS -import Ide.Types ( PluginId ) - --- | We need to serialize writes to the database, so we send any function that --- needs to write to the database over the channel, where it will be picked up by --- a worker thread. -data HieDbWriter - = HieDbWriter - { indexQueue :: IndexQueue - , indexPending :: TVar (HMap.HashMap NormalizedFilePath Fingerprint) -- ^ Avoid unnecessary/out of date indexing - , indexCompleted :: TVar Int -- ^ to report progress - , indexProgressToken :: Var (Maybe LSP.ProgressToken) - -- ^ This is a Var instead of a TVar since we need to do IO to initialise/update, so we need a lock - } - --- | Actions to queue up on the index worker thread -type IndexQueue = TQueue (HieDb -> IO ()) - --- information we stash inside the shakeExtra field -data ShakeExtras = ShakeExtras - { --eventer :: LSP.FromServerMessage -> IO () - lspEnv :: Maybe (LSP.LanguageContextEnv Config) - ,debouncer :: Debouncer NormalizedUri - ,logger :: Logger - ,globals :: Var (HMap.HashMap TypeRep Dynamic) - ,state :: Var Values - ,diagnostics :: Var DiagnosticStore - ,hiddenDiagnostics :: Var DiagnosticStore - ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic]) - -- ^ This represents the set of diagnostics that we have published. - -- Due to debouncing not every change might get published. - ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping))) - -- ^ Map from a text document version to a PositionMapping that describes how to map - -- positions in a version of that document to positions in the latest version - -- First mapping is delta from previous version and second one is an - -- accumlation of all previous mappings. - ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int) - -- ^ How many rules are running for each file - ,progressUpdate :: ProgressEvent -> IO () - ,ideTesting :: IdeTesting - -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants - ,session :: MVar ShakeSession - -- ^ Used in the GhcSession rule to forcefully restart the session after adding a new component - ,restartShakeSession :: [DelayedAction ()] -> IO () - ,ideNc :: IORef NameCache - -- | A mapping of module name to known target (or candidate targets, if missing) - ,knownTargetsVar :: Var (Hashed KnownTargets) - -- | A mapping of exported identifiers for local modules. Updated on kick - ,exportsMap :: Var ExportsMap - -- | A work queue for actions added via 'runInShakeSession' - ,actionQueue :: ActionQueue - ,clientCapabilities :: ClientCapabilities - , hiedb :: HieDb -- ^ Use only to read. - , hiedbWriter :: HieDbWriter -- ^ use to write - , persistentKeys :: Var (HMap.HashMap Key GetStalePersistent) - -- ^ Registery for functions that compute/get "stale" results for the rule - -- (possibly from disk) - , vfs :: VFSHandle - , defaultConfig :: Config - -- ^ Default HLS config, only relevant if the client does not provide any Config - } - -type WithProgressFunc = forall a. - T.Text -> LSP.ProgressCancellable -> ((LSP.ProgressAmount -> IO ()) -> IO a) -> IO a -type WithIndefiniteProgressFunc = forall a. - T.Text -> LSP.ProgressCancellable -> IO a -> IO a - -data ProgressEvent - = KickStarted - | KickCompleted - -type GetStalePersistent = NormalizedFilePath -> IdeAction (Maybe (Dynamic,PositionDelta,TextDocumentVersion)) - -getShakeExtras :: Action ShakeExtras -getShakeExtras = do - Just x <- getShakeExtra @ShakeExtras - return x - -getShakeExtrasRules :: Rules ShakeExtras -getShakeExtrasRules = do - Just x <- getShakeExtraRules @ShakeExtras - return x - -getClientConfig :: LSP.MonadLsp Config m => ShakeExtras -> m Config -getClientConfig ShakeExtras { defaultConfig } = - fromMaybe defaultConfig <$> HLS.getClientConfig - -getPluginConfig - :: LSP.MonadLsp Config m => ShakeExtras -> PluginId -> m PluginConfig -getPluginConfig extras plugin = do - config <- getClientConfig extras - return $ HLS.configForPlugin config plugin - --- | Register a function that will be called to get the "stale" result of a rule, possibly from disk --- This is called when we don't already have a result, or computing the rule failed. --- The result of this function will always be marked as 'stale', and a 'proper' rebuild of the rule will --- be queued if the rule hasn't run before. -addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,TextDocumentVersion))) -> Rules () -addPersistentRule k getVal = do - ShakeExtras{persistentKeys} <- getShakeExtrasRules - liftIO $ modifyVar_ persistentKeys $ \hm -> do - pure $ HMap.insert (Key k) (fmap (fmap (first3 toDyn)) . getVal) hm - return () - -class Typeable a => IsIdeGlobal a where - - --- | haskell-lsp manages the VFS internally and automatically so we cannot use --- the builtin VFS without spawning up an LSP server. To be able to test things --- like `setBufferModified` we abstract over the VFS implementation. -data VFSHandle = VFSHandle - { getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile) - -- ^ get the contents of a virtual file - , setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ()) - -- ^ set a specific file to a value. If Nothing then we are ignoring these - -- signals anyway so can just say something was modified - } -instance IsIdeGlobal VFSHandle - -addIdeGlobal :: IsIdeGlobal a => a -> Rules () -addIdeGlobal x = do - extras <- getShakeExtrasRules - liftIO $ addIdeGlobalExtras extras x - -addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO () -addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) = - liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of - Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty - Nothing -> return $! HMap.insert ty (toDyn x) mp - - -getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a -getIdeGlobalExtras ShakeExtras{globals} = do - let typ = typeRep (Proxy :: Proxy a) - x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals - case x of - Just x - | Just x <- fromDynamic x -> pure x - | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")" - Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ - -getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a -getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras - -getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a -getIdeGlobalState = getIdeGlobalExtras . shakeExtras - - -newtype GlobalIdeOptions = GlobalIdeOptions IdeOptions -instance IsIdeGlobal GlobalIdeOptions - -getIdeOptions :: Action IdeOptions -getIdeOptions = do - GlobalIdeOptions x <- getIdeGlobalAction - return x - -getIdeOptionsIO :: ShakeExtras -> IO IdeOptions -getIdeOptionsIO ide = do - GlobalIdeOptions x <- getIdeGlobalExtras ide - return x - --- | Return the most recent, potentially stale, value and a PositionMapping --- for the version of that value. -lastValueIO :: IdeRule k v => ShakeExtras -> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping)) -lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do - hm <- readVar state - allMappings <- readVar positionMapping - - let readPersistent - | IdeTesting testing <- ideTesting s -- Don't read stale persistent values in tests - , testing = pure Nothing - | otherwise = do - pmap <- readVar persistentKeys - mv <- runMaybeT $ do - liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP UP PERSISTENT FOR: " ++ show k - f <- MaybeT $ pure $ HMap.lookup (Key k) pmap - (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file - MaybeT $ pure $ (,del,ver) <$> fromDynamic dv - modifyVar state $ \hm -> pure $ case mv of - Nothing -> (HMap.alter (alterValue $ Failed True) (file,Key k) hm,Nothing) - Just (v,del,ver) -> (HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (file,Key k) hm - ,Just (v,addDelta del $ mappingForVersion allMappings file ver)) - - -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics - alterValue new Nothing = Just (ValueWithDiagnostics new mempty) -- If it wasn't in the map, give it empty diagnostics - alterValue new (Just old@(ValueWithDiagnostics val diags)) = Just $ case val of - -- Old failed, we can update it preserving diagnostics - Failed{} -> ValueWithDiagnostics new diags - -- Something already succeeded before, leave it alone - _ -> old - - case HMap.lookup (file,Key k) hm of - Nothing -> readPersistent - Just (ValueWithDiagnostics v _) -> case v of - Succeeded ver (fromDynamic -> Just v) -> pure (Just (v, mappingForVersion allMappings file ver)) - Stale del ver (fromDynamic -> Just v) -> pure (Just (v, maybe id addDelta del $ mappingForVersion allMappings file ver)) - Failed p | not p -> readPersistent - _ -> pure Nothing - --- | Return the most recent, potentially stale, value and a PositionMapping --- for the version of that value. -lastValue :: IdeRule k v => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping)) -lastValue key file = do - s <- getShakeExtras - liftIO $ lastValueIO s key file - -valueVersion :: Value v -> Maybe TextDocumentVersion -valueVersion = \case - Succeeded ver _ -> Just ver - Stale _ ver _ -> Just ver - Failed _ -> Nothing - -mappingForVersion - :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping)) - -> NormalizedFilePath - -> TextDocumentVersion - -> PositionMapping -mappingForVersion allMappings file ver = - maybe zeroMapping snd $ - Map.lookup ver =<< - HMap.lookup (filePathToUri' file) allMappings - -type IdeRule k v = - ( Shake.RuleResult k ~ v - , Shake.ShakeValue k - , Show v - , Typeable v - , NFData v - ) - --- | A live Shake session with the ability to enqueue Actions for running. --- Keeps the 'ShakeDatabase' open, so at most one 'ShakeSession' per database. -newtype ShakeSession = ShakeSession - { cancelShakeSession :: IO () - -- ^ Closes the Shake session - } - --- | A Shake database plus persistent store. Can be thought of as storing --- mappings from @(FilePath, k)@ to @RuleResult k@. -data IdeState = IdeState - {shakeDb :: ShakeDatabase - ,shakeSession :: MVar ShakeSession - ,shakeClose :: IO () - ,shakeExtras :: ShakeExtras - ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) - ,stopProgressReporting :: IO () - } - - - --- This is debugging code that generates a series of profiles, if the Boolean is true -shakeDatabaseProfileIO :: Maybe FilePath -> IO(ShakeDatabase -> IO (Maybe FilePath)) -shakeDatabaseProfileIO mbProfileDir = do - profileStartTime <- formatTime defaultTimeLocale "%Y%m%d-%H%M%S" <$> getCurrentTime - profileCounter <- newVar (0::Int) - return $ \shakeDb -> - for mbProfileDir $ \dir -> do - count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y) - let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) <.> "html" - shakeProfileDatabase shakeDb $ dir file - return (dir file) - -setValues :: IdeRule k v - => Var Values - -> k - -> NormalizedFilePath - -> Value v - -> Vector FileDiagnostic - -> IO () -setValues state key file val diags = modifyVar_ state $ \vals -> do - -- Force to make sure the old HashMap is not retained - evaluate $ HMap.insert (file, Key key) (ValueWithDiagnostics (fmap toDyn val) diags) vals - --- | Delete the value stored for a given ide build key -deleteValue - :: (Typeable k, Hashable k, Eq k, Show k) - => IdeState - -> k - -> NormalizedFilePath - -> IO () -deleteValue IdeState{shakeExtras = ShakeExtras{state}} key file = modifyVar_ state $ \vals -> - evaluate $ HMap.delete (file, Key key) vals - --- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value. -getValues :: - forall k v. - IdeRule k v => - Var Values -> - k -> - NormalizedFilePath -> - IO (Maybe (Value v, Vector FileDiagnostic)) -getValues state key file = do - vs <- readVar state - case HMap.lookup (file, Key key) vs of - Nothing -> pure Nothing - Just (ValueWithDiagnostics v diagsV) -> do - let r = fmap (fromJust . fromDynamic @v) v - -- Force to make sure we do not retain a reference to the HashMap - -- and we blow up immediately if the fromJust should fail - -- (which would be an internal error). - evaluate (r `seqValue` Just (r, diagsV)) - --- | Get all the files in the project -knownTargets :: Action (Hashed KnownTargets) -knownTargets = do - ShakeExtras{knownTargetsVar} <- getShakeExtras - liftIO $ readVar knownTargetsVar - --- | Seq the result stored in the Shake value. This only --- evaluates the value to WHNF not NF. We take care of the latter --- elsewhere and doing it twice is expensive. -seqValue :: Value v -> b -> b -seqValue v b = case v of - Succeeded ver v -> rnf ver `seq` v `seq` b - Stale d ver v -> rnf d `seq` rnf ver `seq` v `seq` b - Failed _ -> b - --- | Open a 'IdeState', should be shut using 'shakeShut'. -shakeOpen :: Maybe (LSP.LanguageContextEnv Config) - -> Config - -> Logger - -> Debouncer NormalizedUri - -> Maybe FilePath - -> IdeReportProgress - -> IdeTesting - -> HieDb - -> IndexQueue - -> VFSHandle - -> ShakeOptions - -> Rules () - -> IO IdeState -shakeOpen lspEnv defaultConfig logger debouncer - shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo - - inProgress <- newVar HMap.empty - us <- mkSplitUniqSupply 'r' - ideNc <- newIORef (initNameCache us knownKeyNames) - (shakeExtras, stopProgressReporting) <- do - globals <- newVar HMap.empty - state <- newVar HMap.empty - diagnostics <- newVar mempty - hiddenDiagnostics <- newVar mempty - publishedDiagnostics <- newVar mempty - positionMapping <- newVar HMap.empty - knownTargetsVar <- newVar $ hashed HMap.empty - let restartShakeSession = shakeRestart ideState - let session = shakeSession - mostRecentProgressEvent <- newTVarIO KickCompleted - persistentKeys <- newVar HMap.empty - let progressUpdate = atomically . writeTVar mostRecentProgressEvent - indexPending <- newTVarIO HMap.empty - indexCompleted <- newTVarIO 0 - indexProgressToken <- newVar Nothing - let hiedbWriter = HieDbWriter{..} - progressAsync <- async $ - when reportProgress $ - progressThread mostRecentProgressEvent inProgress - exportsMap <- newVar mempty - - actionQueue <- newQueue - - let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv - - pure (ShakeExtras{..}, cancel progressAsync) - (shakeDbM, shakeClose) <- - shakeOpenDatabase - opts { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts } - rules - shakeDb <- shakeDbM - initSession <- newSession shakeExtras shakeDb [] - shakeSession <- newMVar initSession - shakeDatabaseProfile <- shakeDatabaseProfileIO shakeProfileDir - let ideState = IdeState{..} - - IdeOptions{ optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled } <- getIdeOptionsIO shakeExtras - startTelemetry otProfilingEnabled logger $ state shakeExtras - - return ideState - where - -- The progress thread is a state machine with two states: - -- 1. Idle - -- 2. Reporting a kick event - -- And two transitions, modelled by 'ProgressEvent': - -- 1. KickCompleted - transitions from Reporting into Idle - -- 2. KickStarted - transitions from Idle into Reporting - progressThread mostRecentProgressEvent inProgress = progressLoopIdle - where - progressLoopIdle = do - atomically $ do - v <- readTVar mostRecentProgressEvent - case v of - KickCompleted -> STM.retry - KickStarted -> return () - asyncReporter <- async $ mRunLspT lspEnv lspShakeProgress - progressLoopReporting asyncReporter - progressLoopReporting asyncReporter = do - atomically $ do - v <- readTVar mostRecentProgressEvent - case v of - KickStarted -> STM.retry - KickCompleted -> return () - cancel asyncReporter - progressLoopIdle - - lspShakeProgress :: LSP.LspM config () - lspShakeProgress = do - -- first sleep a bit, so we only show progress messages if it's going to take - -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) - liftIO $ unless testing $ sleep 0.1 - u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique - - void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate - LSP.WorkDoneProgressCreateParams { _token = u } $ const (pure ()) - - bracket_ - (start u) - (stop u) - (loop u Nothing) - where - start id = LSP.sendNotification LSP.SProgress $ - LSP.ProgressParams - { _token = id - , _value = LSP.Begin $ WorkDoneProgressBeginParams - { _title = "Processing" - , _cancellable = Nothing - , _message = Nothing - , _percentage = Nothing - } - } - stop id = LSP.sendNotification LSP.SProgress - LSP.ProgressParams - { _token = id - , _value = LSP.End WorkDoneProgressEndParams - { _message = Nothing - } - } - sample = 0.1 - loop id prev = do - liftIO $ sleep sample - current <- liftIO $ readVar inProgress - let done = length $ filter (== 0) $ HMap.elems current - let todo = HMap.size current - let next = Just $ T.pack $ show done <> "/" <> show todo - when (next /= prev) $ - LSP.sendNotification LSP.SProgress $ - LSP.ProgressParams - { _token = id - , _value = LSP.Report $ LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = next - , _percentage = Nothing - } - } - loop id next - -shakeProfile :: IdeState -> FilePath -> IO () -shakeProfile IdeState{..} = shakeProfileDatabase shakeDb - -shakeShut :: IdeState -> IO () -shakeShut IdeState{..} = withMVar shakeSession $ \runner -> do - -- Shake gets unhappy if you try to close when there is a running - -- request so we first abort that. - void $ cancelShakeSession runner - shakeClose - stopProgressReporting - - --- | This is a variant of withMVar where the first argument is run unmasked and if it throws --- an exception, the previous value is restored while the second argument is executed masked. -withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c -withMVar' var unmasked masked = uninterruptibleMask $ \restore -> do - a <- takeMVar var - b <- restore (unmasked a) `onException` putMVar var a - (a', c) <- masked b - putMVar var a' - pure c - - -mkDelayedAction :: String -> Logger.Priority -> Action a -> DelayedAction a -mkDelayedAction = DelayedAction Nothing - --- | These actions are run asynchronously after the current action is --- finished running. For example, to trigger a key build after a rule --- has already finished as is the case with useWithStaleFast -delayedAction :: DelayedAction a -> IdeAction (IO a) -delayedAction a = do - extras <- ask - liftIO $ shakeEnqueue extras a - --- | Restart the current 'ShakeSession' with the given system actions. --- Any actions running in the current session will be aborted, --- but actions added via 'shakeEnqueue' will be requeued. -shakeRestart :: IdeState -> [DelayedAction ()] -> IO () -shakeRestart IdeState{..} acts = - withMVar' - shakeSession - (\runner -> do - (stopTime,()) <- duration (cancelShakeSession runner) - res <- shakeDatabaseProfile shakeDb - let profile = case res of - Just fp -> ", profile saved at " <> fp - _ -> "" - let msg = T.pack $ "Restarting build session (aborting the previous one took " - ++ showDuration stopTime ++ profile ++ ")" - logDebug (logger shakeExtras) msg - notifyTestingLogMessage shakeExtras msg - ) - -- It is crucial to be masked here, otherwise we can get killed - -- between spawning the new thread and updating shakeSession. - -- See https://github.com/haskell/ghcide/issues/79 - (\() -> do - (,()) <$> newSession shakeExtras shakeDb acts) - -notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO () -notifyTestingLogMessage extras msg = do - (IdeTesting isTestMode) <- optTesting <$> getIdeOptionsIO extras - let notif = LSP.LogMessageParams LSP.MtLog msg - when isTestMode $ mRunLspT (lspEnv extras) $ LSP.sendNotification LSP.SWindowLogMessage notif - - --- | Enqueue an action in the existing 'ShakeSession'. --- Returns a computation to block until the action is run, propagating exceptions. --- Assumes a 'ShakeSession' is available. --- --- Appropriate for user actions other than edits. -shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a) -shakeEnqueue ShakeExtras{actionQueue, logger} act = do - (b, dai) <- instantiateDelayedAction act - atomically $ pushQueue dai actionQueue - let wait' b = - waitBarrier b `catches` - [ Handler(\BlockedIndefinitelyOnMVar -> - fail $ "internal bug: forever blocked on MVar for " <> - actionName act) - , Handler (\e@AsyncCancelled -> do - logPriority logger Debug $ T.pack $ actionName act <> " was cancelled" - - atomically $ abortQueue dai actionQueue - throw e) - ] - return (wait' b >>= either throwIO return) - --- | Set up a new 'ShakeSession' with a set of initial actions --- Will crash if there is an existing 'ShakeSession' running. -newSession :: ShakeExtras -> ShakeDatabase -> [DelayedActionInternal] -> IO ShakeSession -newSession extras@ShakeExtras{..} shakeDb acts = do - reenqueued <- atomically $ peekInProgress actionQueue - let - -- A daemon-like action used to inject additional work - -- Runs actions from the work queue sequentially - pumpActionThread otSpan = do - d <- liftIO $ atomically $ popQueue actionQueue - void $ parallel [run otSpan d, pumpActionThread otSpan] - - -- TODO figure out how to thread the otSpan into defineEarlyCutoff - run _otSpan d = do - start <- liftIO offsetTime - getAction d - liftIO $ atomically $ doneQueue d actionQueue - runTime <- liftIO start - let msg = T.pack $ "finish: " ++ actionName d - ++ " (took " ++ showDuration runTime ++ ")" - liftIO $ do - logPriority logger (actionPriority d) msg - notifyTestingLogMessage extras msg - - workRun restore = withSpan "Shake session" $ \otSpan -> do - let acts' = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts) - res <- try @SomeException (restore $ shakeRunDatabase shakeDb acts') - let res' = case res of - Left e -> "exception: " <> displayException e - Right _ -> "completed" - let msg = T.pack $ "Finishing build session(" ++ res' ++ ")" - return $ do - logDebug logger msg - notifyTestingLogMessage extras msg - - -- Do the work in a background thread - workThread <- asyncWithUnmask workRun - - -- run the wrap up in a separate thread since it contains interruptible - -- commands (and we are not using uninterruptible mask) - _ <- async $ join $ wait workThread - - -- Cancelling is required to flush the Shake database when either - -- the filesystem or the Ghc configuration have changed - let cancelShakeSession :: IO () - cancelShakeSession = cancel workThread - - pure (ShakeSession{..}) - -instantiateDelayedAction - :: DelayedAction a - -> IO (Barrier (Either SomeException a), DelayedActionInternal) -instantiateDelayedAction (DelayedAction _ s p a) = do - u <- newUnique - b <- newBarrier - let a' = do - -- work gets reenqueued when the Shake session is restarted - -- it can happen that a work item finished just as it was reenqueud - -- in that case, skipping the work is fine - alreadyDone <- liftIO $ isJust <$> waitBarrierMaybe b - unless alreadyDone $ do - x <- actionCatch @SomeException (Right <$> a) (pure . Left) - -- ignore exceptions if the barrier has been filled concurrently - liftIO $ void $ try @SomeException $ signalBarrier b x - d' = DelayedAction (Just u) s p a' - return (b, d') - -mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m () -mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f -mRunLspT Nothing _ = pure () - -mRunLspTCallback :: Monad m - => Maybe (LSP.LanguageContextEnv c) - -> (LSP.LspT c m a -> LSP.LspT c m a) - -> m a - -> m a -mRunLspTCallback (Just lspEnv) f g = LSP.runLspT lspEnv $ f (lift g) -mRunLspTCallback Nothing _ g = g - -getDiagnostics :: IdeState -> IO [FileDiagnostic] -getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do - val <- readVar diagnostics - return $ getAllDiagnostics val - -getHiddenDiagnostics :: IdeState -> IO [FileDiagnostic] -getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do - val <- readVar hiddenDiagnostics - return $ getAllDiagnostics val - --- | Clear the results for all files that do not match the given predicate. -garbageCollect :: (NormalizedFilePath -> Bool) -> Action () -garbageCollect keep = do - ShakeExtras{state, diagnostics,hiddenDiagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras - liftIO $ - do newState <- modifyVar state $ \values -> do - values <- evaluate $ HMap.filterWithKey (\(file, _) _ -> keep file) values - return $! dupe values - modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags - modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags - modifyVar_ publishedDiagnostics $ \diags -> return $! HMap.filterWithKey (\uri _ -> keep (fromUri uri)) diags - let versionsForFile = - HMap.fromListWith Set.union $ - mapMaybe (\((file, _key), ValueWithDiagnostics v _) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $ - HMap.toList newState - modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings - --- | Define a new Rule without early cutoff -define - :: IdeRule k v - => (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules () -define op = defineEarlyCutoff $ \k v -> (Nothing,) <$> op k v - --- | Request a Rule result if available -use :: IdeRule k v - => k -> NormalizedFilePath -> Action (Maybe v) -use key file = head <$> uses key [file] - --- | Request a Rule result, it not available return the last computed result, if any, which may be stale -useWithStale :: IdeRule k v - => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping)) -useWithStale key file = head <$> usesWithStale key [file] - --- | Request a Rule result, it not available return the last computed result which may be stale. --- Errors out if none available. -useWithStale_ :: IdeRule k v - => k -> NormalizedFilePath -> Action (v, PositionMapping) -useWithStale_ key file = head <$> usesWithStale_ key [file] - --- | Plural version of 'useWithStale_' -usesWithStale_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [(v, PositionMapping)] -usesWithStale_ key files = do - res <- usesWithStale key files - case sequence res of - Nothing -> liftIO $ throwIO $ BadDependency (show key) - Just v -> return v - -newtype IdeAction a = IdeAction { runIdeActionT :: (ReaderT ShakeExtras IO) a } - deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad) - --- | IdeActions are used when we want to return a result immediately, even if it --- is stale Useful for UI actions like hover, completion where we don't want to --- block. -runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a -runIdeAction _herald s i = runReaderT (runIdeActionT i) s - -askShake :: IdeAction ShakeExtras -askShake = ask - -mkUpdater :: IORef NameCache -> NameCacheUpdater -mkUpdater ref = NCU (upNameCache ref) - --- | A (maybe) stale result now, and an up to date one later -data FastResult a = FastResult { stale :: Maybe (a,PositionMapping), uptoDate :: IO (Maybe a) } - --- | Lookup value in the database and return with the stale value immediately --- Will queue an action to refresh the value. --- Might block the first time the rule runs, but never blocks after that. -useWithStaleFast :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping)) -useWithStaleFast key file = stale <$> useWithStaleFast' key file - --- | Same as useWithStaleFast but lets you wait for an up to date result -useWithStaleFast' :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (FastResult v) -useWithStaleFast' key file = do - -- This lookup directly looks up the key in the shake database and - -- returns the last value that was computed for this key without - -- checking freshness. - - -- Async trigger the key to be built anyway because we want to - -- keep updating the value in the key. - wait <- delayedAction $ mkDelayedAction ("C:" ++ show key) Debug $ use key file - - s@ShakeExtras{state} <- askShake - r <- liftIO $ getValues state key file - liftIO $ case r of - -- block for the result if we haven't computed before - Nothing -> do - -- Check if we can get a stale value from disk - res <- lastValueIO s key file - case res of - Nothing -> do - a <- wait - pure $ FastResult ((,zeroMapping) <$> a) (pure a) - Just _ -> pure $ FastResult res wait - -- Otherwise, use the computed value even if it's out of date. - Just _ -> do - res <- lastValueIO s key file - pure $ FastResult res wait - -useNoFile :: IdeRule k v => k -> Action (Maybe v) -useNoFile key = use key emptyFilePath - -use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v -use_ key file = head <$> uses_ key [file] - -useNoFile_ :: IdeRule k v => k -> Action v -useNoFile_ key = use_ key emptyFilePath - -uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v] -uses_ key files = do - res <- uses key files - case sequence res of - Nothing -> liftIO $ throwIO $ BadDependency (show key) - Just v -> return v - --- | Plural version of 'use' -uses :: IdeRule k v - => k -> [NormalizedFilePath] -> Action [Maybe v] -uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files) - --- | Return the last computed result which might be stale. -usesWithStale :: IdeRule k v - => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)] -usesWithStale key files = do - _ <- apply (map (Q . (key,)) files) - -- We don't look at the result of the 'apply' since 'lastValue' will - -- return the most recent successfully computed value regardless of - -- whether the rule succeeded or not. - mapM (lastValue key) files - --- | Define a new Rule with early cutoff -defineEarlyCutoff - :: IdeRule k v - => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v)) - -> Rules () -defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do - extras@ShakeExtras{state, inProgress} <- getShakeExtras - -- don't do progress for GetFileExists, as there are lots of non-nodes for just that one key - (if show key == "GetFileExists" then id else withProgressVar inProgress file) $ do - val <- case old of - Just old | mode == RunDependenciesSame -> do - v <- liftIO $ getValues state key file - case v of - -- No changes in the dependencies and we have - -- an existing result. - Just (v, diags) -> do - updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) $ Vector.toList diags - return $ Just $ RunResult ChangedNothing old $ A v - _ -> return Nothing - _ -> return Nothing - case val of - Just res -> return res - Nothing -> do - (bs, (diags, res)) <- actionCatch - (do v <- op key file; liftIO $ evaluate $ force v) $ - \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) - modTime <- liftIO $ (currentValue . fst =<<) <$> getValues state GetModificationTime file - (bs, res) <- case res of - Nothing -> do - staleV <- liftIO $ getValues state key file - pure $ case staleV of - Nothing -> (toShakeValue ShakeResult bs, Failed False) - Just v -> case v of - (Succeeded ver v, _) -> - (toShakeValue ShakeStale bs, Stale Nothing ver v) - (Stale d ver v, _) -> - (toShakeValue ShakeStale bs, Stale d ver v) - (Failed b, _) -> - (toShakeValue ShakeResult bs, Failed b) - Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v) - liftIO $ setValues state key file res (Vector.fromList diags) - updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags - let eq = case (bs, fmap decodeShakeValue old) of - (ShakeResult a, Just (ShakeResult b)) -> a == b - (ShakeStale a, Just (ShakeStale b)) -> a == b - -- If we do not have a previous result - -- or we got ShakeNoCutoff we always return False. - _ -> False - return $ RunResult - (if eq then ChangedRecomputeSame else ChangedRecomputeDiff) - (encodeShakeValue bs) $ - A res - where - withProgressVar :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b - withProgressVar var file = actionBracket (f succ) (const $ f pred) . const - -- This functions are deliberately eta-expanded to avoid space leaks. - -- Do not remove the eta-expansion without profiling a session with at - -- least 1000 modifications. - where f shift = modifyVar_ var $ \x -> evaluate $ HMap.insertWith (\_ x -> shift x) file (shift 0) x - -isSuccess :: RunResult (A v) -> Bool -isSuccess (RunResult _ _ (A Failed{})) = False -isSuccess _ = True - --- | Rule type, input file -data QDisk k = QDisk k NormalizedFilePath - deriving (Eq, Generic) - -instance Hashable k => Hashable (QDisk k) - -instance NFData k => NFData (QDisk k) - -instance Binary k => Binary (QDisk k) - -instance Show k => Show (QDisk k) where - show (QDisk k file) = - show k ++ "; " ++ fromNormalizedFilePath file - -type instance RuleResult (QDisk k) = Bool - -data OnDiskRule = OnDiskRule - { getHash :: Action BS.ByteString - -- This is used to figure out if the state on disk corresponds to the state in the Shake - -- database and we can therefore avoid rerunning. Often this can just be the file hash but - -- in some cases we can be more aggressive, e.g., for GHC interface files this can be the ABI hash which - -- is more stable than the hash of the interface file. - -- An empty bytestring indicates that the state on disk is invalid, e.g., files are missing. - -- We do not use a Maybe since we have to deal with encoding things into a ByteString anyway in the Shake DB. - , runRule :: Action (IdeResult BS.ByteString) - -- The actual rule code which produces the new hash (or Nothing if the rule failed) and the diagnostics. - } - --- This is used by the DAML compiler for incremental builds. Right now this is not used by --- ghcide itself but that might change in the future. --- The reason why this code lives in ghcide and in particular in this module is that it depends quite heavily on --- the internals of this module that we do not want to expose. -defineOnDisk - :: (Shake.ShakeValue k, RuleResult k ~ ()) - => (k -> NormalizedFilePath -> OnDiskRule) - -> Rules () -defineOnDisk act = addBuiltinRule noLint noIdentity $ - \(QDisk key file) (mbOld :: Maybe BS.ByteString) mode -> do - extras <- getShakeExtras - let OnDiskRule{..} = act key file - let validateHash h - | BS.null h = Nothing - | otherwise = Just h - let runAct = actionCatch runRule $ - \(e :: SomeException) -> pure ([ideErrorText file $ T.pack $ displayException e | not $ isBadDependency e], Nothing) - case mbOld of - Nothing -> do - (diags, mbHash) <- runAct - updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags - pure $ RunResult ChangedRecomputeDiff (fromMaybe "" mbHash) (isJust mbHash) - Just old -> do - current <- validateHash <$> (actionCatch getHash $ \(_ :: SomeException) -> pure "") - if mode == RunDependenciesSame && Just old == current && not (BS.null old) - then - -- None of our dependencies changed, we’ve had a successful run before and - -- the state on disk matches the state in the Shake database. - pure $ RunResult ChangedNothing (fromMaybe "" current) (isJust current) - else do - (diags, mbHash) <- runAct - updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags - let change - | mbHash == Just old = ChangedRecomputeSame - | otherwise = ChangedRecomputeDiff - pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash) - -needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action () -needOnDisk k file = do - successfull <- apply1 (QDisk k file) - liftIO $ unless successfull $ throwIO $ BadDependency (show k) - -needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action () -needOnDisks k files = do - successfulls <- apply $ map (QDisk k) files - liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k) - -updateFileDiagnostics :: MonadIO m - => NormalizedFilePath - -> Key - -> ShakeExtras - -> [(ShowDiagnostic,Diagnostic)] -- ^ current results - -> m () -updateFileDiagnostics fp k ShakeExtras{logger, diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, lspEnv} current = liftIO $ do - modTime <- (currentValue . fst =<<) <$> getValues state GetModificationTime fp - let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current - uri = filePathToUri' fp - ver = vfsVersion =<< modTime - updateDiagnosticsWithForcing new store = do - store' <- evaluate $ setStageDiagnostics uri ver (T.pack $ show k) new store - new' <- evaluate $ getUriDiagnostics uri store' - return (store', new') - mask_ $ do - -- Mask async exceptions to ensure that updated diagnostics are always - -- published. Otherwise, we might never publish certain diagnostics if - -- an exception strikes between modifyVar but before - -- publishDiagnosticsNotification. - newDiags <- modifyVar diagnostics $ updateDiagnosticsWithForcing $ map snd currentShown - _ <- modifyVar hiddenDiagnostics $ updateDiagnosticsWithForcing $ map snd currentHidden - let uri = filePathToUri' fp - let delay = if null newDiags then 0.1 else 0 - registerEvent debouncer delay uri $ do - mask_ $ modifyVar_ publishedDiagnostics $ \published -> do - let lastPublish = HMap.lookupDefault [] uri published - when (lastPublish /= newDiags) $ case lspEnv of - Nothing -> -- Print an LSP event. - logInfo logger $ showDiagnosticsColored $ map (fp,ShowDiag,) newDiags - Just env -> LSP.runLspT env $ - LSP.sendNotification LSP.STextDocumentPublishDiagnostics $ - LSP.PublishDiagnosticsParams (fromNormalizedUri uri) ver (List newDiags) - pure $! HMap.insert uri newDiags published - -newtype Priority = Priority Double - -setPriority :: Priority -> Action () -setPriority (Priority p) = reschedule p - -ideLogger :: IdeState -> Logger -ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger - -actionLogger :: Action Logger -actionLogger = do - ShakeExtras{logger} <- getShakeExtras - return logger - - -getDiagnosticsFromStore :: StoreItem -> [Diagnostic] -getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags - - --- | Sets the diagnostics for a file and compilation step --- if you want to clear the diagnostics call this with an empty list -setStageDiagnostics - :: NormalizedUri - -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited - -> T.Text - -> [LSP.Diagnostic] - -> DiagnosticStore - -> DiagnosticStore -setStageDiagnostics uri ver stage diags ds = updateDiagnostics ds uri ver updatedDiags - where - updatedDiags = Map.singleton (Just stage) (SL.toSortedList diags) - -getAllDiagnostics :: - DiagnosticStore -> - [FileDiagnostic] -getAllDiagnostics = - concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . HMap.toList - -getUriDiagnostics :: - NormalizedUri -> - DiagnosticStore -> - [LSP.Diagnostic] -getUriDiagnostics uri ds = - maybe [] getDiagnosticsFromStore $ - HMap.lookup uri ds - -filterDiagnostics :: - (NormalizedFilePath -> Bool) -> - DiagnosticStore -> - DiagnosticStore -filterDiagnostics keep = - HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri) - -filterVersionMap - :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion) - -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a) - -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a) -filterVersionMap = - HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep - -updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO () -updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do - modifyVar_ positionMapping $ \allMappings -> do - let uri = toNormalizedUri _uri - let mappingForUri = HMap.lookupDefault Map.empty uri allMappings - let (_, updatedMapping) = - -- Very important to use mapAccum here so that the tails of - -- each mapping can be shared, otherwise quadratic space is - -- used which is evident in long running sessions. - Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc))) - zeroMapping - (Map.insert _version (shared_change, zeroMapping) mappingForUri) - pure $! HMap.insert uri updatedMapping allMappings - where - shared_change = mkDelta changes +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TypeFamilies #-} + +-- | A Shake implementation of the compiler service. +-- +-- There are two primary locations where data lives, and both of +-- these contain much the same data: +-- +-- * The Shake database (inside 'shakeDb') stores a map of shake keys +-- to shake values. In our case, these are all of type 'Q' to 'A'. +-- During a single run all the values in the Shake database are consistent +-- so are used in conjunction with each other, e.g. in 'uses'. +-- +-- * The 'Values' type stores a map of keys to values. These values are +-- always stored as real Haskell values, whereas Shake serialises all 'A' values +-- between runs. To deserialise a Shake value, we just consult Values. +module Development.IDE.Core.Shake( + IdeState, shakeExtras, + ShakeExtras(..), getShakeExtras, getShakeExtrasRules, + KnownTargets, Target(..), toKnownFiles, + IdeRule, IdeResult, + GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics), + shakeOpen, shakeShut, + shakeRestart, + shakeEnqueue, + shakeProfile, + use, useNoFile, uses, useWithStaleFast, useWithStaleFast', delayedAction, + FastResult(..), + use_, useNoFile_, uses_, + useWithStale, usesWithStale, + useWithStale_, usesWithStale_, + BadDependency(..), + RuleBody(..), + define, defineNoDiagnostics, + defineEarlyCutoff, + defineOnDisk, needOnDisk, needOnDisks, + getDiagnostics, + mRunLspT, mRunLspTCallback, + getHiddenDiagnostics, + IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction, + getIdeGlobalExtras, + getIdeOptions, + getIdeOptionsIO, + GlobalIdeOptions(..), + getClientConfig, + getPluginConfig, + garbageCollect, + knownTargets, + setPriority, + ideLogger, + actionLogger, + FileVersion(..), + Priority(..), + updatePositionMapping, + deleteValue, + OnDiskRule(..), + WithProgressFunc, WithIndefiniteProgressFunc, + ProgressEvent(..), + DelayedAction, mkDelayedAction, + IdeAction(..), runIdeAction, + mkUpdater, + -- Exposed for testing. + Q(..), + IndexQueue, + HieDb, + HieDbWriter(..), + VFSHandle(..), + addPersistentRule + ) where + +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Concurrent.Strict +import Control.DeepSeq +import Control.Monad.Extra +import Control.Monad.IO.Class +import Control.Monad.Reader +import qualified Control.Monad.STM as STM +import Control.Monad.Trans.Maybe +import qualified Data.ByteString.Char8 as BS +import Data.Dynamic +import qualified Data.HashMap.Strict as HMap +import Data.Hashable +import Data.List.Extra (partition, takeEnd) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.Set as Set +import qualified Data.SortedList as SL +import qualified Data.Text as T +import Data.Time +import Data.Traversable +import Data.Tuple.Extra +import Data.Typeable +import Data.Unique +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Development.IDE.Core.Debouncer +import Development.IDE.Core.PositionMapping +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Tracing +import Development.IDE.GHC.Compat (NameCacheUpdater (..), + upNameCache) +import Development.IDE.GHC.Orphans () +import Development.IDE.Types.Action +import Development.IDE.Types.Diagnostics +import Development.IDE.Types.Exports +import Development.IDE.Types.KnownTargets +import Development.IDE.Types.Location +import Development.IDE.Types.Logger hiding (Priority) +import qualified Development.IDE.Types.Logger as Logger +import Development.IDE.Types.Options +import Development.IDE.Types.Shake +import Development.Shake hiding (Info, ShakeValue, + doesFileExist) +import qualified Development.Shake as Shake +import Development.Shake.Classes +import Development.Shake.Database +import Development.Shake.Rule +import GHC.Generics +import Language.LSP.Diagnostics +import qualified Language.LSP.Server as LSP +import Language.LSP.Types +import qualified Language.LSP.Types as LSP +import Language.LSP.VFS +import System.FilePath hiding (makeRelative) +import System.Time.Extra + +import Data.IORef +import GHC.Fingerprint +import Language.LSP.Types.Capabilities +import NameCache +import OpenTelemetry.Eventlog +import PrelInfo +import UniqSupply + +import Control.Exception.Extra hiding (bracket_) +import Data.Default +import HieDb.Types +import Ide.Plugin.Config +import qualified Ide.PluginUtils as HLS +import Ide.Types (PluginId) +import UnliftIO.Exception (bracket_) + +-- | We need to serialize writes to the database, so we send any function that +-- needs to write to the database over the channel, where it will be picked up by +-- a worker thread. +data HieDbWriter + = HieDbWriter + { indexQueue :: IndexQueue + , indexPending :: TVar (HMap.HashMap NormalizedFilePath Fingerprint) -- ^ Avoid unnecessary/out of date indexing + , indexCompleted :: TVar Int -- ^ to report progress + , indexProgressToken :: Var (Maybe LSP.ProgressToken) + -- ^ This is a Var instead of a TVar since we need to do IO to initialise/update, so we need a lock + } + +-- | Actions to queue up on the index worker thread +type IndexQueue = TQueue (HieDb -> IO ()) + +-- information we stash inside the shakeExtra field +data ShakeExtras = ShakeExtras + { --eventer :: LSP.FromServerMessage -> IO () + lspEnv :: Maybe (LSP.LanguageContextEnv Config) + ,debouncer :: Debouncer NormalizedUri + ,logger :: Logger + ,globals :: Var (HMap.HashMap TypeRep Dynamic) + ,state :: Var Values + ,diagnostics :: Var DiagnosticStore + ,hiddenDiagnostics :: Var DiagnosticStore + ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic]) + -- ^ This represents the set of diagnostics that we have published. + -- Due to debouncing not every change might get published. + ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping))) + -- ^ Map from a text document version to a PositionMapping that describes how to map + -- positions in a version of that document to positions in the latest version + -- First mapping is delta from previous version and second one is an + -- accumlation of all previous mappings. + ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int) + -- ^ How many rules are running for each file + ,progressUpdate :: ProgressEvent -> IO () + ,ideTesting :: IdeTesting + -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants + ,session :: MVar ShakeSession + -- ^ Used in the GhcSession rule to forcefully restart the session after adding a new component + ,restartShakeSession :: [DelayedAction ()] -> IO () + ,ideNc :: IORef NameCache + -- | A mapping of module name to known target (or candidate targets, if missing) + ,knownTargetsVar :: Var (Hashed KnownTargets) + -- | A mapping of exported identifiers for local modules. Updated on kick + ,exportsMap :: Var ExportsMap + -- | A work queue for actions added via 'runInShakeSession' + ,actionQueue :: ActionQueue + ,clientCapabilities :: ClientCapabilities + , hiedb :: HieDb -- ^ Use only to read. + , hiedbWriter :: HieDbWriter -- ^ use to write + , persistentKeys :: Var (HMap.HashMap Key GetStalePersistent) + -- ^ Registery for functions that compute/get "stale" results for the rule + -- (possibly from disk) + , vfs :: VFSHandle + , defaultConfig :: Config + -- ^ Default HLS config, only relevant if the client does not provide any Config + } + +type WithProgressFunc = forall a. + T.Text -> LSP.ProgressCancellable -> ((LSP.ProgressAmount -> IO ()) -> IO a) -> IO a +type WithIndefiniteProgressFunc = forall a. + T.Text -> LSP.ProgressCancellable -> IO a -> IO a + +data ProgressEvent + = KickStarted + | KickCompleted + +type GetStalePersistent = NormalizedFilePath -> IdeAction (Maybe (Dynamic,PositionDelta,TextDocumentVersion)) + +getShakeExtras :: Action ShakeExtras +getShakeExtras = do + Just x <- getShakeExtra @ShakeExtras + return x + +getShakeExtrasRules :: Rules ShakeExtras +getShakeExtrasRules = do + Just x <- getShakeExtraRules @ShakeExtras + return x + +getClientConfig :: LSP.MonadLsp Config m => ShakeExtras -> m Config +getClientConfig ShakeExtras { defaultConfig } = + fromMaybe defaultConfig <$> HLS.getClientConfig + +getPluginConfig + :: LSP.MonadLsp Config m => ShakeExtras -> PluginId -> m PluginConfig +getPluginConfig extras plugin = do + config <- getClientConfig extras + return $ HLS.configForPlugin config plugin + +-- | Register a function that will be called to get the "stale" result of a rule, possibly from disk +-- This is called when we don't already have a result, or computing the rule failed. +-- The result of this function will always be marked as 'stale', and a 'proper' rebuild of the rule will +-- be queued if the rule hasn't run before. +addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,TextDocumentVersion))) -> Rules () +addPersistentRule k getVal = do + ShakeExtras{persistentKeys} <- getShakeExtrasRules + void $ liftIO $ modifyVar' persistentKeys $ HMap.insert (Key k) (fmap (fmap (first3 toDyn)) . getVal) + +class Typeable a => IsIdeGlobal a where + + +-- | haskell-lsp manages the VFS internally and automatically so we cannot use +-- the builtin VFS without spawning up an LSP server. To be able to test things +-- like `setBufferModified` we abstract over the VFS implementation. +data VFSHandle = VFSHandle + { getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile) + -- ^ get the contents of a virtual file + , setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ()) + -- ^ set a specific file to a value. If Nothing then we are ignoring these + -- signals anyway so can just say something was modified + } +instance IsIdeGlobal VFSHandle + +addIdeGlobal :: IsIdeGlobal a => a -> Rules () +addIdeGlobal x = do + extras <- getShakeExtrasRules + liftIO $ addIdeGlobalExtras extras x + +addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO () +addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) = + void $ liftIO $ modifyVarIO' globals $ \mp -> case HMap.lookup ty mp of + Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty + Nothing -> return $! HMap.insert ty (toDyn x) mp + + +getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a +getIdeGlobalExtras ShakeExtras{globals} = do + let typ = typeRep (Proxy :: Proxy a) + x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals + case x of + Just x + | Just x <- fromDynamic x -> pure x + | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")" + Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ + +getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a +getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras + +getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a +getIdeGlobalState = getIdeGlobalExtras . shakeExtras + + +newtype GlobalIdeOptions = GlobalIdeOptions IdeOptions +instance IsIdeGlobal GlobalIdeOptions + +getIdeOptions :: Action IdeOptions +getIdeOptions = do + GlobalIdeOptions x <- getIdeGlobalAction + return x + +getIdeOptionsIO :: ShakeExtras -> IO IdeOptions +getIdeOptionsIO ide = do + GlobalIdeOptions x <- getIdeGlobalExtras ide + return x + +-- | Return the most recent, potentially stale, value and a PositionMapping +-- for the version of that value. +lastValueIO :: IdeRule k v => ShakeExtras -> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping)) +lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do + hm <- readVar state + allMappings <- readVar positionMapping + + let readPersistent + | IdeTesting testing <- ideTesting s -- Don't read stale persistent values in tests + , testing = pure Nothing + | otherwise = do + pmap <- readVar persistentKeys + mv <- runMaybeT $ do + liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP UP PERSISTENT FOR: " ++ show k + f <- MaybeT $ pure $ HMap.lookup (Key k) pmap + (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file + MaybeT $ pure $ (,del,ver) <$> fromDynamic dv + case mv of + Nothing -> do + void $ modifyVar' state $ HMap.alter (alterValue $ Failed True) (file,Key k) + return Nothing + Just (v,del,ver) -> do + void $ modifyVar' state $ HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (file,Key k) + return $ Just (v,addDelta del $ mappingForVersion allMappings file ver) + + -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics + alterValue new Nothing = Just (ValueWithDiagnostics new mempty) -- If it wasn't in the map, give it empty diagnostics + alterValue new (Just old@(ValueWithDiagnostics val diags)) = Just $ case val of + -- Old failed, we can update it preserving diagnostics + Failed{} -> ValueWithDiagnostics new diags + -- Something already succeeded before, leave it alone + _ -> old + + case HMap.lookup (file,Key k) hm of + Nothing -> readPersistent + Just (ValueWithDiagnostics v _) -> case v of + Succeeded ver (fromDynamic -> Just v) -> pure (Just (v, mappingForVersion allMappings file ver)) + Stale del ver (fromDynamic -> Just v) -> pure (Just (v, maybe id addDelta del $ mappingForVersion allMappings file ver)) + Failed p | not p -> readPersistent + _ -> pure Nothing + +-- | Return the most recent, potentially stale, value and a PositionMapping +-- for the version of that value. +lastValue :: IdeRule k v => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping)) +lastValue key file = do + s <- getShakeExtras + liftIO $ lastValueIO s key file + +valueVersion :: Value v -> Maybe TextDocumentVersion +valueVersion = \case + Succeeded ver _ -> Just ver + Stale _ ver _ -> Just ver + Failed _ -> Nothing + +mappingForVersion + :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping)) + -> NormalizedFilePath + -> TextDocumentVersion + -> PositionMapping +mappingForVersion allMappings file ver = + maybe zeroMapping snd $ + Map.lookup ver =<< + HMap.lookup (filePathToUri' file) allMappings + +type IdeRule k v = + ( Shake.RuleResult k ~ v + , Shake.ShakeValue k + , Show v + , Typeable v + , NFData v + ) + +-- | A live Shake session with the ability to enqueue Actions for running. +-- Keeps the 'ShakeDatabase' open, so at most one 'ShakeSession' per database. +newtype ShakeSession = ShakeSession + { cancelShakeSession :: IO () + -- ^ Closes the Shake session + } + +-- | A Shake database plus persistent store. Can be thought of as storing +-- mappings from @(FilePath, k)@ to @RuleResult k@. +data IdeState = IdeState + {shakeDb :: ShakeDatabase + ,shakeSession :: MVar ShakeSession + ,shakeClose :: IO () + ,shakeExtras :: ShakeExtras + ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) + ,stopProgressReporting :: IO () + } + + + +-- This is debugging code that generates a series of profiles, if the Boolean is true +shakeDatabaseProfileIO :: Maybe FilePath -> IO(ShakeDatabase -> IO (Maybe FilePath)) +shakeDatabaseProfileIO mbProfileDir = do + profileStartTime <- formatTime defaultTimeLocale "%Y%m%d-%H%M%S" <$> getCurrentTime + profileCounter <- newVar (0::Int) + return $ \shakeDb -> + for mbProfileDir $ \dir -> do + count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y) + let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) <.> "html" + shakeProfileDatabase shakeDb $ dir file + return (dir file) + +setValues :: IdeRule k v + => Var Values + -> k + -> NormalizedFilePath + -> Value v + -> Vector FileDiagnostic + -> IO () +setValues state key file val diags = + void $ modifyVar' state $ HMap.insert (file, Key key) (ValueWithDiagnostics (fmap toDyn val) diags) + + +-- | Delete the value stored for a given ide build key +deleteValue + :: (Typeable k, Hashable k, Eq k, Show k) + => ShakeExtras + -> k + -> NormalizedFilePath + -> IO () +deleteValue ShakeExtras{state} key file = void $ modifyVar' state $ HMap.delete (file, Key key) + +-- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value. +getValues :: + forall k v. + IdeRule k v => + Var Values -> + k -> + NormalizedFilePath -> + IO (Maybe (Value v, Vector FileDiagnostic)) +getValues state key file = do + vs <- readVar state + case HMap.lookup (file, Key key) vs of + Nothing -> pure Nothing + Just (ValueWithDiagnostics v diagsV) -> do + let r = fmap (fromJust . fromDynamic @v) v + -- Force to make sure we do not retain a reference to the HashMap + -- and we blow up immediately if the fromJust should fail + -- (which would be an internal error). + evaluate (r `seqValue` Just (r, diagsV)) + +-- | Get all the files in the project +knownTargets :: Action (Hashed KnownTargets) +knownTargets = do + ShakeExtras{knownTargetsVar} <- getShakeExtras + liftIO $ readVar knownTargetsVar + +-- | Seq the result stored in the Shake value. This only +-- evaluates the value to WHNF not NF. We take care of the latter +-- elsewhere and doing it twice is expensive. +seqValue :: Value v -> b -> b +seqValue v b = case v of + Succeeded ver v -> rnf ver `seq` v `seq` b + Stale d ver v -> rnf d `seq` rnf ver `seq` v `seq` b + Failed _ -> b + +-- | Open a 'IdeState', should be shut using 'shakeShut'. +shakeOpen :: Maybe (LSP.LanguageContextEnv Config) + -> Config + -> Logger + -> Debouncer NormalizedUri + -> Maybe FilePath + -> IdeReportProgress + -> IdeTesting + -> HieDb + -> IndexQueue + -> VFSHandle + -> ShakeOptions + -> Rules () + -> IO IdeState +shakeOpen lspEnv defaultConfig logger debouncer + shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo + + inProgress <- newVar HMap.empty + us <- mkSplitUniqSupply 'r' + ideNc <- newIORef (initNameCache us knownKeyNames) + (shakeExtras, stopProgressReporting) <- do + globals <- newVar HMap.empty + state <- newVar HMap.empty + diagnostics <- newVar mempty + hiddenDiagnostics <- newVar mempty + publishedDiagnostics <- newVar mempty + positionMapping <- newVar HMap.empty + knownTargetsVar <- newVar $ hashed HMap.empty + let restartShakeSession = shakeRestart ideState + let session = shakeSession + mostRecentProgressEvent <- newTVarIO KickCompleted + persistentKeys <- newVar HMap.empty + let progressUpdate = atomically . writeTVar mostRecentProgressEvent + indexPending <- newTVarIO HMap.empty + indexCompleted <- newTVarIO 0 + indexProgressToken <- newVar Nothing + let hiedbWriter = HieDbWriter{..} + progressAsync <- async $ + when reportProgress $ + progressThread mostRecentProgressEvent inProgress + exportsMap <- newVar mempty + + actionQueue <- newQueue + + let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv + + pure (ShakeExtras{..}, cancel progressAsync) + (shakeDbM, shakeClose) <- + shakeOpenDatabase + opts { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts } + rules + shakeDb <- shakeDbM + initSession <- newSession shakeExtras shakeDb [] + shakeSession <- newMVar initSession + shakeDatabaseProfile <- shakeDatabaseProfileIO shakeProfileDir + let ideState = IdeState{..} + + IdeOptions{ optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled } <- getIdeOptionsIO shakeExtras + startTelemetry otProfilingEnabled logger $ state shakeExtras + + return ideState + where + -- The progress thread is a state machine with two states: + -- 1. Idle + -- 2. Reporting a kick event + -- And two transitions, modelled by 'ProgressEvent': + -- 1. KickCompleted - transitions from Reporting into Idle + -- 2. KickStarted - transitions from Idle into Reporting + progressThread mostRecentProgressEvent inProgress = progressLoopIdle + where + progressLoopIdle = do + atomically $ do + v <- readTVar mostRecentProgressEvent + case v of + KickCompleted -> STM.retry + KickStarted -> return () + asyncReporter <- async $ mRunLspT lspEnv lspShakeProgress + progressLoopReporting asyncReporter + progressLoopReporting asyncReporter = do + atomically $ do + v <- readTVar mostRecentProgressEvent + case v of + KickStarted -> STM.retry + KickCompleted -> return () + cancel asyncReporter + progressLoopIdle + + lspShakeProgress :: LSP.LspM config () + lspShakeProgress = do + -- first sleep a bit, so we only show progress messages if it's going to take + -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) + liftIO $ unless testing $ sleep 0.1 + u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique + + void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate + LSP.WorkDoneProgressCreateParams { _token = u } $ const (pure ()) + + bracket_ + (start u) + (stop u) + (loop u Nothing) + where + start id = LSP.sendNotification LSP.SProgress $ + LSP.ProgressParams + { _token = id + , _value = LSP.Begin $ WorkDoneProgressBeginParams + { _title = "Processing" + , _cancellable = Nothing + , _message = Nothing + , _percentage = Nothing + } + } + stop id = LSP.sendNotification LSP.SProgress + LSP.ProgressParams + { _token = id + , _value = LSP.End WorkDoneProgressEndParams + { _message = Nothing + } + } + sample = 0.1 + loop id prev = do + liftIO $ sleep sample + current <- liftIO $ readVar inProgress + let done = length $ filter (== 0) $ HMap.elems current + let todo = HMap.size current + let next = Just $ T.pack $ show done <> "/" <> show todo + when (next /= prev) $ + LSP.sendNotification LSP.SProgress $ + LSP.ProgressParams + { _token = id + , _value = LSP.Report $ LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = next + , _percentage = Nothing + } + } + loop id next + +shakeProfile :: IdeState -> FilePath -> IO () +shakeProfile IdeState{..} = shakeProfileDatabase shakeDb + +shakeShut :: IdeState -> IO () +shakeShut IdeState{..} = withMVar shakeSession $ \runner -> do + -- Shake gets unhappy if you try to close when there is a running + -- request so we first abort that. + void $ cancelShakeSession runner + shakeClose + stopProgressReporting + + +-- | This is a variant of withMVar where the first argument is run unmasked and if it throws +-- an exception, the previous value is restored while the second argument is executed masked. +withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c +withMVar' var unmasked masked = uninterruptibleMask $ \restore -> do + a <- takeMVar var + b <- restore (unmasked a) `onException` putMVar var a + (a', c) <- masked b + putMVar var a' + pure c + + +mkDelayedAction :: String -> Logger.Priority -> Action a -> DelayedAction a +mkDelayedAction = DelayedAction Nothing + +-- | These actions are run asynchronously after the current action is +-- finished running. For example, to trigger a key build after a rule +-- has already finished as is the case with useWithStaleFast +delayedAction :: DelayedAction a -> IdeAction (IO a) +delayedAction a = do + extras <- ask + liftIO $ shakeEnqueue extras a + +-- | Restart the current 'ShakeSession' with the given system actions. +-- Any actions running in the current session will be aborted, +-- but actions added via 'shakeEnqueue' will be requeued. +shakeRestart :: IdeState -> [DelayedAction ()] -> IO () +shakeRestart IdeState{..} acts = + withMVar' + shakeSession + (\runner -> do + (stopTime,()) <- duration (cancelShakeSession runner) + res <- shakeDatabaseProfile shakeDb + let profile = case res of + Just fp -> ", profile saved at " <> fp + _ -> "" + let msg = T.pack $ "Restarting build session (aborting the previous one took " + ++ showDuration stopTime ++ profile ++ ")" + logDebug (logger shakeExtras) msg + notifyTestingLogMessage shakeExtras msg + ) + -- It is crucial to be masked here, otherwise we can get killed + -- between spawning the new thread and updating shakeSession. + -- See https://github.com/haskell/ghcide/issues/79 + (\() -> do + (,()) <$> newSession shakeExtras shakeDb acts) + +notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO () +notifyTestingLogMessage extras msg = do + (IdeTesting isTestMode) <- optTesting <$> getIdeOptionsIO extras + let notif = LSP.LogMessageParams LSP.MtLog msg + when isTestMode $ mRunLspT (lspEnv extras) $ LSP.sendNotification LSP.SWindowLogMessage notif + + +-- | Enqueue an action in the existing 'ShakeSession'. +-- Returns a computation to block until the action is run, propagating exceptions. +-- Assumes a 'ShakeSession' is available. +-- +-- Appropriate for user actions other than edits. +shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a) +shakeEnqueue ShakeExtras{actionQueue, logger} act = do + (b, dai) <- instantiateDelayedAction act + atomically $ pushQueue dai actionQueue + let wait' b = + waitBarrier b `catches` + [ Handler(\BlockedIndefinitelyOnMVar -> + fail $ "internal bug: forever blocked on MVar for " <> + actionName act) + , Handler (\e@AsyncCancelled -> do + logPriority logger Debug $ T.pack $ actionName act <> " was cancelled" + + atomically $ abortQueue dai actionQueue + throw e) + ] + return (wait' b >>= either throwIO return) + +-- | Set up a new 'ShakeSession' with a set of initial actions +-- Will crash if there is an existing 'ShakeSession' running. +newSession :: ShakeExtras -> ShakeDatabase -> [DelayedActionInternal] -> IO ShakeSession +newSession extras@ShakeExtras{..} shakeDb acts = do + reenqueued <- atomically $ peekInProgress actionQueue + let + -- A daemon-like action used to inject additional work + -- Runs actions from the work queue sequentially + pumpActionThread otSpan = do + d <- liftIO $ atomically $ popQueue actionQueue + void $ parallel [run otSpan d, pumpActionThread otSpan] + + -- TODO figure out how to thread the otSpan into defineEarlyCutoff + run _otSpan d = do + start <- liftIO offsetTime + getAction d + liftIO $ atomically $ doneQueue d actionQueue + runTime <- liftIO start + let msg = T.pack $ "finish: " ++ actionName d + ++ " (took " ++ showDuration runTime ++ ")" + liftIO $ do + logPriority logger (actionPriority d) msg + notifyTestingLogMessage extras msg + + workRun restore = withSpan "Shake session" $ \otSpan -> do + let acts' = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts) + res <- try @SomeException (restore $ shakeRunDatabase shakeDb acts') + let res' = case res of + Left e -> "exception: " <> displayException e + Right _ -> "completed" + let msg = T.pack $ "Finishing build session(" ++ res' ++ ")" + return $ do + logDebug logger msg + notifyTestingLogMessage extras msg + + -- Do the work in a background thread + workThread <- asyncWithUnmask workRun + + -- run the wrap up in a separate thread since it contains interruptible + -- commands (and we are not using uninterruptible mask) + _ <- async $ join $ wait workThread + + -- Cancelling is required to flush the Shake database when either + -- the filesystem or the Ghc configuration have changed + let cancelShakeSession :: IO () + cancelShakeSession = cancel workThread + + pure (ShakeSession{..}) + +instantiateDelayedAction + :: DelayedAction a + -> IO (Barrier (Either SomeException a), DelayedActionInternal) +instantiateDelayedAction (DelayedAction _ s p a) = do + u <- newUnique + b <- newBarrier + let a' = do + -- work gets reenqueued when the Shake session is restarted + -- it can happen that a work item finished just as it was reenqueud + -- in that case, skipping the work is fine + alreadyDone <- liftIO $ isJust <$> waitBarrierMaybe b + unless alreadyDone $ do + x <- actionCatch @SomeException (Right <$> a) (pure . Left) + -- ignore exceptions if the barrier has been filled concurrently + liftIO $ void $ try @SomeException $ signalBarrier b x + d' = DelayedAction (Just u) s p a' + return (b, d') + +mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m () +mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f +mRunLspT Nothing _ = pure () + +mRunLspTCallback :: Monad m + => Maybe (LSP.LanguageContextEnv c) + -> (LSP.LspT c m a -> LSP.LspT c m a) + -> m a + -> m a +mRunLspTCallback (Just lspEnv) f g = LSP.runLspT lspEnv $ f (lift g) +mRunLspTCallback Nothing _ g = g + +getDiagnostics :: IdeState -> IO [FileDiagnostic] +getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do + val <- readVar diagnostics + return $ getAllDiagnostics val + +getHiddenDiagnostics :: IdeState -> IO [FileDiagnostic] +getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do + val <- readVar hiddenDiagnostics + return $ getAllDiagnostics val + +-- | Clear the results for all files that do not match the given predicate. +garbageCollect :: (NormalizedFilePath -> Bool) -> Action () +garbageCollect keep = do + ShakeExtras{state, diagnostics,hiddenDiagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras + liftIO $ + do newState <- modifyVar' state $ HMap.filterWithKey (\(file, _) _ -> keep file) + void $ modifyVar' diagnostics $ filterDiagnostics keep + void $ modifyVar' hiddenDiagnostics $ filterDiagnostics keep + void $ modifyVar' publishedDiagnostics $ HMap.filterWithKey (\uri _ -> keep (fromUri uri)) + let versionsForFile = + HMap.fromListWith Set.union $ + mapMaybe (\((file, _key), ValueWithDiagnostics v _) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $ + HMap.toList newState + void $ modifyVar' positionMapping $ filterVersionMap versionsForFile + +-- | Define a new Rule without early cutoff +define + :: IdeRule k v + => (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules () +define op = defineEarlyCutoff $ Rule $ \k v -> (Nothing,) <$> op k v + +defineNoDiagnostics + :: IdeRule k v + => (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules () +defineNoDiagnostics op = defineEarlyCutoff $ RuleNoDiagnostics $ \k v -> (Nothing,) <$> op k v + +-- | Request a Rule result if available +use :: IdeRule k v + => k -> NormalizedFilePath -> Action (Maybe v) +use key file = head <$> uses key [file] + +-- | Request a Rule result, it not available return the last computed result, if any, which may be stale +useWithStale :: IdeRule k v + => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping)) +useWithStale key file = head <$> usesWithStale key [file] + +-- | Request a Rule result, it not available return the last computed result which may be stale. +-- Errors out if none available. +useWithStale_ :: IdeRule k v + => k -> NormalizedFilePath -> Action (v, PositionMapping) +useWithStale_ key file = head <$> usesWithStale_ key [file] + +-- | Plural version of 'useWithStale_' +usesWithStale_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [(v, PositionMapping)] +usesWithStale_ key files = do + res <- usesWithStale key files + case sequence res of + Nothing -> liftIO $ throwIO $ BadDependency (show key) + Just v -> return v + +newtype IdeAction a = IdeAction { runIdeActionT :: (ReaderT ShakeExtras IO) a } + deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad) + +-- | IdeActions are used when we want to return a result immediately, even if it +-- is stale Useful for UI actions like hover, completion where we don't want to +-- block. +runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a +runIdeAction _herald s i = runReaderT (runIdeActionT i) s + +askShake :: IdeAction ShakeExtras +askShake = ask + +mkUpdater :: IORef NameCache -> NameCacheUpdater +mkUpdater ref = NCU (upNameCache ref) + +-- | A (maybe) stale result now, and an up to date one later +data FastResult a = FastResult { stale :: Maybe (a,PositionMapping), uptoDate :: IO (Maybe a) } + +-- | Lookup value in the database and return with the stale value immediately +-- Will queue an action to refresh the value. +-- Might block the first time the rule runs, but never blocks after that. +useWithStaleFast :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping)) +useWithStaleFast key file = stale <$> useWithStaleFast' key file + +-- | Same as useWithStaleFast but lets you wait for an up to date result +useWithStaleFast' :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (FastResult v) +useWithStaleFast' key file = do + -- This lookup directly looks up the key in the shake database and + -- returns the last value that was computed for this key without + -- checking freshness. + + -- Async trigger the key to be built anyway because we want to + -- keep updating the value in the key. + wait <- delayedAction $ mkDelayedAction ("C:" ++ show key) Debug $ use key file + + s@ShakeExtras{state} <- askShake + r <- liftIO $ getValues state key file + liftIO $ case r of + -- block for the result if we haven't computed before + Nothing -> do + -- Check if we can get a stale value from disk + res <- lastValueIO s key file + case res of + Nothing -> do + a <- wait + pure $ FastResult ((,zeroMapping) <$> a) (pure a) + Just _ -> pure $ FastResult res wait + -- Otherwise, use the computed value even if it's out of date. + Just _ -> do + res <- lastValueIO s key file + pure $ FastResult res wait + +useNoFile :: IdeRule k v => k -> Action (Maybe v) +useNoFile key = use key emptyFilePath + +use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v +use_ key file = head <$> uses_ key [file] + +useNoFile_ :: IdeRule k v => k -> Action v +useNoFile_ key = use_ key emptyFilePath + +uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v] +uses_ key files = do + res <- uses key files + case sequence res of + Nothing -> liftIO $ throwIO $ BadDependency (show key) + Just v -> return v + +-- | Plural version of 'use' +uses :: IdeRule k v + => k -> [NormalizedFilePath] -> Action [Maybe v] +uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files) + +-- | Return the last computed result which might be stale. +usesWithStale :: IdeRule k v + => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)] +usesWithStale key files = do + _ <- apply (map (Q . (key,)) files) + -- We don't look at the result of the 'apply' since 'lastValue' will + -- return the most recent successfully computed value regardless of + -- whether the rule succeeded or not. + mapM (lastValue key) files + +data RuleBody k v + = Rule (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v)) + | RuleNoDiagnostics (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v)) + + +-- | Define a new Rule with early cutoff +defineEarlyCutoff + :: IdeRule k v + => RuleBody k v + -> Rules () +defineEarlyCutoff (Rule op) = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do + defineEarlyCutoff' True key file old mode $ op key file +defineEarlyCutoff (RuleNoDiagnostics op) = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do + defineEarlyCutoff' False key file old mode $ second (mempty,) <$> op key file + +defineEarlyCutoff' + :: IdeRule k v + => Bool -- ^ update diagnostics + -> k + -> NormalizedFilePath + -> Maybe BS.ByteString + -> RunMode + -> Action (Maybe BS.ByteString, IdeResult v) + -> Action (RunResult (A (RuleResult k))) +defineEarlyCutoff' doDiagnostics key file old mode action = do + extras@ShakeExtras{state, inProgress, logger} <- getShakeExtras + options <- getIdeOptions + (if optSkipProgress options key then id else withProgressVar inProgress file) $ do + val <- case old of + Just old | mode == RunDependenciesSame -> do + v <- liftIO $ getValues state key file + case v of + -- No changes in the dependencies and we have + -- an existing result. + Just (v, diags) -> do + when doDiagnostics $ + updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) $ Vector.toList diags + return $ Just $ RunResult ChangedNothing old $ A v + _ -> return Nothing + _ -> return Nothing + case val of + Just res -> return res + Nothing -> do + (bs, (diags, res)) <- actionCatch + (do v <- action; liftIO $ evaluate $ force v) $ + \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) + modTime <- liftIO $ (currentValue . fst =<<) <$> getValues state GetModificationTime file + (bs, res) <- case res of + Nothing -> do + staleV <- liftIO $ getValues state key file + pure $ case staleV of + Nothing -> (toShakeValue ShakeResult bs, Failed False) + Just v -> case v of + (Succeeded ver v, _) -> + (toShakeValue ShakeStale bs, Stale Nothing ver v) + (Stale d ver v, _) -> + (toShakeValue ShakeStale bs, Stale d ver v) + (Failed b, _) -> + (toShakeValue ShakeResult bs, Failed b) + Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v) + liftIO $ setValues state key file res (Vector.fromList diags) + if doDiagnostics + then updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags + else forM_ diags $ \d -> liftIO $ logWarning logger $ showDiagnosticsColored [d] + let eq = case (bs, fmap decodeShakeValue old) of + (ShakeResult a, Just (ShakeResult b)) -> a == b + (ShakeStale a, Just (ShakeStale b)) -> a == b + -- If we do not have a previous result + -- or we got ShakeNoCutoff we always return False. + _ -> False + return $ RunResult + (if eq then ChangedRecomputeSame else ChangedRecomputeDiff) + (encodeShakeValue bs) $ + A res + where + + withProgressVar :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b + withProgressVar var file = actionBracket (f succ) (const $ f pred) . const + -- This functions are deliberately eta-expanded to avoid space leaks. + -- Do not remove the eta-expansion without profiling a session with at + -- least 1000 modifications. + where f shift = void $ modifyVar' var $ HMap.insertWith (\_ x -> shift x) file (shift 0) + +isSuccess :: RunResult (A v) -> Bool +isSuccess (RunResult _ _ (A Failed{})) = False +isSuccess _ = True + +-- | Rule type, input file +data QDisk k = QDisk k NormalizedFilePath + deriving (Eq, Generic) + +instance Hashable k => Hashable (QDisk k) + +instance NFData k => NFData (QDisk k) + +instance Binary k => Binary (QDisk k) + +instance Show k => Show (QDisk k) where + show (QDisk k file) = + show k ++ "; " ++ fromNormalizedFilePath file + +type instance RuleResult (QDisk k) = Bool + +data OnDiskRule = OnDiskRule + { getHash :: Action BS.ByteString + -- This is used to figure out if the state on disk corresponds to the state in the Shake + -- database and we can therefore avoid rerunning. Often this can just be the file hash but + -- in some cases we can be more aggressive, e.g., for GHC interface files this can be the ABI hash which + -- is more stable than the hash of the interface file. + -- An empty bytestring indicates that the state on disk is invalid, e.g., files are missing. + -- We do not use a Maybe since we have to deal with encoding things into a ByteString anyway in the Shake DB. + , runRule :: Action (IdeResult BS.ByteString) + -- The actual rule code which produces the new hash (or Nothing if the rule failed) and the diagnostics. + } + +-- This is used by the DAML compiler for incremental builds. Right now this is not used by +-- ghcide itself but that might change in the future. +-- The reason why this code lives in ghcide and in particular in this module is that it depends quite heavily on +-- the internals of this module that we do not want to expose. +defineOnDisk + :: (Shake.ShakeValue k, RuleResult k ~ ()) + => (k -> NormalizedFilePath -> OnDiskRule) + -> Rules () +defineOnDisk act = addBuiltinRule noLint noIdentity $ + \(QDisk key file) (mbOld :: Maybe BS.ByteString) mode -> do + extras <- getShakeExtras + let OnDiskRule{..} = act key file + let validateHash h + | BS.null h = Nothing + | otherwise = Just h + let runAct = actionCatch runRule $ + \(e :: SomeException) -> pure ([ideErrorText file $ T.pack $ displayException e | not $ isBadDependency e], Nothing) + case mbOld of + Nothing -> do + (diags, mbHash) <- runAct + updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags + pure $ RunResult ChangedRecomputeDiff (fromMaybe "" mbHash) (isJust mbHash) + Just old -> do + current <- validateHash <$> (actionCatch getHash $ \(_ :: SomeException) -> pure "") + if mode == RunDependenciesSame && Just old == current && not (BS.null old) + then + -- None of our dependencies changed, we’ve had a successful run before and + -- the state on disk matches the state in the Shake database. + pure $ RunResult ChangedNothing (fromMaybe "" current) (isJust current) + else do + (diags, mbHash) <- runAct + updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags + let change + | mbHash == Just old = ChangedRecomputeSame + | otherwise = ChangedRecomputeDiff + pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash) + +needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action () +needOnDisk k file = do + successfull <- apply1 (QDisk k file) + liftIO $ unless successfull $ throwIO $ BadDependency (show k) + +needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action () +needOnDisks k files = do + successfulls <- apply $ map (QDisk k) files + liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k) + +updateFileDiagnostics :: MonadIO m + => NormalizedFilePath + -> Key + -> ShakeExtras + -> [(ShowDiagnostic,Diagnostic)] -- ^ current results + -> m () +updateFileDiagnostics fp k ShakeExtras{logger, diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, lspEnv} current = liftIO $ do + modTime <- (currentValue . fst =<<) <$> getValues state GetModificationTime fp + let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current + uri = filePathToUri' fp + ver = vfsVersion =<< modTime + update new store = + let store' = setStageDiagnostics uri ver (T.pack $ show k) new store + new' = getUriDiagnostics uri store' + in (store', new') + mask_ $ do + -- Mask async exceptions to ensure that updated diagnostics are always + -- published. Otherwise, we might never publish certain diagnostics if + -- an exception strikes between modifyVar but before + -- publishDiagnosticsNotification. + newDiags <- modifyVar diagnostics $ pure . update (map snd currentShown) + _ <- modifyVar hiddenDiagnostics $ pure . update (map snd currentHidden) + let uri = filePathToUri' fp + let delay = if null newDiags then 0.1 else 0 + registerEvent debouncer delay uri $ do + join $ mask_ $ modifyVar publishedDiagnostics $ \published -> do + let lastPublish = HMap.lookupDefault [] uri published + !published' = HMap.insert uri newDiags published + action = when (lastPublish /= newDiags) $ case lspEnv of + Nothing -> -- Print an LSP event. + logInfo logger $ showDiagnosticsColored $ map (fp,ShowDiag,) newDiags + Just env -> LSP.runLspT env $ + LSP.sendNotification LSP.STextDocumentPublishDiagnostics $ + LSP.PublishDiagnosticsParams (fromNormalizedUri uri) ver (List newDiags) + return (published', action) + +newtype Priority = Priority Double + +setPriority :: Priority -> Action () +setPriority (Priority p) = reschedule p + +ideLogger :: IdeState -> Logger +ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger + +actionLogger :: Action Logger +actionLogger = do + ShakeExtras{logger} <- getShakeExtras + return logger + + +getDiagnosticsFromStore :: StoreItem -> [Diagnostic] +getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags + + +-- | Sets the diagnostics for a file and compilation step +-- if you want to clear the diagnostics call this with an empty list +setStageDiagnostics + :: NormalizedUri + -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited + -> T.Text + -> [LSP.Diagnostic] + -> DiagnosticStore + -> DiagnosticStore +setStageDiagnostics uri ver stage diags ds = updateDiagnostics ds uri ver updatedDiags + where + updatedDiags = Map.singleton (Just stage) (SL.toSortedList diags) + +getAllDiagnostics :: + DiagnosticStore -> + [FileDiagnostic] +getAllDiagnostics = + concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . HMap.toList + +getUriDiagnostics :: + NormalizedUri -> + DiagnosticStore -> + [LSP.Diagnostic] +getUriDiagnostics uri ds = + maybe [] getDiagnosticsFromStore $ + HMap.lookup uri ds + +filterDiagnostics :: + (NormalizedFilePath -> Bool) -> + DiagnosticStore -> + DiagnosticStore +filterDiagnostics keep = + HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri) + +filterVersionMap + :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion) + -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a) + -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a) +filterVersionMap = + HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep + +updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO () +updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do + modifyVar_ positionMapping $ \allMappings -> do + let uri = toNormalizedUri _uri + let mappingForUri = HMap.lookupDefault Map.empty uri allMappings + let (_, updatedMapping) = + -- Very important to use mapAccum here so that the tails of + -- each mapping can be shared, otherwise quadratic space is + -- used which is evident in long running sessions. + Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc))) + zeroMapping + (Map.insert _version (shared_change, zeroMapping) mappingForUri) + pure $ HMap.insert uri updatedMapping allMappings + where + shared_change = mkDelta changes diff --git a/src/Development/IDE/Core/Tracing.hs b/src/Development/IDE/Core/Tracing.hs --- a/src/Development/IDE/Core/Tracing.hs +++ b/src/Development/IDE/Core/Tracing.hs @@ -1,217 +1,236 @@ -{-# LANGUAGE CPP #-} -#include "ghc-api-version.h" -module Development.IDE.Core.Tracing - ( otTracedHandler - , otTracedAction - , startTelemetry - , measureMemory - , getInstrumentCached - ,otTracedProvider,otSetUri) -where - -import Control.Concurrent.Async (Async, async) -import Control.Concurrent.Extra (Var, modifyVar_, newVar, - readVar, threadDelay) -import Control.Exception (evaluate) -import Control.Exception.Safe (catch, SomeException) -import Control.Monad (void, when, unless, forM_, forever, (>=>)) -import Control.Monad.Extra (whenJust) -import Control.Seq (r0, seqList, seqTuple2, using) -import Data.Dynamic (Dynamic) -import qualified Data.HashMap.Strict as HMap -import Data.IORef (modifyIORef', newIORef, - readIORef, writeIORef) -import Data.String (IsString (fromString)) -import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), - GhcSessionDeps (GhcSessionDeps), - GhcSessionIO (GhcSessionIO)) -import Development.IDE.Types.Logger (logInfo, Logger, logDebug) -import Development.IDE.Types.Shake (ValueWithDiagnostics(..), Key (..), Value, Values) -import Development.Shake (Action, actionBracket) -import Ide.PluginUtils (installSigUsr1Handler) -import Foreign.Storable (Storable (sizeOf)) -import HeapSize (recursiveSize, runHeapsize) -import Language.LSP.Types (NormalizedFilePath, - fromNormalizedFilePath) -import Numeric.Natural (Natural) -import OpenTelemetry.Eventlog (SpanInFlight, Synchronicity(Asynchronous), Instrument, addEvent, beginSpan, endSpan, - mkValueObserver, observe, - setTag, withSpan, withSpan_) -import Data.ByteString (ByteString) -import Data.Text.Encoding (encodeUtf8) -import Ide.Types (PluginId (..)) -import Development.IDE.Types.Location (Uri (..)) -import Control.Monad.IO.Unlift - --- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span. -otTracedHandler - :: MonadUnliftIO m - => String -- ^ Message type - -> String -- ^ Message label - -> (SpanInFlight -> m a) - -> m a -otTracedHandler requestType label act = - let !name = - if null label - then requestType - else requestType <> ":" <> show label - -- Add an event so all requests can be quickly seen in the viewer without searching - in do - runInIO <- askRunInIO - liftIO $ withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> runInIO (act sp)) - -otSetUri :: SpanInFlight -> Uri -> IO () -otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t) - --- | Trace a Shake action using opentelemetry. -otTracedAction - :: Show k - => k -- ^ The Action's Key - -> NormalizedFilePath -- ^ Path to the file the action was run for - -> (a -> Bool) -- ^ Did this action succeed? - -> Action a -- ^ The action - -> Action a -otTracedAction key file success act = actionBracket - (do - sp <- beginSpan (fromString (show key)) - setTag sp "File" (fromString $ fromNormalizedFilePath file) - return sp - ) - endSpan - (\sp -> do - res <- act - unless (success res) $ setTag sp "error" "1" - return res) - -#if MIN_GHC_API_VERSION(8,8,0) -otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a -#else -otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a -#endif -otTracedProvider (PluginId pluginName) provider act = do - runInIO <- askRunInIO - liftIO $ withSpan (provider <> " provider") $ \sp -> do - setTag sp "plugin" (encodeUtf8 pluginName) - runInIO act - -startTelemetry :: Bool -> Logger -> Var Values -> IO () -startTelemetry allTheTime logger stateRef = do - instrumentFor <- getInstrumentCached - mapCountInstrument <- mkValueObserver "values map count" - - installSigUsr1Handler $ do - logInfo logger "SIGUSR1 received: performing memory measurement" - performMeasurement logger stateRef instrumentFor mapCountInstrument - - when allTheTime $ void $ regularly (1 * seconds) $ - performMeasurement logger stateRef instrumentFor mapCountInstrument - where - seconds = 1000000 - - regularly :: Int -> IO () -> IO (Async ()) - regularly delay act = async $ forever (act >> threadDelay delay) - - -performMeasurement :: - Logger -> - Var Values -> - (Maybe Key -> IO OurValueObserver) -> - Instrument 'Asynchronous a m' -> - IO () -performMeasurement logger stateRef instrumentFor mapCountInstrument = do - withSpan_ "Measure length" $ readVar stateRef >>= observe mapCountInstrument . length - - values <- readVar stateRef - let keys = Key GhcSession - : Key GhcSessionDeps - : [ k | (_,k) <- HMap.keys values - -- do GhcSessionIO last since it closes over stateRef itself - , k /= Key GhcSession - , k /= Key GhcSessionDeps - , k /= Key GhcSessionIO - ] ++ [Key GhcSessionIO] - groupedForSharing <- evaluate (keys `using` seqList r0) - measureMemory logger [groupedForSharing] instrumentFor stateRef - `catch` \(e::SomeException) -> - logInfo logger ("MEMORY PROFILING ERROR: " <> fromString (show e)) - - -type OurValueObserver = Int -> IO () - -getInstrumentCached :: IO (Maybe Key -> IO OurValueObserver) -getInstrumentCached = do - instrumentMap <- newVar HMap.empty - mapBytesInstrument <- mkValueObserver "value map size_bytes" - - let instrumentFor k = do - mb_inst <- HMap.lookup k <$> readVar instrumentMap - case mb_inst of - Nothing -> do - instrument <- mkValueObserver (fromString (show k ++ " size_bytes")) - modifyVar_ instrumentMap (return . HMap.insert k instrument) - return $ observe instrument - Just v -> return $ observe v - return $ maybe (return $ observe mapBytesInstrument) instrumentFor - -whenNothing :: IO () -> IO (Maybe a) -> IO () -whenNothing act mb = mb >>= f - where f Nothing = act - f Just{} = return () - -measureMemory - :: Logger - -> [[Key]] -- ^ Grouping of keys for the sharing-aware analysis - -> (Maybe Key -> IO OurValueObserver) - -> Var Values - -> IO () -measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" $ do - values <- readVar stateRef - valuesSizeRef <- newIORef $ Just 0 - let !groupsOfGroupedValues = groupValues values - logDebug logger "STARTING MEMORY PROFILING" - forM_ groupsOfGroupedValues $ \groupedValues -> do - keepGoing <- readIORef valuesSizeRef - whenJust keepGoing $ \_ -> - whenNothing (writeIORef valuesSizeRef Nothing) $ - repeatUntilJust 3 $ do - -- logDebug logger (fromString $ show $ map fst groupedValues) - runHeapsize 25000000 $ - forM_ groupedValues $ \(k,v) -> withSpan ("Measure " <> (fromString $ show k)) $ \sp -> do - acc <- liftIO $ newIORef 0 - observe <- liftIO $ instrumentFor $ Just k - mapM_ (recursiveSize >=> \x -> liftIO (modifyIORef' acc (+ x))) v - size <- liftIO $ readIORef acc - let !byteSize = sizeOf (undefined :: Word) * size - setTag sp "size" (fromString (show byteSize ++ " bytes")) - () <- liftIO $ observe byteSize - liftIO $ modifyIORef' valuesSizeRef (fmap (+ byteSize)) - - mbValuesSize <- readIORef valuesSizeRef - case mbValuesSize of - Just valuesSize -> do - observe <- instrumentFor Nothing - observe valuesSize - logDebug logger "MEMORY PROFILING COMPLETED" - Nothing -> - logInfo logger "Memory profiling could not be completed: increase the size of your nursery (+RTS -Ax) and try again" - - where - groupValues :: Values -> [ [(Key, [Value Dynamic])] ] - groupValues values = - let !groupedValues = - [ [ (k, vv) - | k <- groupKeys - , let vv = [ v | ((_,k'), ValueWithDiagnostics v _) <- HMap.toList values , k == k'] - ] - | groupKeys <- groups - ] - -- force the spine of the nested lists - in groupedValues `using` seqList (seqList (seqTuple2 r0 (seqList r0))) - -repeatUntilJust :: Monad m => Natural -> m (Maybe a) -> m (Maybe a) -repeatUntilJust 0 _ = return Nothing -repeatUntilJust nattempts action = do - res <- action - case res of - Nothing -> repeatUntilJust (nattempts-1) action - Just{} -> return res +{-# LANGUAGE CPP #-} +#include "ghc-api-version.h" +module Development.IDE.Core.Tracing + ( otTracedHandler + , otTracedAction + , startTelemetry + , measureMemory + , getInstrumentCached + ,otTracedProvider,otSetUri) +where + +import Control.Concurrent.Async (Async, async) +import Control.Concurrent.Extra (Var, modifyVar_, newVar, + readVar, threadDelay) +import Control.Exception (evaluate) +import Control.Exception.Safe (SomeException, catch) +import Control.Monad (forM_, forever, unless, void, + when, (>=>)) +import Control.Monad.Extra (whenJust) +import Control.Monad.IO.Unlift +import Control.Seq (r0, seqList, seqTuple2, using) +import Data.ByteString (ByteString) +import Data.Dynamic (Dynamic) +import qualified Data.HashMap.Strict as HMap +import Data.IORef (modifyIORef', newIORef, + readIORef, writeIORef) +import Data.String (IsString (fromString)) +import Data.Text.Encoding (encodeUtf8) +import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), + GhcSessionDeps (GhcSessionDeps), + GhcSessionIO (GhcSessionIO)) +import Development.IDE.Types.Location (Uri (..)) +import Development.IDE.Types.Logger (Logger, logDebug, logInfo) +import Development.IDE.Types.Shake (Key (..), Value, + ValueWithDiagnostics (..), + Values) +import Development.Shake (Action, actionBracket) +import Foreign.Storable (Storable (sizeOf)) +import GHC.RTS.Flags +import HeapSize (recursiveSize, runHeapsize) +import Ide.PluginUtils (installSigUsr1Handler) +import Ide.Types (PluginId (..)) +import Language.LSP.Types (NormalizedFilePath, + fromNormalizedFilePath) +import Numeric.Natural (Natural) +import OpenTelemetry.Eventlog (Instrument, SpanInFlight, + Synchronicity (Asynchronous), + addEvent, beginSpan, endSpan, + mkValueObserver, observe, + setTag, withSpan, withSpan_) +import System.IO.Unsafe (unsafePerformIO) + +-- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span. +otTracedHandler + :: MonadUnliftIO m + => String -- ^ Message type + -> String -- ^ Message label + -> (SpanInFlight -> m a) + -> m a +otTracedHandler requestType label act = + let !name = + if null label + then requestType + else requestType <> ":" <> show label + -- Add an event so all requests can be quickly seen in the viewer without searching + in do + runInIO <- askRunInIO + liftIO $ withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> runInIO (act sp)) + +otSetUri :: SpanInFlight -> Uri -> IO () +otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t) + +{-# NOINLINE isTracingEnabled #-} +isTracingEnabled :: Bool +isTracingEnabled = unsafePerformIO $ do + flags <- getTraceFlags + case tracing flags of + TraceNone -> return False + _ -> return True + +-- | Trace a Shake action using opentelemetry. +otTracedAction + :: Show k + => k -- ^ The Action's Key + -> NormalizedFilePath -- ^ Path to the file the action was run for + -> (a -> Bool) -- ^ Did this action succeed? + -> Action a -- ^ The action + -> Action a +otTracedAction key file success act + | isTracingEnabled = + actionBracket + (do + sp <- beginSpan (fromString (show key)) + setTag sp "File" (fromString $ fromNormalizedFilePath file) + return sp + ) + endSpan + (\sp -> do + res <- act + unless (success res) $ setTag sp "error" "1" + return res) + | otherwise = act + +#if MIN_GHC_API_VERSION(8,8,0) +otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a +#else +otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a +#endif +otTracedProvider (PluginId pluginName) provider act = do + runInIO <- askRunInIO + liftIO $ withSpan (provider <> " provider") $ \sp -> do + setTag sp "plugin" (encodeUtf8 pluginName) + runInIO act + +startTelemetry :: Bool -> Logger -> Var Values -> IO () +startTelemetry allTheTime logger stateRef = do + instrumentFor <- getInstrumentCached + mapCountInstrument <- mkValueObserver "values map count" + + installSigUsr1Handler $ do + logInfo logger "SIGUSR1 received: performing memory measurement" + performMeasurement logger stateRef instrumentFor mapCountInstrument + + when allTheTime $ void $ regularly (1 * seconds) $ + performMeasurement logger stateRef instrumentFor mapCountInstrument + where + seconds = 1000000 + + regularly :: Int -> IO () -> IO (Async ()) + regularly delay act = async $ forever (act >> threadDelay delay) + + +performMeasurement :: + Logger -> + Var Values -> + (Maybe Key -> IO OurValueObserver) -> + Instrument 'Asynchronous a m' -> + IO () +performMeasurement logger stateRef instrumentFor mapCountInstrument = do + withSpan_ "Measure length" $ readVar stateRef >>= observe mapCountInstrument . length + + values <- readVar stateRef + let keys = Key GhcSession + : Key GhcSessionDeps + : [ k | (_,k) <- HMap.keys values + -- do GhcSessionIO last since it closes over stateRef itself + , k /= Key GhcSession + , k /= Key GhcSessionDeps + , k /= Key GhcSessionIO + ] ++ [Key GhcSessionIO] + groupedForSharing <- evaluate (keys `using` seqList r0) + measureMemory logger [groupedForSharing] instrumentFor stateRef + `catch` \(e::SomeException) -> + logInfo logger ("MEMORY PROFILING ERROR: " <> fromString (show e)) + + +type OurValueObserver = Int -> IO () + +getInstrumentCached :: IO (Maybe Key -> IO OurValueObserver) +getInstrumentCached = do + instrumentMap <- newVar HMap.empty + mapBytesInstrument <- mkValueObserver "value map size_bytes" + + let instrumentFor k = do + mb_inst <- HMap.lookup k <$> readVar instrumentMap + case mb_inst of + Nothing -> do + instrument <- mkValueObserver (fromString (show k ++ " size_bytes")) + modifyVar_ instrumentMap (return . HMap.insert k instrument) + return $ observe instrument + Just v -> return $ observe v + return $ maybe (return $ observe mapBytesInstrument) instrumentFor + +whenNothing :: IO () -> IO (Maybe a) -> IO () +whenNothing act mb = mb >>= f + where f Nothing = act + f Just{} = return () + +measureMemory + :: Logger + -> [[Key]] -- ^ Grouping of keys for the sharing-aware analysis + -> (Maybe Key -> IO OurValueObserver) + -> Var Values + -> IO () +measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" $ do + values <- readVar stateRef + valuesSizeRef <- newIORef $ Just 0 + let !groupsOfGroupedValues = groupValues values + logDebug logger "STARTING MEMORY PROFILING" + forM_ groupsOfGroupedValues $ \groupedValues -> do + keepGoing <- readIORef valuesSizeRef + whenJust keepGoing $ \_ -> + whenNothing (writeIORef valuesSizeRef Nothing) $ + repeatUntilJust 3 $ do + -- logDebug logger (fromString $ show $ map fst groupedValues) + runHeapsize 25000000 $ + forM_ groupedValues $ \(k,v) -> withSpan ("Measure " <> (fromString $ show k)) $ \sp -> do + acc <- liftIO $ newIORef 0 + observe <- liftIO $ instrumentFor $ Just k + mapM_ (recursiveSize >=> \x -> liftIO (modifyIORef' acc (+ x))) v + size <- liftIO $ readIORef acc + let !byteSize = sizeOf (undefined :: Word) * size + setTag sp "size" (fromString (show byteSize ++ " bytes")) + () <- liftIO $ observe byteSize + liftIO $ modifyIORef' valuesSizeRef (fmap (+ byteSize)) + + mbValuesSize <- readIORef valuesSizeRef + case mbValuesSize of + Just valuesSize -> do + observe <- instrumentFor Nothing + observe valuesSize + logDebug logger "MEMORY PROFILING COMPLETED" + Nothing -> + logInfo logger "Memory profiling could not be completed: increase the size of your nursery (+RTS -Ax) and try again" + + where + groupValues :: Values -> [ [(Key, [Value Dynamic])] ] + groupValues values = + let !groupedValues = + [ [ (k, vv) + | k <- groupKeys + , let vv = [ v | ((_,k'), ValueWithDiagnostics v _) <- HMap.toList values , k == k'] + ] + | groupKeys <- groups + ] + -- force the spine of the nested lists + in groupedValues `using` seqList (seqList (seqTuple2 r0 (seqList r0))) + +repeatUntilJust :: Monad m => Natural -> m (Maybe a) -> m (Maybe a) +repeatUntilJust 0 _ = return Nothing +repeatUntilJust nattempts action = do + res <- action + case res of + Nothing -> repeatUntilJust (nattempts-1) action + Just{} -> return res + diff --git a/src/Development/IDE/GHC/CPP.hs b/src/Development/IDE/GHC/CPP.hs --- a/src/Development/IDE/GHC/CPP.hs +++ b/src/Development/IDE/GHC/CPP.hs @@ -1,228 +1,231 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - --- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019 --- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944. --- Update the above MR got merged to master on 31 May 2019. When it becomes avialable to ghc-lib, this file can be removed. - -{- HLINT ignore -} -- since copied from upstream - -{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -#include "ghc-api-version.h" - ------------------------------------------------------------------------------ --- --- GHC Driver --- --- (c) The University of Glasgow 2005 --- ------------------------------------------------------------------------------ - -module Development.IDE.GHC.CPP(doCpp, addOptP) -where - -import Development.IDE.GHC.Compat -import Packages -import SysTools -import Module -import Panic -import FileCleanup -#if MIN_GHC_API_VERSION(8,8,2) -import LlvmCodeGen (llvmVersionList) -#elif MIN_GHC_API_VERSION(8,8,0) -import LlvmCodeGen (LlvmVersion (..)) -#endif -#if MIN_GHC_API_VERSION (8,10,0) -import Fingerprint -import ToolSettings -#endif - -import System.Directory -import System.FilePath -import Control.Monad -import System.Info -import Data.List ( intercalate ) -import Data.Maybe -import Data.Version - - - -doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () -doCpp dflags raw input_fn output_fn = do - let hscpp_opts = picPOpts dflags - let cmdline_include_paths = includePaths dflags - - pkg_include_dirs <- getPackageIncludePath dflags [] - let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] - (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) - let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] - (includePathsQuote cmdline_include_paths) - let include_paths = include_paths_quote ++ include_paths_global - - let verbFlags = getVerbFlags dflags - - let cpp_prog args | raw = SysTools.runCpp dflags args -#if MIN_GHC_API_VERSION(8,10,0) - | otherwise = SysTools.runCc Nothing -#else - | otherwise = SysTools.runCc -#endif - dflags (SysTools.Option "-E" : args) - - let target_defs = - -- NEIL: Patched to use System.Info instead of constants from CPP - [ "-D" ++ os ++ "_BUILD_OS", - "-D" ++ arch ++ "_BUILD_ARCH", - "-D" ++ os ++ "_HOST_OS", - "-D" ++ arch ++ "_HOST_ARCH" ] - -- remember, in code we *compile*, the HOST is the same our TARGET, - -- and BUILD is the same as our HOST. - - let sse_defs = - [ "-D__SSE__" | isSseEnabled dflags ] ++ - [ "-D__SSE2__" | isSse2Enabled dflags ] ++ - [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] - - let avx_defs = - [ "-D__AVX__" | isAvxEnabled dflags ] ++ - [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ - [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ - [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ - [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ - [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] - - backend_defs <- getBackendDefs dflags - - let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] - -- Default CPP defines in Haskell source - ghcVersionH <- getGhcVersionPathName dflags - let hsSourceCppOpts = [ "-include", ghcVersionH ] - - -- MIN_VERSION macros - let uids = explicitPackages (pkgState dflags) - pkgs = catMaybes (map (lookupPackage dflags) uids) - mb_macro_include <- - if not (null pkgs) && gopt Opt_VersionMacros dflags - then do macro_stub <- newTempName dflags TFL_CurrentModule "h" - writeFile macro_stub (generatePackageVersionMacros pkgs) - -- Include version macros for every *exposed* package. - -- Without -hide-all-packages and with a package database - -- size of 1000 packages, it takes cpp an estimated 2 - -- milliseconds to process this file. See #10970 - -- comment 8. - return [SysTools.FileOption "-include" macro_stub] - else return [] - - cpp_prog ( map SysTools.Option verbFlags - ++ map SysTools.Option include_paths - ++ map SysTools.Option hsSourceCppOpts - ++ map SysTools.Option target_defs - ++ map SysTools.Option backend_defs - ++ map SysTools.Option th_defs - ++ map SysTools.Option hscpp_opts - ++ map SysTools.Option sse_defs - ++ map SysTools.Option avx_defs - ++ mb_macro_include - -- Set the language mode to assembler-with-cpp when preprocessing. This - -- alleviates some of the C99 macro rules relating to whitespace and the hash - -- operator, which we tend to abuse. Clang in particular is not very happy - -- about this. - ++ [ SysTools.Option "-x" - , SysTools.Option "assembler-with-cpp" - , SysTools.Option input_fn - -- We hackily use Option instead of FileOption here, so that the file - -- name is not back-slashed on Windows. cpp is capable of - -- dealing with / in filenames, so it works fine. Furthermore - -- if we put in backslashes, cpp outputs #line directives - -- with *double* backslashes. And that in turn means that - -- our error messages get double backslashes in them. - -- In due course we should arrange that the lexer deals - -- with these \\ escapes properly. - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ]) - -getBackendDefs :: DynFlags -> IO [String] -getBackendDefs dflags | hscTarget dflags == HscLlvm = do - llvmVer <- figureLlvmVersion dflags - return $ case llvmVer of -#if MIN_GHC_API_VERSION(8,8,2) - Just v - | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ] - | m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ] -#elif MIN_GHC_API_VERSION(8,8,0) - Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ] - Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] -#else - Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ] -#endif - _ -> [] - where - format (major, minor) - | minor >= 100 = error "getBackendDefs: Unsupported minor version" - | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int - -getBackendDefs _ = - return [] - -addOptP :: String -> DynFlags -> DynFlags -#if MIN_GHC_API_VERSION (8,10,0) -addOptP f = alterToolSettings $ \s -> s - { toolSettings_opt_P = f : toolSettings_opt_P s - , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) - } - where - fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss - alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } -#else -addOptP opt = onSettings (onOptP (opt:)) - where - onSettings f x = x{settings = f $ settings x} - onOptP f x = x{sOpt_P = f $ sOpt_P x} -#endif - --- --------------------------------------------------------------------------- --- Macros (cribbed from Cabal) - -generatePackageVersionMacros :: [PackageConfig] -> String -generatePackageVersionMacros pkgs = concat - -- Do not add any C-style comments. See #3389. - [ generateMacros "" pkgname version - | pkg <- pkgs - , let version = packageVersion pkg - pkgname = map fixchar (packageNameString pkg) - ] - -fixchar :: Char -> Char -fixchar '-' = '_' -fixchar c = c - -generateMacros :: String -> String -> Version -> String -generateMacros prefix name version = - concat - ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" - ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" - ," (major1) < ",major1," || \\\n" - ," (major1) == ",major1," && (major2) < ",major2," || \\\n" - ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" - ,"\n\n" - ] - where - (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) - - --- | Find out path to @ghcversion.h@ file -getGhcVersionPathName :: DynFlags -> IO FilePath -getGhcVersionPathName dflags = do - candidates <- case ghcVersionFile dflags of - Just path -> return [path] - Nothing -> (map ( "ghcversion.h")) <$> - (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId]) - - found <- filterM doesFileExist candidates - case found of - [] -> throwGhcExceptionIO (InstallationError - ("ghcversion.h missing; tried: " - ++ intercalate ", " candidates)) - (x:_) -> return x +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +-- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019 +-- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944. +-- Update the above MR got merged to master on 31 May 2019. When it becomes avialable to ghc-lib, this file can be removed. + +{- HLINT ignore -} -- since copied from upstream + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +#include "ghc-api-version.h" + +----------------------------------------------------------------------------- +-- +-- GHC Driver +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module Development.IDE.GHC.CPP(doCpp, addOptP) +where + +import Development.IDE.GHC.Compat +import FileCleanup +import Module +import Packages +import Panic +import SysTools +#if MIN_GHC_API_VERSION(8,8,2) +import LlvmCodeGen (llvmVersionList) +#elif MIN_GHC_API_VERSION(8,8,0) +import LlvmCodeGen (LlvmVersion (..)) +#endif +#if MIN_GHC_API_VERSION (8,10,0) +import Fingerprint +import ToolSettings +#endif + +import Control.Monad +import Data.List (intercalate) +import Data.Maybe +import Data.Version +import System.Directory +import System.FilePath +import System.Info + + + +doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () +doCpp dflags raw input_fn output_fn = do + let hscpp_opts = picPOpts dflags + let cmdline_include_paths = includePaths dflags + + pkg_include_dirs <- getPackageIncludePath dflags [] + let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] + (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) + let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] + (includePathsQuote cmdline_include_paths) + let include_paths = include_paths_quote ++ include_paths_global + + let verbFlags = getVerbFlags dflags + + let cpp_prog args | raw = SysTools.runCpp dflags args +#if MIN_GHC_API_VERSION(8,10,0) + | otherwise = SysTools.runCc Nothing +#else + | otherwise = SysTools.runCc +#endif + dflags (SysTools.Option "-E" : args) + + let target_defs = + -- NEIL: Patched to use System.Info instead of constants from CPP + [ "-D" ++ os ++ "_BUILD_OS", + "-D" ++ arch ++ "_BUILD_ARCH", + "-D" ++ os ++ "_HOST_OS", + "-D" ++ arch ++ "_HOST_ARCH" ] + -- remember, in code we *compile*, the HOST is the same our TARGET, + -- and BUILD is the same as our HOST. + + let sse_defs = + [ "-D__SSE__" | isSseEnabled dflags ] ++ + [ "-D__SSE2__" | isSse2Enabled dflags ] ++ + [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] + + let avx_defs = + [ "-D__AVX__" | isAvxEnabled dflags ] ++ + [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ + [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ + [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ + [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ + [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] + + backend_defs <- getBackendDefs dflags + + let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] + -- Default CPP defines in Haskell source + ghcVersionH <- getGhcVersionPathName dflags + let hsSourceCppOpts = [ "-include", ghcVersionH ] + + -- MIN_VERSION macros + let uids = explicitPackages (pkgState dflags) + pkgs = catMaybes (map (lookupPackage dflags) uids) + mb_macro_include <- + if not (null pkgs) && gopt Opt_VersionMacros dflags + then do macro_stub <- newTempName dflags TFL_CurrentModule "h" + writeFile macro_stub (generatePackageVersionMacros pkgs) + -- Include version macros for every *exposed* package. + -- Without -hide-all-packages and with a package database + -- size of 1000 packages, it takes cpp an estimated 2 + -- milliseconds to process this file. See #10970 + -- comment 8. + return [SysTools.FileOption "-include" macro_stub] + else return [] + + cpp_prog ( map SysTools.Option verbFlags + ++ map SysTools.Option include_paths + ++ map SysTools.Option hsSourceCppOpts + ++ map SysTools.Option target_defs + ++ map SysTools.Option backend_defs + ++ map SysTools.Option th_defs + ++ map SysTools.Option hscpp_opts + ++ map SysTools.Option sse_defs + ++ map SysTools.Option avx_defs + ++ mb_macro_include + -- Set the language mode to assembler-with-cpp when preprocessing. This + -- alleviates some of the C99 macro rules relating to whitespace and the hash + -- operator, which we tend to abuse. Clang in particular is not very happy + -- about this. + ++ [ SysTools.Option "-x" + , SysTools.Option "assembler-with-cpp" + , SysTools.Option input_fn + -- We hackily use Option instead of FileOption here, so that the file + -- name is not back-slashed on Windows. cpp is capable of + -- dealing with / in filenames, so it works fine. Furthermore + -- if we put in backslashes, cpp outputs #line directives + -- with *double* backslashes. And that in turn means that + -- our error messages get double backslashes in them. + -- In due course we should arrange that the lexer deals + -- with these \\ escapes properly. + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ]) + +getBackendDefs :: DynFlags -> IO [String] +getBackendDefs dflags | hscTarget dflags == HscLlvm = do + llvmVer <- figureLlvmVersion dflags + return $ case llvmVer of +#if MIN_GHC_API_VERSION(8,8,2) + Just v + | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ] + | m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ] +#elif MIN_GHC_API_VERSION(8,8,0) + Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ] + Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] +#else + Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ] +#endif + _ -> [] + where + format (major, minor) + | minor >= 100 = error "getBackendDefs: Unsupported minor version" + | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int + +getBackendDefs _ = + return [] + +addOptP :: String -> DynFlags -> DynFlags +#if MIN_GHC_API_VERSION (8,10,0) +addOptP f = alterToolSettings $ \s -> s + { toolSettings_opt_P = f : toolSettings_opt_P s + , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) + } + where + fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss + alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } +#else +addOptP opt = onSettings (onOptP (opt:)) + where + onSettings f x = x{settings = f $ settings x} + onOptP f x = x{sOpt_P = f $ sOpt_P x} +#endif + +-- --------------------------------------------------------------------------- +-- Macros (cribbed from Cabal) + +generatePackageVersionMacros :: [PackageConfig] -> String +generatePackageVersionMacros pkgs = concat + -- Do not add any C-style comments. See #3389. + [ generateMacros "" pkgname version + | pkg <- pkgs + , let version = packageVersion pkg + pkgname = map fixchar (packageNameString pkg) + ] + +fixchar :: Char -> Char +fixchar '-' = '_' +fixchar c = c + +generateMacros :: String -> String -> Version -> String +generateMacros prefix name version = + concat + ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" + ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" + ," (major1) < ",major1," || \\\n" + ," (major1) == ",major1," && (major2) < ",major2," || \\\n" + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" + ,"\n\n" + ] + where + (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) + + +-- | Find out path to @ghcversion.h@ file +getGhcVersionPathName :: DynFlags -> IO FilePath +getGhcVersionPathName dflags = do + candidates <- case ghcVersionFile dflags of + Just path -> return [path] + Nothing -> (map ( "ghcversion.h")) <$> + (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId]) + + found <- filterM doesFileExist candidates + case found of + [] -> throwGhcExceptionIO (InstallationError + ("ghcversion.h missing; tried: " + ++ intercalate ", " candidates)) + (x:_) -> return x diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs --- a/src/Development/IDE/GHC/Compat.hs +++ b/src/Development/IDE/GHC/Compat.hs @@ -1,311 +1,311 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternSynonyms #-} -{-# OPTIONS -Wno-dodgy-imports -Wno-incomplete-uni-patterns #-} -#include "ghc-api-version.h" - --- | Attempt at hiding the GHC version differences we can. -module Development.IDE.GHC.Compat( - HieFileResult(..), - HieFile(..), - NameCacheUpdater(..), - hieExportNames, - mkHieFile, - mkHieFile', - enrichHie, - RefMap, - writeHieFile, - readHieFile, - supportsHieFiles, - setHieDir, - dontWriteHieFiles, -#if !MIN_GHC_API_VERSION(8,8,0) - ml_hie_file, - addBootSuffixLocnOut, -#endif - hPutStringBuffer, - addIncludePathsQuote, - getModuleHash, - getPackageName, - setUpTypedHoles, - GHC.ModLocation, - Module.addBootSuffix, - pattern ModLocation, - pattern ExposePackage, - HasSrcSpan, - getLoc, - upNameCache, - disableWarningsAsErrors, - AvailInfo, - tcg_exports, - pattern FunTy, - -#if MIN_GHC_API_VERSION(8,10,0) - module GHC.Hs.Extension, - module LinkerTypes, -#else - module HsExtension, - noExtField, - linkableTime, -#endif - - module GHC, - module DynFlags, - initializePlugins, - applyPluginsParsedResultAction, - module Compat.HieTypes, - module Compat.HieUtils, - dropForAll - ,isQualifiedImport) where - -#if MIN_GHC_API_VERSION(8,10,0) -import LinkerTypes -#endif - -import StringBuffer -import qualified DynFlags -import DynFlags hiding (ExposePackage) -import Fingerprint (Fingerprint) -import qualified Module -import Packages -import Data.IORef -import HscTypes -import NameCache -import qualified Data.ByteString as BS -import MkIface -import TcRnTypes -import Compat.HieAst (mkHieFile,enrichHie) -import Compat.HieBin -import Compat.HieTypes -import Compat.HieUtils - -#if MIN_GHC_API_VERSION(8,10,0) -import GHC.Hs.Extension -#else -import HsExtension -#endif - -import qualified GHC -import qualified TyCoRep -import GHC hiding ( - ModLocation, - HasSrcSpan, - lookupName, - getLoc - ) -import Avail -#if MIN_GHC_API_VERSION(8,8,0) -import Data.List (foldl') -#else -import Data.List (foldl', isSuffixOf) -#endif - -import DynamicLoading -import Plugins (Plugin(parsedResultAction), withPlugins) -import Data.Map.Strict (Map) - -#if !MIN_GHC_API_VERSION(8,8,0) -import System.FilePath ((-<.>)) -#endif - -#if !MIN_GHC_API_VERSION(8,8,0) -import qualified EnumSet - -import System.IO -import Foreign.ForeignPtr - - -hPutStringBuffer :: Handle -> StringBuffer -> IO () -hPutStringBuffer hdl (StringBuffer buf len cur) - = withForeignPtr (plusForeignPtr buf cur) $ \ptr -> - hPutBuf hdl ptr len - -#endif - -#if !MIN_GHC_API_VERSION(8,10,0) -noExtField :: NoExt -noExtField = noExt -#endif - -supportsHieFiles :: Bool -supportsHieFiles = True - -hieExportNames :: HieFile -> [(SrcSpan, Name)] -hieExportNames = nameListFromAvails . hie_exports - -#if !MIN_GHC_API_VERSION(8,8,0) -ml_hie_file :: GHC.ModLocation -> FilePath -ml_hie_file ml - | "boot" `isSuffixOf ` ml_hi_file ml = ml_hi_file ml -<.> ".hie-boot" - | otherwise = ml_hi_file ml -<.> ".hie" -#endif - -upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c -#if !MIN_GHC_API_VERSION(8,8,0) -upNameCache ref upd_fn - = atomicModifyIORef' ref upd_fn -#else -upNameCache = updNameCache -#endif - - -type RefMap a = Map Identifier [(Span, IdentifierDetails a)] - -mkHieFile' :: ModSummary - -> [AvailInfo] - -> HieASTs Type - -> BS.ByteString - -> Hsc HieFile -mkHieFile' ms exports asts src = do - let Just src_file = ml_hs_file $ ms_location ms - (asts',arr) = compressTypes asts - return $ HieFile - { hie_hs_file = src_file - , hie_module = ms_mod ms - , hie_types = arr - , hie_asts = asts' - -- mkIfaceExports sorts the AvailInfos for stability - , hie_exports = mkIfaceExports exports - , hie_hs_src = src - } - -addIncludePathsQuote :: FilePath -> DynFlags -> DynFlags -addIncludePathsQuote path x = x{includePaths = f $ includePaths x} - where f i = i{includePathsQuote = path : includePathsQuote i} - -pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation -pattern ModLocation a b c <- -#if MIN_GHC_API_VERSION(8,8,0) - GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c "" -#else - GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c -#endif - -setHieDir :: FilePath -> DynFlags -> DynFlags -setHieDir _f d = -#if MIN_GHC_API_VERSION(8,8,0) - d { hieDir = Just _f} -#else - d -#endif - -dontWriteHieFiles :: DynFlags -> DynFlags -dontWriteHieFiles d = -#if MIN_GHC_API_VERSION(8,8,0) - gopt_unset d Opt_WriteHie -#else - d -#endif - -setUpTypedHoles ::DynFlags -> DynFlags -setUpTypedHoles df - = flip gopt_unset Opt_AbstractRefHoleFits -- too spammy -#if MIN_GHC_API_VERSION(8,8,0) - $ flip gopt_unset Opt_ShowDocsOfHoleFits -- not used -#endif - $ flip gopt_unset Opt_ShowMatchesOfHoleFits -- nice but broken (forgets module qualifiers) - $ flip gopt_unset Opt_ShowProvOfHoleFits -- not used - $ flip gopt_unset Opt_ShowTypeAppOfHoleFits -- not used - $ flip gopt_unset Opt_ShowTypeAppVarsOfHoleFits -- not used - $ flip gopt_unset Opt_ShowTypeOfHoleFits -- massively simplifies parsing - $ flip gopt_set Opt_SortBySubsumHoleFits -- very nice and fast enough in most cases - $ flip gopt_unset Opt_SortValidHoleFits - $ flip gopt_unset Opt_UnclutterValidHoleFits - $ df - { refLevelHoleFits = Just 1 -- becomes slow at higher levels - , maxRefHoleFits = Just 10 -- quantity does not impact speed - , maxValidHoleFits = Nothing -- quantity does not impact speed - } - - -nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)] -nameListFromAvails as = - map (\n -> (nameSrcSpan n, n)) (concatMap availNames as) - -#if MIN_GHC_API_VERSION(8,8,0) - -type HasSrcSpan = GHC.HasSrcSpan -getLoc :: HasSrcSpan a => a -> SrcSpan -getLoc = GHC.getLoc - -#else - -class HasSrcSpan a where - getLoc :: a -> SrcSpan -instance HasSrcSpan Name where - getLoc = nameSrcSpan -instance HasSrcSpan (GenLocated SrcSpan a) where - getLoc = GHC.getLoc - --- | Add the @-boot@ suffix to all output file paths associated with the --- module, not including the input file itself -addBootSuffixLocnOut :: GHC.ModLocation -> GHC.ModLocation -addBootSuffixLocnOut locn - = locn { ml_hi_file = Module.addBootSuffix (ml_hi_file locn) - , ml_obj_file = Module.addBootSuffix (ml_obj_file locn) - } -#endif - -getModuleHash :: ModIface -> Fingerprint -#if MIN_GHC_API_VERSION(8,10,0) -getModuleHash = mi_mod_hash . mi_final_exts -#else -getModuleHash = mi_mod_hash -#endif - -getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName -getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i)) - -disableWarningsAsErrors :: DynFlags -> DynFlags -disableWarningsAsErrors df = - flip gopt_unset Opt_WarnIsError $ foldl' wopt_unset_fatal df [toEnum 0 ..] - -#if !MIN_GHC_API_VERSION(8,8,0) -wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags -wopt_unset_fatal dfs f - = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) } -#endif - -applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> ApiAnns -> ParsedSource -> IO ParsedSource -applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do - -- Apply parsedResultAction of plugins - let applyPluginAction p opts = parsedResultAction p opts ms - fmap hpm_module $ - runHsc env $ withPlugins dflags applyPluginAction - (HsParsedModule parsed [] hpm_annotations) - -pattern ExposePackage :: String -> PackageArg -> ModRenaming -> PackageFlag --- https://github.com/facebook/fbghc -#ifdef __FACEBOOK_HASKELL__ -pattern ExposePackage s a mr <- DynFlags.ExposePackage s a _ mr -#else -pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr -#endif - --- | Take AST representation of type signature and drop `forall` part from it (if any), returning just type's body -dropForAll :: LHsType pass -> LHsType pass -#if MIN_GHC_API_VERSION(8,10,0) -dropForAll = snd . GHC.splitLHsForAllTyInvis -#else -dropForAll = snd . GHC.splitLHsForAllTy -#endif - -pattern FunTy :: Type -> Type -> Type -#if MIN_GHC_API_VERSION(8, 10, 0) -pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res} -#else -pattern FunTy arg res <- TyCoRep.FunTy arg res -#endif - -isQualifiedImport :: ImportDecl a -> Bool -#if MIN_GHC_API_VERSION(8,10,0) -isQualifiedImport ImportDecl{ideclQualified = NotQualified} = False -isQualifiedImport ImportDecl{} = True -#else -isQualifiedImport ImportDecl{ideclQualified} = ideclQualified -#endif -isQualifiedImport _ = False +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS -Wno-dodgy-imports -Wno-incomplete-uni-patterns #-} +#include "ghc-api-version.h" + +-- | Attempt at hiding the GHC version differences we can. +module Development.IDE.GHC.Compat( + HieFileResult(..), + HieFile(..), + NameCacheUpdater(..), + hieExportNames, + mkHieFile, + mkHieFile', + enrichHie, + RefMap, + writeHieFile, + readHieFile, + supportsHieFiles, + setHieDir, + dontWriteHieFiles, +#if !MIN_GHC_API_VERSION(8,8,0) + ml_hie_file, + addBootSuffixLocnOut, +#endif + hPutStringBuffer, + addIncludePathsQuote, + getModuleHash, + getPackageName, + setUpTypedHoles, + GHC.ModLocation, + Module.addBootSuffix, + pattern ModLocation, + pattern ExposePackage, + HasSrcSpan, + getLoc, + upNameCache, + disableWarningsAsErrors, + AvailInfo, + tcg_exports, + pattern FunTy, + +#if MIN_GHC_API_VERSION(8,10,0) + module GHC.Hs.Extension, + module LinkerTypes, +#else + module HsExtension, + noExtField, + linkableTime, +#endif + + module GHC, + module DynFlags, + initializePlugins, + applyPluginsParsedResultAction, + module Compat.HieTypes, + module Compat.HieUtils, + dropForAll + ,isQualifiedImport) where + +#if MIN_GHC_API_VERSION(8,10,0) +import LinkerTypes +#endif + +import StringBuffer +import qualified DynFlags +import DynFlags hiding (ExposePackage) +import Fingerprint (Fingerprint) +import qualified Module +import Packages +import Data.IORef +import HscTypes +import NameCache +import qualified Data.ByteString as BS +import MkIface +import TcRnTypes +import Compat.HieAst (mkHieFile,enrichHie) +import Compat.HieBin +import Compat.HieTypes +import Compat.HieUtils + +#if MIN_GHC_API_VERSION(8,10,0) +import GHC.Hs.Extension +#else +import HsExtension +#endif + +import qualified GHC +import qualified TyCoRep +import GHC hiding ( + ModLocation, + HasSrcSpan, + lookupName, + getLoc + ) +import Avail +#if MIN_GHC_API_VERSION(8,8,0) +import Data.List (foldl') +#else +import Data.List (foldl', isSuffixOf) +#endif + +import DynamicLoading +import Plugins (Plugin(parsedResultAction), withPlugins) +import Data.Map.Strict (Map) + +#if !MIN_GHC_API_VERSION(8,8,0) +import System.FilePath ((-<.>)) +#endif + +#if !MIN_GHC_API_VERSION(8,8,0) +import qualified EnumSet + +import System.IO +import Foreign.ForeignPtr + + +hPutStringBuffer :: Handle -> StringBuffer -> IO () +hPutStringBuffer hdl (StringBuffer buf len cur) + = withForeignPtr (plusForeignPtr buf cur) $ \ptr -> + hPutBuf hdl ptr len + +#endif + +#if !MIN_GHC_API_VERSION(8,10,0) +noExtField :: NoExt +noExtField = noExt +#endif + +supportsHieFiles :: Bool +supportsHieFiles = True + +hieExportNames :: HieFile -> [(SrcSpan, Name)] +hieExportNames = nameListFromAvails . hie_exports + +#if !MIN_GHC_API_VERSION(8,8,0) +ml_hie_file :: GHC.ModLocation -> FilePath +ml_hie_file ml + | "boot" `isSuffixOf ` ml_hi_file ml = ml_hi_file ml -<.> ".hie-boot" + | otherwise = ml_hi_file ml -<.> ".hie" +#endif + +upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c +#if !MIN_GHC_API_VERSION(8,8,0) +upNameCache ref upd_fn + = atomicModifyIORef' ref upd_fn +#else +upNameCache = updNameCache +#endif + + +type RefMap a = Map Identifier [(Span, IdentifierDetails a)] + +mkHieFile' :: ModSummary + -> [AvailInfo] + -> HieASTs Type + -> BS.ByteString + -> Hsc HieFile +mkHieFile' ms exports asts src = do + let Just src_file = ml_hs_file $ ms_location ms + (asts',arr) = compressTypes asts + return $ HieFile + { hie_hs_file = src_file + , hie_module = ms_mod ms + , hie_types = arr + , hie_asts = asts' + -- mkIfaceExports sorts the AvailInfos for stability + , hie_exports = mkIfaceExports exports + , hie_hs_src = src + } + +addIncludePathsQuote :: FilePath -> DynFlags -> DynFlags +addIncludePathsQuote path x = x{includePaths = f $ includePaths x} + where f i = i{includePathsQuote = path : includePathsQuote i} + +pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation +pattern ModLocation a b c <- +#if MIN_GHC_API_VERSION(8,8,0) + GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c "" +#else + GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c +#endif + +setHieDir :: FilePath -> DynFlags -> DynFlags +setHieDir _f d = +#if MIN_GHC_API_VERSION(8,8,0) + d { hieDir = Just _f} +#else + d +#endif + +dontWriteHieFiles :: DynFlags -> DynFlags +dontWriteHieFiles d = +#if MIN_GHC_API_VERSION(8,8,0) + gopt_unset d Opt_WriteHie +#else + d +#endif + +setUpTypedHoles ::DynFlags -> DynFlags +setUpTypedHoles df + = flip gopt_unset Opt_AbstractRefHoleFits -- too spammy +#if MIN_GHC_API_VERSION(8,8,0) + $ flip gopt_unset Opt_ShowDocsOfHoleFits -- not used +#endif + $ flip gopt_unset Opt_ShowMatchesOfHoleFits -- nice but broken (forgets module qualifiers) + $ flip gopt_unset Opt_ShowProvOfHoleFits -- not used + $ flip gopt_unset Opt_ShowTypeAppOfHoleFits -- not used + $ flip gopt_unset Opt_ShowTypeAppVarsOfHoleFits -- not used + $ flip gopt_unset Opt_ShowTypeOfHoleFits -- massively simplifies parsing + $ flip gopt_set Opt_SortBySubsumHoleFits -- very nice and fast enough in most cases + $ flip gopt_unset Opt_SortValidHoleFits + $ flip gopt_unset Opt_UnclutterValidHoleFits + $ df + { refLevelHoleFits = Just 1 -- becomes slow at higher levels + , maxRefHoleFits = Just 10 -- quantity does not impact speed + , maxValidHoleFits = Nothing -- quantity does not impact speed + } + + +nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)] +nameListFromAvails as = + map (\n -> (nameSrcSpan n, n)) (concatMap availNames as) + +#if MIN_GHC_API_VERSION(8,8,0) + +type HasSrcSpan = GHC.HasSrcSpan +getLoc :: HasSrcSpan a => a -> SrcSpan +getLoc = GHC.getLoc + +#else + +class HasSrcSpan a where + getLoc :: a -> SrcSpan +instance HasSrcSpan Name where + getLoc = nameSrcSpan +instance HasSrcSpan (GenLocated SrcSpan a) where + getLoc = GHC.getLoc + +-- | Add the @-boot@ suffix to all output file paths associated with the +-- module, not including the input file itself +addBootSuffixLocnOut :: GHC.ModLocation -> GHC.ModLocation +addBootSuffixLocnOut locn + = locn { ml_hi_file = Module.addBootSuffix (ml_hi_file locn) + , ml_obj_file = Module.addBootSuffix (ml_obj_file locn) + } +#endif + +getModuleHash :: ModIface -> Fingerprint +#if MIN_GHC_API_VERSION(8,10,0) +getModuleHash = mi_mod_hash . mi_final_exts +#else +getModuleHash = mi_mod_hash +#endif + +getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName +getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i)) + +disableWarningsAsErrors :: DynFlags -> DynFlags +disableWarningsAsErrors df = + flip gopt_unset Opt_WarnIsError $ foldl' wopt_unset_fatal df [toEnum 0 ..] + +#if !MIN_GHC_API_VERSION(8,8,0) +wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags +wopt_unset_fatal dfs f + = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) } +#endif + +applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> ApiAnns -> ParsedSource -> IO ParsedSource +applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do + -- Apply parsedResultAction of plugins + let applyPluginAction p opts = parsedResultAction p opts ms + fmap hpm_module $ + runHsc env $ withPlugins dflags applyPluginAction + (HsParsedModule parsed [] hpm_annotations) + +pattern ExposePackage :: String -> PackageArg -> ModRenaming -> PackageFlag +-- https://github.com/facebook/fbghc +#ifdef __FACEBOOK_HASKELL__ +pattern ExposePackage s a mr <- DynFlags.ExposePackage s a _ mr +#else +pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr +#endif + +-- | Take AST representation of type signature and drop `forall` part from it (if any), returning just type's body +dropForAll :: LHsType pass -> LHsType pass +#if MIN_GHC_API_VERSION(8,10,0) +dropForAll = snd . GHC.splitLHsForAllTyInvis +#else +dropForAll = snd . GHC.splitLHsForAllTy +#endif + +pattern FunTy :: Type -> Type -> Type +#if MIN_GHC_API_VERSION(8, 10, 0) +pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res} +#else +pattern FunTy arg res <- TyCoRep.FunTy arg res +#endif + +isQualifiedImport :: ImportDecl a -> Bool +#if MIN_GHC_API_VERSION(8,10,0) +isQualifiedImport ImportDecl{ideclQualified = NotQualified} = False +isQualifiedImport ImportDecl{} = True +#else +isQualifiedImport ImportDecl{ideclQualified} = ideclQualified +#endif +isQualifiedImport _ = False diff --git a/src/Development/IDE/GHC/Error.hs b/src/Development/IDE/GHC/Error.hs --- a/src/Development/IDE/GHC/Error.hs +++ b/src/Development/IDE/GHC/Error.hs @@ -1,218 +1,218 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 -module Development.IDE.GHC.Error - ( - -- * Producing Diagnostic values - diagFromErrMsgs - , diagFromErrMsg - , diagFromString - , diagFromStrings - , diagFromGhcException - , catchSrcErrors - - -- * utilities working with spans - , srcSpanToLocation - , srcSpanToRange - , realSrcSpanToRange - , realSrcLocToPosition - , realSrcSpanToLocation - , srcSpanToFilename - , rangeToSrcSpan - , rangeToRealSrcSpan - , positionToRealSrcLoc - , zeroSpan - , realSpan - , isInsideSrcSpan - , noSpan - - -- * utilities working with severities - , toDSeverity - ) where - -import Development.IDE.Types.Diagnostics as D -import qualified Data.Text as T -import Data.Maybe -import Development.IDE.Types.Location -import Development.IDE.GHC.Orphans() -import qualified FastString as FS -import GHC -import Bag -import HscTypes -import Panic -import ErrUtils -import SrcLoc -import qualified Outputable as Out -import Data.String (fromString) - - - -diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic -diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc,ShowDiag,) - Diagnostic - { _range = fromMaybe noRange $ srcSpanToRange loc - , _severity = Just sev - , _source = Just diagSource -- not shown in the IDE, but useful for ghcide developers - , _message = msg - , _code = Nothing - , _relatedInformation = Nothing - , _tags = Nothing - } - --- | Produce a GHC-style error from a source span and a message. -diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic] -diagFromErrMsg diagSource dflags e = - [ diagFromText diagSource sev (errMsgSpan e) - $ T.pack $ formatErrorWithQual dflags e - | Just sev <- [toDSeverity $ errMsgSeverity e]] - -formatErrorWithQual :: DynFlags -> ErrMsg -> String -formatErrorWithQual dflags e = - Out.showSDoc dflags - $ Out.withPprStyle (Out.mkErrStyle dflags $ errMsgContext e) - $ ErrUtils.formatErrDoc dflags - $ ErrUtils.errMsgDoc e - -diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic] -diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList - --- | Convert a GHC SrcSpan to a DAML compiler Range -srcSpanToRange :: SrcSpan -> Maybe Range -srcSpanToRange (UnhelpfulSpan _) = Nothing -srcSpanToRange (RealSrcSpan real) = Just $ realSrcSpanToRange real - -realSrcSpanToRange :: RealSrcSpan -> Range -realSrcSpanToRange real = - Range (realSrcLocToPosition $ realSrcSpanStart real) - (realSrcLocToPosition $ realSrcSpanEnd real) - -realSrcLocToPosition :: RealSrcLoc -> Position -realSrcLocToPosition real = - Position (srcLocLine real - 1) (srcLocCol real - 1) - --- | Extract a file name from a GHC SrcSpan (use message for unhelpful ones) --- FIXME This may not be an _absolute_ file name, needs fixing. -srcSpanToFilename :: SrcSpan -> Maybe FilePath -srcSpanToFilename (UnhelpfulSpan _) = Nothing -srcSpanToFilename (RealSrcSpan real) = Just $ FS.unpackFS $ srcSpanFile real - -realSrcSpanToLocation :: RealSrcSpan -> Location -realSrcSpanToLocation real = Location file (realSrcSpanToRange real) - where file = fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ FS.unpackFS $ srcSpanFile real - -srcSpanToLocation :: SrcSpan -> Maybe Location -srcSpanToLocation src = do - fs <- srcSpanToFilename src - rng <- srcSpanToRange src - -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code - pure $ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' fs) rng - -rangeToSrcSpan :: NormalizedFilePath -> Range -> SrcSpan -rangeToSrcSpan = fmap RealSrcSpan . rangeToRealSrcSpan - -rangeToRealSrcSpan - :: NormalizedFilePath -> Range -> RealSrcSpan -rangeToRealSrcSpan nfp = - mkRealSrcSpan - <$> positionToRealSrcLoc nfp . _start - <*> positionToRealSrcLoc nfp . _end - -positionToRealSrcLoc :: NormalizedFilePath -> Position -> RealSrcLoc -positionToRealSrcLoc nfp (Position l c)= - mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (l + 1) (c + 1) - -isInsideSrcSpan :: Position -> SrcSpan -> Bool -p `isInsideSrcSpan` r = case srcSpanToRange r of - Just (Range sp ep) -> sp <= p && p <= ep - _ -> False - --- | Convert a GHC severity to a DAML compiler Severity. Severities below --- "Warning" level are dropped (returning Nothing). -toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity -toDSeverity SevOutput = Nothing -toDSeverity SevInteractive = Nothing -toDSeverity SevDump = Nothing -toDSeverity SevInfo = Just DsInfo -toDSeverity SevWarning = Just DsWarning -toDSeverity SevError = Just DsError -toDSeverity SevFatal = Just DsError - - --- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given --- (optional) locations and message strings. -diagFromStrings :: T.Text -> D.DiagnosticSeverity -> [(SrcSpan, String)] -> [FileDiagnostic] -diagFromStrings diagSource sev = concatMap (uncurry (diagFromString diagSource sev)) - --- | Produce a GHC-style error from a source span and a message. -diagFromString :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> String -> [FileDiagnostic] -diagFromString diagSource sev sp x = [diagFromText diagSource sev sp $ T.pack x] - - --- | Produces an "unhelpful" source span with the given string. -noSpan :: String -> SrcSpan -noSpan = UnhelpfulSpan . FS.fsLit - - --- | creates a span with zero length in the filename of the argument passed -zeroSpan :: FS.FastString -- ^ file path of span - -> RealSrcSpan -zeroSpan file = realSrcLocSpan (mkRealSrcLoc file 1 1) - -realSpan :: SrcSpan - -> Maybe RealSrcSpan -realSpan = \case - RealSrcSpan r -> Just r - UnhelpfulSpan _ -> Nothing - - --- | Catch the errors thrown by GHC (SourceErrors and --- compiler-internal exceptions like Panic or InstallationError), and turn them into --- diagnostics -catchSrcErrors :: DynFlags -> T.Text -> IO a -> IO (Either [FileDiagnostic] a) -catchSrcErrors dflags fromWhere ghcM = do - handleGhcException (ghcExceptionToDiagnostics dflags) $ - handleSourceError (sourceErrorToDiagnostics dflags) $ - Right <$> ghcM - where - ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags - sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags . srcErrorMessages - - -diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic] -diagFromGhcException diagSource dflags exc = diagFromString diagSource DsError (noSpan "") (showGHCE dflags exc) - -showGHCE :: DynFlags -> GhcException -> String -showGHCE dflags exc = case exc of - Signal n - -> "Signal: " <> show n - - Panic s - -> unwords ["Compilation Issue:", s, "\n", requestReport] - PprPanic s sdoc - -> unlines ["Compilation Issue", s,"" - , Out.showSDoc dflags sdoc - , requestReport ] - - Sorry s - -> "Unsupported feature: " <> s - PprSorry s sdoc - -> unlines ["Unsupported feature: ", s,"" - , Out.showSDoc dflags sdoc] - - - ---------- errors below should not happen at all -------- - InstallationError str - -> "Installation error: " <> str - - UsageError str -- should never happen - -> unlines ["Unexpected usage error", str] - - CmdLineError str - -> unlines ["Unexpected usage error", str] - - ProgramError str - -> "Program error: " <> str - PprProgramError str sdoc -> - unlines ["Program error:", str,"" - , Out.showSDoc dflags sdoc] - where - requestReport = "Please report this bug to the compiler authors." +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 +module Development.IDE.GHC.Error + ( + -- * Producing Diagnostic values + diagFromErrMsgs + , diagFromErrMsg + , diagFromString + , diagFromStrings + , diagFromGhcException + , catchSrcErrors + + -- * utilities working with spans + , srcSpanToLocation + , srcSpanToRange + , realSrcSpanToRange + , realSrcLocToPosition + , realSrcSpanToLocation + , srcSpanToFilename + , rangeToSrcSpan + , rangeToRealSrcSpan + , positionToRealSrcLoc + , zeroSpan + , realSpan + , isInsideSrcSpan + , noSpan + + -- * utilities working with severities + , toDSeverity + ) where + +import Bag +import Data.Maybe +import Data.String (fromString) +import qualified Data.Text as T +import Development.IDE.GHC.Orphans () +import Development.IDE.Types.Diagnostics as D +import Development.IDE.Types.Location +import ErrUtils +import qualified FastString as FS +import GHC +import HscTypes +import qualified Outputable as Out +import Panic +import SrcLoc + + + +diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic +diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc,ShowDiag,) + Diagnostic + { _range = fromMaybe noRange $ srcSpanToRange loc + , _severity = Just sev + , _source = Just diagSource -- not shown in the IDE, but useful for ghcide developers + , _message = msg + , _code = Nothing + , _relatedInformation = Nothing + , _tags = Nothing + } + +-- | Produce a GHC-style error from a source span and a message. +diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic] +diagFromErrMsg diagSource dflags e = + [ diagFromText diagSource sev (errMsgSpan e) + $ T.pack $ formatErrorWithQual dflags e + | Just sev <- [toDSeverity $ errMsgSeverity e]] + +formatErrorWithQual :: DynFlags -> ErrMsg -> String +formatErrorWithQual dflags e = + Out.showSDoc dflags + $ Out.withPprStyle (Out.mkErrStyle dflags $ errMsgContext e) + $ ErrUtils.formatErrDoc dflags + $ ErrUtils.errMsgDoc e + +diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic] +diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList + +-- | Convert a GHC SrcSpan to a DAML compiler Range +srcSpanToRange :: SrcSpan -> Maybe Range +srcSpanToRange (UnhelpfulSpan _) = Nothing +srcSpanToRange (RealSrcSpan real) = Just $ realSrcSpanToRange real + +realSrcSpanToRange :: RealSrcSpan -> Range +realSrcSpanToRange real = + Range (realSrcLocToPosition $ realSrcSpanStart real) + (realSrcLocToPosition $ realSrcSpanEnd real) + +realSrcLocToPosition :: RealSrcLoc -> Position +realSrcLocToPosition real = + Position (srcLocLine real - 1) (srcLocCol real - 1) + +-- | Extract a file name from a GHC SrcSpan (use message for unhelpful ones) +-- FIXME This may not be an _absolute_ file name, needs fixing. +srcSpanToFilename :: SrcSpan -> Maybe FilePath +srcSpanToFilename (UnhelpfulSpan _) = Nothing +srcSpanToFilename (RealSrcSpan real) = Just $ FS.unpackFS $ srcSpanFile real + +realSrcSpanToLocation :: RealSrcSpan -> Location +realSrcSpanToLocation real = Location file (realSrcSpanToRange real) + where file = fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ FS.unpackFS $ srcSpanFile real + +srcSpanToLocation :: SrcSpan -> Maybe Location +srcSpanToLocation src = do + fs <- srcSpanToFilename src + rng <- srcSpanToRange src + -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code + pure $ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' fs) rng + +rangeToSrcSpan :: NormalizedFilePath -> Range -> SrcSpan +rangeToSrcSpan = fmap RealSrcSpan . rangeToRealSrcSpan + +rangeToRealSrcSpan + :: NormalizedFilePath -> Range -> RealSrcSpan +rangeToRealSrcSpan nfp = + mkRealSrcSpan + <$> positionToRealSrcLoc nfp . _start + <*> positionToRealSrcLoc nfp . _end + +positionToRealSrcLoc :: NormalizedFilePath -> Position -> RealSrcLoc +positionToRealSrcLoc nfp (Position l c)= + mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (l + 1) (c + 1) + +isInsideSrcSpan :: Position -> SrcSpan -> Bool +p `isInsideSrcSpan` r = case srcSpanToRange r of + Just (Range sp ep) -> sp <= p && p <= ep + _ -> False + +-- | Convert a GHC severity to a DAML compiler Severity. Severities below +-- "Warning" level are dropped (returning Nothing). +toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity +toDSeverity SevOutput = Nothing +toDSeverity SevInteractive = Nothing +toDSeverity SevDump = Nothing +toDSeverity SevInfo = Just DsInfo +toDSeverity SevWarning = Just DsWarning +toDSeverity SevError = Just DsError +toDSeverity SevFatal = Just DsError + + +-- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given +-- (optional) locations and message strings. +diagFromStrings :: T.Text -> D.DiagnosticSeverity -> [(SrcSpan, String)] -> [FileDiagnostic] +diagFromStrings diagSource sev = concatMap (uncurry (diagFromString diagSource sev)) + +-- | Produce a GHC-style error from a source span and a message. +diagFromString :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> String -> [FileDiagnostic] +diagFromString diagSource sev sp x = [diagFromText diagSource sev sp $ T.pack x] + + +-- | Produces an "unhelpful" source span with the given string. +noSpan :: String -> SrcSpan +noSpan = UnhelpfulSpan . FS.fsLit + + +-- | creates a span with zero length in the filename of the argument passed +zeroSpan :: FS.FastString -- ^ file path of span + -> RealSrcSpan +zeroSpan file = realSrcLocSpan (mkRealSrcLoc file 1 1) + +realSpan :: SrcSpan + -> Maybe RealSrcSpan +realSpan = \case + RealSrcSpan r -> Just r + UnhelpfulSpan _ -> Nothing + + +-- | Catch the errors thrown by GHC (SourceErrors and +-- compiler-internal exceptions like Panic or InstallationError), and turn them into +-- diagnostics +catchSrcErrors :: DynFlags -> T.Text -> IO a -> IO (Either [FileDiagnostic] a) +catchSrcErrors dflags fromWhere ghcM = do + handleGhcException (ghcExceptionToDiagnostics dflags) $ + handleSourceError (sourceErrorToDiagnostics dflags) $ + Right <$> ghcM + where + ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags + sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags . srcErrorMessages + + +diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic] +diagFromGhcException diagSource dflags exc = diagFromString diagSource DsError (noSpan "") (showGHCE dflags exc) + +showGHCE :: DynFlags -> GhcException -> String +showGHCE dflags exc = case exc of + Signal n + -> "Signal: " <> show n + + Panic s + -> unwords ["Compilation Issue:", s, "\n", requestReport] + PprPanic s sdoc + -> unlines ["Compilation Issue", s,"" + , Out.showSDoc dflags sdoc + , requestReport ] + + Sorry s + -> "Unsupported feature: " <> s + PprSorry s sdoc + -> unlines ["Unsupported feature: ", s,"" + , Out.showSDoc dflags sdoc] + + + ---------- errors below should not happen at all -------- + InstallationError str + -> "Installation error: " <> str + + UsageError str -- should never happen + -> unlines ["Unexpected usage error", str] + + CmdLineError str + -> unlines ["Unexpected usage error", str] + + ProgramError str + -> "Program error: " <> str + PprProgramError str sdoc -> + unlines ["Program error:", str,"" + , Out.showSDoc dflags sdoc] + where + requestReport = "Please report this bug to the compiler authors." diff --git a/src/Development/IDE/GHC/ExactPrint.hs b/src/Development/IDE/GHC/ExactPrint.hs --- a/src/Development/IDE/GHC/ExactPrint.hs +++ b/src/Development/IDE/GHC/ExactPrint.hs @@ -1,448 +1,584 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} - -module Development.IDE.GHC.ExactPrint - ( Graft(..), - graft, - graftWithoutParentheses, - graftDecls, - graftDeclsWithM, - annotate, - hoistGraft, - graftWithM, - graftWithSmallestM, - graftSmallestDecls, - graftSmallestDeclsWithM, - transform, - transformM, - useAnnotatedSource, - annotateParsedSource, - getAnnotatedParsedSourceRule, - GetAnnotatedParsedSource(..), - ASTElement (..), - ExceptStringT (..), - Annotated(..), - TransformT, - Anns, - Annotate, - ) -where - -import BasicTypes (appPrec) -import Control.Applicative (Alternative) -import Control.Monad -import qualified Control.Monad.Fail as Fail -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Class -import Control.Monad.Trans.Except -import Control.Monad.Zip -import qualified Data.DList as DL -import Data.Either.Extra (mapLeft) -import Data.Functor.Classes -import Data.Functor.Contravariant -import qualified Data.Text as T -import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Service (runAction) -import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat hiding (parseExpr) -import Development.IDE.Types.Location -import Development.Shake (RuleResult, Rules) -import Development.Shake.Classes -import qualified GHC.Generics as GHC -import Generics.SYB -import Ide.PluginUtils -import Language.Haskell.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.Parsers -import Language.LSP.Types -import Language.LSP.Types.Capabilities (ClientCapabilities) -import Outputable (Outputable, ppr, showSDoc) -import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, parseType) -import Parser (parseIdentifier) -import Data.Traversable (for) -import Data.Foldable (Foldable(fold)) -import Data.Bool (bool) -#if __GLASGOW_HASKELL__ == 808 -import Control.Arrow -#endif -#if __GLASGOW_HASKELL__ > 808 -import Bag (listToBag) -import ErrUtils (mkErrMsg) -import Outputable (text, neverQualify) -#endif - - ------------------------------------------------------------------------------- - -data GetAnnotatedParsedSource = GetAnnotatedParsedSource - deriving (Eq, Show, Typeable, GHC.Generic) - -instance Hashable GetAnnotatedParsedSource -instance NFData GetAnnotatedParsedSource -instance Binary GetAnnotatedParsedSource -type instance RuleResult GetAnnotatedParsedSource = Annotated ParsedSource - --- | Get the latest version of the annotated parse source with comments. -getAnnotatedParsedSourceRule :: Rules () -getAnnotatedParsedSourceRule = define $ \GetAnnotatedParsedSource nfp -> do - pm <- use GetParsedModuleWithComments nfp - return ([], fmap annotateParsedSource pm) - -annotateParsedSource :: ParsedModule -> Annotated ParsedSource -annotateParsedSource = fixAnns - -useAnnotatedSource :: - String -> - IdeState -> - NormalizedFilePath -> - IO (Maybe (Annotated ParsedSource)) -useAnnotatedSource herald state nfp = - runAction herald state (use GetAnnotatedParsedSource nfp) ------------------------------------------------------------------------------- - -{- | A transformation for grafting source trees together. Use the semigroup - instance to combine 'Graft's, and run them via 'transform'. --} -newtype Graft m a = Graft - { runGraft :: DynFlags -> a -> TransformT m a - } - -hoistGraft :: (forall x. m x -> n x) -> Graft m a -> Graft n a -hoistGraft h (Graft f) = Graft (fmap (hoistTransform h) . f) - -newtype ExceptStringT m a = ExceptStringT {runExceptString :: ExceptT String m a} - deriving newtype - ( MonadTrans - , Monad - , Functor - , Applicative - , Alternative - , Foldable - , Contravariant - , MonadIO - , Eq1 - , Ord1 - , Show1 - , Read1 - , MonadZip - , MonadPlus - , Eq - , Ord - , Show - , Read - ) - -instance Monad m => Fail.MonadFail (ExceptStringT m) where - fail = ExceptStringT . ExceptT . pure . Left - -instance Monad m => Semigroup (Graft m a) where - Graft a <> Graft b = Graft $ \dflags -> a dflags >=> b dflags - -instance Monad m => Monoid (Graft m a) where - mempty = Graft $ const pure - ------------------------------------------------------------------------------- - --- | Convert a 'Graft' into a 'WorkspaceEdit'. -transform :: - DynFlags -> - ClientCapabilities -> - Uri -> - Graft (Either String) ParsedSource -> - Annotated ParsedSource -> - Either String WorkspaceEdit -transform dflags ccs uri f a = do - let src = printA a - a' <- transformA a $ runGraft f dflags - let res = printA a' - pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions - ------------------------------------------------------------------------------- - --- | Convert a 'Graft' into a 'WorkspaceEdit'. -transformM :: - Monad m => - DynFlags -> - ClientCapabilities -> - Uri -> - Graft (ExceptStringT m) ParsedSource -> - Annotated ParsedSource -> - m (Either String WorkspaceEdit) -transformM dflags ccs uri f a = runExceptT $ - runExceptString $ do - let src = printA a - a' <- transformA a $ runGraft f dflags - let res = printA a' - pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions - ------------------------------------------------------------------------------- - -{- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with the - given 'LHSExpr'. The node at that position must already be a 'LHsExpr', or - this is a no-op. --} -graft :: - forall ast a. - (Data a, ASTElement ast) => - SrcSpan -> - Located ast -> - Graft (Either String) a -graft dst = graftWithoutParentheses dst . maybeParensAST - --- | Like 'graft', but trusts that you have correctly inserted the parentheses --- yourself. If you haven't, the resulting AST will not be valid! -graftWithoutParentheses :: - forall ast a. - (Data a, ASTElement ast) => - SrcSpan -> - Located ast -> - Graft (Either String) a -graftWithoutParentheses dst val = Graft $ \dflags a -> do - (anns, val') <- annotate dflags val - modifyAnnsT $ mappend anns - pure $ - everywhere' - ( mkT $ - \case - (L src _ :: Located ast) | src == dst -> val' - l -> l - ) - a - - ------------------------------------------------------------------------------- - -graftWithM :: - forall ast m a. - (Fail.MonadFail m, Data a, ASTElement ast) => - SrcSpan -> - (Located ast -> TransformT m (Maybe (Located ast))) -> - Graft m a -graftWithM dst trans = Graft $ \dflags a -> do - everywhereM' - ( mkM $ - \case - val@(L src _ :: Located ast) - | src == dst -> do - mval <- trans val - case mval of - Just val' -> do - (anns, val'') <- - hoistTransform (either Fail.fail pure) $ - annotate dflags $ maybeParensAST val' - modifyAnnsT $ mappend anns - pure val'' - Nothing -> pure val - l -> pure l - ) - a - -graftWithSmallestM :: - forall ast m a. - (Fail.MonadFail m, Data a, ASTElement ast) => - SrcSpan -> - (Located ast -> TransformT m (Maybe (Located ast))) -> - Graft m a -graftWithSmallestM dst trans = Graft $ \dflags a -> do - everywhereM' - ( mkM $ - \case - val@(L src _ :: Located ast) - | dst `isSubspanOf` src -> do - mval <- trans val - case mval of - Just val' -> do - (anns, val'') <- - hoistTransform (either Fail.fail pure) $ - annotate dflags $ maybeParensAST val' - modifyAnnsT $ mappend anns - pure val'' - Nothing -> pure val - l -> pure l - ) - a - -graftDecls :: - forall a. - (HasDecls a) => - SrcSpan -> - [LHsDecl GhcPs] -> - Graft (Either String) a -graftDecls dst decs0 = Graft $ \dflags a -> do - decs <- forM decs0 $ \decl -> do - (anns, decl') <- annotateDecl dflags decl - modifyAnnsT $ mappend anns - pure decl' - let go [] = DL.empty - go (L src e : rest) - | src == dst = DL.fromList decs <> DL.fromList rest - | otherwise = DL.singleton (L src e) <> go rest - modifyDeclsT (pure . DL.toList . go) a - -graftSmallestDecls :: - forall a. - (HasDecls a) => - SrcSpan -> - [LHsDecl GhcPs] -> - Graft (Either String) a -graftSmallestDecls dst decs0 = Graft $ \dflags a -> do - decs <- forM decs0 $ \decl -> do - (anns, decl') <- annotateDecl dflags decl - modifyAnnsT $ mappend anns - pure decl' - let go [] = DL.empty - go (L src e : rest) - | dst `isSubspanOf` src = DL.fromList decs <> DL.fromList rest - | otherwise = DL.singleton (L src e) <> go rest - modifyDeclsT (pure . DL.toList . go) a - -graftSmallestDeclsWithM :: - forall a. - (HasDecls a) => - SrcSpan -> - (LHsDecl GhcPs -> TransformT (Either String) (Maybe [LHsDecl GhcPs])) -> - Graft (Either String) a -graftSmallestDeclsWithM dst toDecls = Graft $ \dflags a -> do - let go [] = pure DL.empty - go (e@(L src _) : rest) - | dst `isSubspanOf` src = toDecls e >>= \case - Just decs0 -> do - decs <- forM decs0 $ \decl -> do - (anns, decl') <- - annotateDecl dflags decl - modifyAnnsT $ mappend anns - pure decl' - pure $ DL.fromList decs <> DL.fromList rest - Nothing -> (DL.singleton e <>) <$> go rest - | otherwise = (DL.singleton e <>) <$> go rest - modifyDeclsT (fmap DL.toList . go) a - -graftDeclsWithM :: - forall a m. - (HasDecls a, Fail.MonadFail m) => - SrcSpan -> - (LHsDecl GhcPs -> TransformT m (Maybe [LHsDecl GhcPs])) -> - Graft m a -graftDeclsWithM dst toDecls = Graft $ \dflags a -> do - let go [] = pure DL.empty - go (e@(L src _) : rest) - | src == dst = toDecls e >>= \case - Just decs0 -> do - decs <- forM decs0 $ \decl -> do - (anns, decl') <- - hoistTransform (either Fail.fail pure) $ - annotateDecl dflags decl - modifyAnnsT $ mappend anns - pure decl' - pure $ DL.fromList decs <> DL.fromList rest - Nothing -> (DL.singleton e <>) <$> go rest - | otherwise = (DL.singleton e <>) <$> go rest - modifyDeclsT (fmap DL.toList . go) a - - -everywhereM' :: forall m. Monad m => GenericM m -> GenericM m -everywhereM' f = go - where - go :: GenericM m - go = gmapM go <=< f - -class (Data ast, Outputable ast) => ASTElement ast where - parseAST :: Parser (Located ast) - maybeParensAST :: Located ast -> Located ast - -instance p ~ GhcPs => ASTElement (HsExpr p) where - parseAST = parseExpr - maybeParensAST = parenthesize - -instance p ~ GhcPs => ASTElement (Pat p) where -#if __GLASGOW_HASKELL__ == 808 - parseAST = fmap (fmap $ right $ second dL) . parsePattern - maybeParensAST = dL . parenthesizePat appPrec . unLoc -#else - parseAST = parsePattern - maybeParensAST = parenthesizePat appPrec -#endif - -instance p ~ GhcPs => ASTElement (HsType p) where - parseAST = parseType - maybeParensAST = parenthesizeHsType appPrec - -instance p ~ GhcPs => ASTElement (HsDecl p) where - parseAST = parseDecl - maybeParensAST = id - -instance p ~ GhcPs => ASTElement (ImportDecl p) where - parseAST = parseImport - maybeParensAST = id - -instance ASTElement RdrName where - parseAST df fp = parseWith df fp parseIdentifier - maybeParensAST = id - ------------------------------------------------------------------------------- - --- | Dark magic I stole from retrie. No idea what it does. -fixAnns :: ParsedModule -> Annotated ParsedSource -fixAnns ParsedModule {..} = - let ranns = relativiseApiAnns pm_parsed_source pm_annotations - in unsafeMkA pm_parsed_source ranns 0 - ------------------------------------------------------------------------------- - --- | Given an 'LHSExpr', compute its exactprint annotations. --- Note that this function will throw away any existing annotations (and format) -annotate :: ASTElement ast => DynFlags -> Located ast -> TransformT (Either String) (Anns, Located ast) -annotate dflags ast = do - uniq <- show <$> uniqueSrcSpanT - let rendered = render dflags ast - (anns, expr') <- lift $ mapLeft show $ parseAST dflags uniq rendered - let anns' = setPrecedingLines expr' 0 1 anns - pure (anns', expr') - --- | Given an 'LHsDecl', compute its exactprint annotations. -annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (Anns, LHsDecl GhcPs) --- The 'parseDecl' function fails to parse 'FunBind' 'ValD's which contain --- multiple matches. To work around this, we split the single --- 'FunBind'-of-multiple-'Match'es into multiple 'FunBind's-of-one-'Match', --- and then merge them all back together. -annotateDecl dflags - (L src ( - ValD ext fb@FunBind - { fun_matches = mg@MG { mg_alts = L alt_src alts@(_:_)} - })) = do - let set_matches matches = - ValD ext fb { fun_matches = mg { mg_alts = L alt_src matches }} - - (anns', alts') <- fmap unzip $ for (zip [0..] alts) $ \(ix :: Int, alt) -> do - uniq <- show <$> uniqueSrcSpanT - let rendered = render dflags $ set_matches [alt] - lift (mapLeft show $ parseDecl dflags uniq rendered) >>= \case - (ann, L _ (ValD _ FunBind { fun_matches = MG { mg_alts = L _ [alt']}})) - -> pure (bool id (setPrecedingLines alt' 1 0) (ix /= 0) ann, alt') - _ -> lift $ Left "annotateDecl: didn't parse a single FunBind match" - - let expr' = L src $ set_matches alts' - anns'' = setPrecedingLines expr' 1 0 $ fold anns' - - pure (anns'', expr') -annotateDecl dflags ast = do - uniq <- show <$> uniqueSrcSpanT - let rendered = render dflags ast - (anns, expr') <- lift $ mapLeft show $ parseDecl dflags uniq rendered - let anns' = setPrecedingLines expr' 1 0 anns - pure (anns', expr') - ------------------------------------------------------------------------------- - --- | Print out something 'Outputable'. -render :: Outputable a => DynFlags -> a -> String -render dflags = showSDoc dflags . ppr - ------------------------------------------------------------------------------- - --- | Put parentheses around an expression if required. -parenthesize :: LHsExpr GhcPs -> LHsExpr GhcPs -parenthesize = parenthesizeHsExpr appPrec +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +module Development.IDE.GHC.ExactPrint + ( Graft(..), + graftDecls, + graftDeclsWithM, + annotate, + annotateDecl, + hoistGraft, + graftWithM, + genericGraftWithSmallestM, + genericGraftWithLargestM, + graftSmallestDeclsWithM, + transform, + transformM, + useAnnotatedSource, + annotateParsedSource, + getAnnotatedParsedSourceRule, + GetAnnotatedParsedSource(..), + ASTElement (..), + ExceptStringT (..), + Annotated(..), + TransformT, + Anns, + Annotate, + mkBindListT, + setPrecedingLinesT, + everywhereM', + ) +where + +import BasicTypes (appPrec) +import Control.Applicative (Alternative) +import Control.Monad +import qualified Control.Monad.Fail as Fail +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Control.Monad.Zip +import qualified Data.DList as DL +import Data.Either.Extra (mapLeft) +import Data.Functor.Classes +import Data.Functor.Contravariant +import qualified Data.Text as T +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Service (runAction) +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat hiding (parseExpr) +import Development.IDE.Types.Location +import Development.Shake (RuleResult, Rules) +import Development.Shake.Classes +import qualified GHC.Generics as GHC +import Generics.SYB +import Ide.PluginUtils +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Parsers +import Language.LSP.Types +import Language.LSP.Types.Capabilities (ClientCapabilities) +import Outputable (Outputable, ppr, showSDoc) +import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, parseType) +import Parser (parseIdentifier) +import Data.Traversable (for) +import Data.Foldable (Foldable(fold)) +import Data.Bool (bool) +import Data.Monoid (All(All), Any(Any)) +import Data.Functor.Compose (Compose(Compose)) +#if __GLASGOW_HASKELL__ == 808 +import Control.Arrow +#endif + + +------------------------------------------------------------------------------ + +data GetAnnotatedParsedSource = GetAnnotatedParsedSource + deriving (Eq, Show, Typeable, GHC.Generic) + +instance Hashable GetAnnotatedParsedSource +instance NFData GetAnnotatedParsedSource +instance Binary GetAnnotatedParsedSource +type instance RuleResult GetAnnotatedParsedSource = Annotated ParsedSource + +-- | Get the latest version of the annotated parse source with comments. +getAnnotatedParsedSourceRule :: Rules () +getAnnotatedParsedSourceRule = define $ \GetAnnotatedParsedSource nfp -> do + pm <- use GetParsedModuleWithComments nfp + return ([], fmap annotateParsedSource pm) + +annotateParsedSource :: ParsedModule -> Annotated ParsedSource +annotateParsedSource = fixAnns + +useAnnotatedSource :: + String -> + IdeState -> + NormalizedFilePath -> + IO (Maybe (Annotated ParsedSource)) +useAnnotatedSource herald state nfp = + runAction herald state (use GetAnnotatedParsedSource nfp) +------------------------------------------------------------------------------ + +{- | A transformation for grafting source trees together. Use the semigroup + instance to combine 'Graft's, and run them via 'transform'. +-} +newtype Graft m a = Graft + { runGraft :: DynFlags -> a -> TransformT m a + } + +hoistGraft :: (forall x. m x -> n x) -> Graft m a -> Graft n a +hoistGraft h (Graft f) = Graft (fmap (hoistTransform h) . f) + +newtype ExceptStringT m a = ExceptStringT {runExceptString :: ExceptT String m a} + deriving newtype + ( MonadTrans + , Monad + , Functor + , Applicative + , Alternative + , Foldable + , Contravariant + , MonadIO + , Eq1 + , Ord1 + , Show1 + , Read1 + , MonadZip + , MonadPlus + , Eq + , Ord + , Show + , Read + ) + +instance Monad m => Fail.MonadFail (ExceptStringT m) where + fail = ExceptStringT . ExceptT . pure . Left + +instance Monad m => Semigroup (Graft m a) where + Graft a <> Graft b = Graft $ \dflags -> a dflags >=> b dflags + +instance Monad m => Monoid (Graft m a) where + mempty = Graft $ const pure + +------------------------------------------------------------------------------ + +-- | Convert a 'Graft' into a 'WorkspaceEdit'. +transform :: + DynFlags -> + ClientCapabilities -> + Uri -> + Graft (Either String) ParsedSource -> + Annotated ParsedSource -> + Either String WorkspaceEdit +transform dflags ccs uri f a = do + let src = printA a + a' <- transformA a $ runGraft f dflags + let res = printA a' + pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions + +------------------------------------------------------------------------------ + +-- | Convert a 'Graft' into a 'WorkspaceEdit'. +transformM :: + Monad m => + DynFlags -> + ClientCapabilities -> + Uri -> + Graft (ExceptStringT m) ParsedSource -> + Annotated ParsedSource -> + m (Either String WorkspaceEdit) +transformM dflags ccs uri f a = runExceptT $ + runExceptString $ do + let src = printA a + a' <- transformA a $ runGraft f dflags + let res = printA a' + pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions + + +-- | Returns whether or not this node requires its immediate children to have +-- be parenthesized and have a leading space. +-- +-- A more natural type for this function would be to return @(Bool, Bool)@, but +-- we use 'All' instead for its monoid instance. +needsParensSpace :: + HsExpr GhcPs -> + -- | (Needs parens, needs space) + (All, All) +needsParensSpace HsLam{} = (All False, All False) +needsParensSpace HsLamCase{} = (All False, All False) +needsParensSpace HsApp{} = mempty +needsParensSpace HsAppType{} = mempty +needsParensSpace OpApp{} = mempty +needsParensSpace HsPar{} = (All False, All False) +needsParensSpace SectionL{} = (All False, All False) +needsParensSpace SectionR{} = (All False, All False) +needsParensSpace ExplicitTuple{} = (All False, All False) +needsParensSpace ExplicitSum{} = (All False, All False) +needsParensSpace HsCase{} = (All False, All False) +needsParensSpace HsIf{} = (All False, All False) +needsParensSpace HsMultiIf{} = (All False, All False) +needsParensSpace HsLet{} = (All False, All True) +needsParensSpace HsDo{} = (All False, All False) +needsParensSpace ExplicitList{} = (All False, All False) +needsParensSpace RecordCon{} = (All False, All False) +needsParensSpace RecordUpd{} = mempty +needsParensSpace _ = mempty + + +------------------------------------------------------------------------------ + +{- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with the + given @Located ast@. The node at that position must already be a @Located + ast@, or this is a no-op. +-} +graft' :: + forall ast a. + (Data a, ASTElement ast) => + -- | Do we need to insert a space before this grafting? In do blocks, the + -- answer is no, or we will break layout. But in function applications, + -- the answer is yes, or the function call won't get its argument. Yikes! + -- + -- More often the answer is yes, so when in doubt, use that. + Bool -> + SrcSpan -> + Located ast -> + Graft (Either String) a +graft' needs_space dst val = Graft $ \dflags a -> do + (anns, val') <- annotate dflags needs_space val + modifyAnnsT $ mappend anns + pure $ + everywhere' + ( mkT $ + \case + (L src _ :: Located ast) | src == dst -> val' + l -> l + ) + a + +-- | Like 'graft', but specialized to 'LHsExpr', and intelligently inserts +-- parentheses if they're necessary. +graftExpr :: + forall a. + (Data a) => + SrcSpan -> + LHsExpr GhcPs -> + Graft (Either String) a +graftExpr dst val = Graft $ \dflags a -> do + -- Traverse the tree, looking for our replacement node. But keep track of + -- the context (parent HsExpr constructor) we're in while we do it. This + -- lets us determine wehther or not we need parentheses. + let (All needs_parens, All needs_space) = + everythingWithContext (All True, All True) (<>) + ( mkQ (mempty, ) $ \x s -> case x of + (L src _ :: LHsExpr GhcPs) | src == dst -> + (s, s) + L _ x' -> (mempty, needsParensSpace x') + ) a + + runGraft + (graft' needs_space dst $ bool id maybeParensAST needs_parens val) + dflags + a + + +------------------------------------------------------------------------------ + +graftWithM :: + forall ast m a. + (Fail.MonadFail m, Data a, ASTElement ast) => + SrcSpan -> + (Located ast -> TransformT m (Maybe (Located ast))) -> + Graft m a +graftWithM dst trans = Graft $ \dflags a -> do + everywhereM' + ( mkM $ + \case + val@(L src _ :: Located ast) + | src == dst -> do + mval <- trans val + case mval of + Just val' -> do + (anns, val'') <- + hoistTransform (either Fail.fail pure) $ + annotate dflags True $ maybeParensAST val' + modifyAnnsT $ mappend anns + pure val'' + Nothing -> pure val + l -> pure l + ) + a + +-- | A generic query intended to be used for calling 'smallestM' and +-- 'largestM'. If the current node is a 'Located', returns whether or not the +-- given 'SrcSpan' is a subspan. For all other nodes, returns 'Nothing', which +-- indicates uncertainty. The search strategy in 'smallestM' et al. will +-- continue searching uncertain nodes. +genericIsSubspan :: + forall ast. + Typeable ast => + -- | The type of nodes we'd like to consider. + Proxy (Located ast) -> + SrcSpan -> + GenericQ (Maybe Bool) +genericIsSubspan _ dst = mkQ Nothing $ \case + (L span _ :: Located ast) -> Just $ dst `isSubspanOf` span + +-- | Run the given transformation only on the smallest node in the tree that +-- contains the 'SrcSpan'. +genericGraftWithSmallestM :: + forall m a ast. + (Monad m, Data a, Typeable ast) => + -- | The type of nodes we'd like to consider when finding the smallest. + Proxy (Located ast) -> + SrcSpan -> + (DynFlags -> GenericM (TransformT m)) -> + Graft m a +genericGraftWithSmallestM proxy dst trans = Graft $ \dflags -> + smallestM (genericIsSubspan proxy dst) (trans dflags) + +-- | Run the given transformation only on the largest node in the tree that +-- contains the 'SrcSpan'. +genericGraftWithLargestM :: + forall m a ast. + (Monad m, Data a, Typeable ast) => + -- | The type of nodes we'd like to consider when finding the largest. + Proxy (Located ast) -> + SrcSpan -> + (DynFlags -> GenericM (TransformT m)) -> + Graft m a +genericGraftWithLargestM proxy dst trans = Graft $ \dflags -> + largestM (genericIsSubspan proxy dst) (trans dflags) + + +-- | Lift a function that replaces a value with several values into a generic +-- function. The result doesn't perform any searching, so should be driven via +-- 'everywhereM' or friends. +-- +-- The 'Int' argument is the index in the list being bound. +mkBindListT :: forall b m. (Typeable b, Data b, Monad m) => (Int -> b -> m [b]) -> GenericM m +mkBindListT f = mkM $ fmap join . traverse (uncurry f) . zip [0..] + + +graftDecls :: + forall a. + (HasDecls a) => + SrcSpan -> + [LHsDecl GhcPs] -> + Graft (Either String) a +graftDecls dst decs0 = Graft $ \dflags a -> do + decs <- forM decs0 $ \decl -> do + annotateDecl dflags decl + let go [] = DL.empty + go (L src e : rest) + | src == dst = DL.fromList decs <> DL.fromList rest + | otherwise = DL.singleton (L src e) <> go rest + modifyDeclsT (pure . DL.toList . go) a + +graftSmallestDeclsWithM :: + forall a. + (HasDecls a) => + SrcSpan -> + (LHsDecl GhcPs -> TransformT (Either String) (Maybe [LHsDecl GhcPs])) -> + Graft (Either String) a +graftSmallestDeclsWithM dst toDecls = Graft $ \dflags a -> do + let go [] = pure DL.empty + go (e@(L src _) : rest) + | dst `isSubspanOf` src = toDecls e >>= \case + Just decs0 -> do + decs <- forM decs0 $ \decl -> + annotateDecl dflags decl + pure $ DL.fromList decs <> DL.fromList rest + Nothing -> (DL.singleton e <>) <$> go rest + | otherwise = (DL.singleton e <>) <$> go rest + modifyDeclsT (fmap DL.toList . go) a + +graftDeclsWithM :: + forall a m. + (HasDecls a, Fail.MonadFail m) => + SrcSpan -> + (LHsDecl GhcPs -> TransformT m (Maybe [LHsDecl GhcPs])) -> + Graft m a +graftDeclsWithM dst toDecls = Graft $ \dflags a -> do + let go [] = pure DL.empty + go (e@(L src _) : rest) + | src == dst = toDecls e >>= \case + Just decs0 -> do + decs <- forM decs0 $ \decl -> + hoistTransform (either Fail.fail pure) $ + annotateDecl dflags decl + pure $ DL.fromList decs <> DL.fromList rest + Nothing -> (DL.singleton e <>) <$> go rest + | otherwise = (DL.singleton e <>) <$> go rest + modifyDeclsT (fmap DL.toList . go) a + + +everywhereM' :: forall m. Monad m => GenericM m -> GenericM m +everywhereM' f = go + where + go :: GenericM m + go = gmapM go <=< f + +class (Data ast, Outputable ast) => ASTElement ast where + parseAST :: Parser (Located ast) + maybeParensAST :: Located ast -> Located ast + {- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with + the given @Located ast@. The node at that position must already be + a @Located ast@, or this is a no-op. + -} + graft :: + forall a. + (Data a) => + SrcSpan -> + Located ast -> + Graft (Either String) a + graft dst = graft' True dst . maybeParensAST + +instance p ~ GhcPs => ASTElement (HsExpr p) where + parseAST = parseExpr + maybeParensAST = parenthesize + graft = graftExpr + +instance p ~ GhcPs => ASTElement (Pat p) where +#if __GLASGOW_HASKELL__ == 808 + parseAST = fmap (fmap $ right $ second dL) . parsePattern + maybeParensAST = dL . parenthesizePat appPrec . unLoc +#else + parseAST = parsePattern + maybeParensAST = parenthesizePat appPrec +#endif + +instance p ~ GhcPs => ASTElement (HsType p) where + parseAST = parseType + maybeParensAST = parenthesizeHsType appPrec + +instance p ~ GhcPs => ASTElement (HsDecl p) where + parseAST = parseDecl + maybeParensAST = id + +instance p ~ GhcPs => ASTElement (ImportDecl p) where + parseAST = parseImport + maybeParensAST = id + +instance ASTElement RdrName where + parseAST df fp = parseWith df fp parseIdentifier + maybeParensAST = id + +------------------------------------------------------------------------------ + +-- | Dark magic I stole from retrie. No idea what it does. +fixAnns :: ParsedModule -> Annotated ParsedSource +fixAnns ParsedModule {..} = + let ranns = relativiseApiAnns pm_parsed_source pm_annotations + in unsafeMkA pm_parsed_source ranns 0 + +------------------------------------------------------------------------------ + +-- | Given an 'LHSExpr', compute its exactprint annotations. +-- Note that this function will throw away any existing annotations (and format) +annotate :: ASTElement ast => DynFlags -> Bool -> Located ast -> TransformT (Either String) (Anns, Located ast) +annotate dflags needs_space ast = do + uniq <- show <$> uniqueSrcSpanT + let rendered = render dflags ast + (anns, expr') <- lift $ mapLeft show $ parseAST dflags uniq rendered + let anns' = setPrecedingLines expr' 0 (bool 0 1 needs_space) anns + pure (anns', expr') + +-- | Given an 'LHsDecl', compute its exactprint annotations. +annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (LHsDecl GhcPs) +-- The 'parseDecl' function fails to parse 'FunBind' 'ValD's which contain +-- multiple matches. To work around this, we split the single +-- 'FunBind'-of-multiple-'Match'es into multiple 'FunBind's-of-one-'Match', +-- and then merge them all back together. +annotateDecl dflags + (L src ( + ValD ext fb@FunBind + { fun_matches = mg@MG { mg_alts = L alt_src alts@(_:_)} + })) = do + let set_matches matches = + ValD ext fb { fun_matches = mg { mg_alts = L alt_src matches }} + + (anns', alts') <- fmap unzip $ for alts $ \alt -> do + uniq <- show <$> uniqueSrcSpanT + let rendered = render dflags $ set_matches [alt] + lift (mapLeft show $ parseDecl dflags uniq rendered) >>= \case + (ann, L _ (ValD _ FunBind { fun_matches = MG { mg_alts = L _ [alt']}})) + -> pure (setPrecedingLines alt' 1 0 ann, alt') + _ -> lift $ Left "annotateDecl: didn't parse a single FunBind match" + + modifyAnnsT $ mappend $ fold anns' + pure $ L src $ set_matches alts' +annotateDecl dflags ast = do + uniq <- show <$> uniqueSrcSpanT + let rendered = render dflags ast + (anns, expr') <- lift $ mapLeft show $ parseDecl dflags uniq rendered + let anns' = setPrecedingLines expr' 1 0 anns + modifyAnnsT $ mappend anns' + pure expr' + +------------------------------------------------------------------------------ + +-- | Print out something 'Outputable'. +render :: Outputable a => DynFlags -> a -> String +render dflags = showSDoc dflags . ppr + +------------------------------------------------------------------------------ + +-- | Put parentheses around an expression if required. +parenthesize :: LHsExpr GhcPs -> LHsExpr GhcPs +parenthesize = parenthesizeHsExpr appPrec + + +------------------------------------------------------------------------------ +-- Custom SYB machinery +------------------------------------------------------------------------------ + +-- | Generic monadic transformations that return side-channel data. +type GenericMQ r m = forall a. Data a => a -> m (r, a) + +------------------------------------------------------------------------------ +-- | Apply the given 'GenericM' at all every node whose children fail the +-- 'GenericQ', but which passes the query itself. +-- +-- The query must be a monotonic function when it returns 'Just'. That is, if +-- @s@ is a subtree of @t@, @q t@ should return @Just True@ if @q s@ does. It +-- is the True-to-false edge of the query that triggers the transformation. +-- +-- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes +-- with data nodes, so for any given node we can only definitely return an +-- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is +-- used. +smallestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m +smallestM q f = fmap snd . go + where + go :: GenericMQ Any m + go x = do + case q x of + Nothing -> gmapMQ go x + Just True -> do + it@(r, x') <- gmapMQ go x + case r of + Any True -> pure it + Any False -> fmap (Any True,) $ f x' + Just False -> pure (mempty, x) + +------------------------------------------------------------------------------ +-- | Apply the given 'GenericM' at every node that passes the 'GenericQ', but +-- don't descend into children if the query matches. Because this traversal is +-- root-first, this policy will find the largest subtrees for which the query +-- holds true. +-- +-- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes +-- with data nodes, so for any given node we can only definitely return an +-- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is +-- used. +largestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m +largestM q f = go + where + go :: GenericM m + go x = do + case q x of + Just True -> f x + Just False -> pure x + Nothing -> gmapM go x + +newtype MonadicQuery r m a = MonadicQuery + { runMonadicQuery :: m (r, a) + } + deriving stock (Functor) + deriving Applicative via Compose m ((,) r) + + +------------------------------------------------------------------------------ +-- | Like 'gmapM', but also returns side-channel data. +gmapMQ :: + forall f r a. (Monoid r, Data a, Applicative f) => + (forall d. Data d => d -> f (r, d)) -> + a -> + f (r, a) +gmapMQ f = runMonadicQuery . gfoldl k pure + where + k :: Data d => MonadicQuery r f (d -> b) -> d -> MonadicQuery r f b + k c x = c <*> MonadicQuery (f x) + diff --git a/src/Development/IDE/GHC/Orphans.hs b/src/Development/IDE/GHC/Orphans.hs --- a/src/Development/IDE/GHC/Orphans.hs +++ b/src/Development/IDE/GHC/Orphans.hs @@ -1,153 +1,153 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} -#include "ghc-api-version.h" - --- | Orphan instances for GHC. --- Note that the 'NFData' instances may not be law abiding. -module Development.IDE.GHC.Orphans() where - -import Bag -import Control.DeepSeq -import Data.Aeson -import Data.Hashable -import Development.IDE.GHC.Compat -import Development.IDE.GHC.Util -import GHC () -import GhcPlugins -import qualified StringBuffer as SB -import Data.Text (Text) -import Data.String (IsString(fromString)) -import Retrie.ExactPrint (Annotated) - - --- Orphan instances for types from the GHC API. -instance Show CoreModule where show = prettyPrint -instance NFData CoreModule where rnf = rwhnf -instance Show CgGuts where show = prettyPrint . cg_module -instance NFData CgGuts where rnf = rwhnf -instance Show ModDetails where show = const "" -instance NFData ModDetails where rnf = rwhnf -instance NFData SafeHaskellMode where rnf = rwhnf -instance Show Linkable where show = prettyPrint -instance NFData Linkable where rnf = rwhnf -instance Show PackageFlag where show = prettyPrint -instance Show InteractiveImport where show = prettyPrint -instance Show ComponentId where show = prettyPrint -instance Show PackageName where show = prettyPrint -instance Show SourcePackageId where show = prettyPrint - -instance Show InstalledUnitId where - show = installedUnitIdString - -instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS - -instance NFData SB.StringBuffer where rnf = rwhnf - -instance Show Module where - show = moduleNameString . moduleName - -instance Outputable a => Show (GenLocated SrcSpan a) where show = prettyPrint - -instance (NFData l, NFData e) => NFData (GenLocated l e) where - rnf (L l e) = rnf l `seq` rnf e - -instance Show ModSummary where - show = show . ms_mod - -instance Show ParsedModule where - show = show . pm_mod_summary - -instance NFData ModSummary where - rnf = rwhnf - -#if !MIN_GHC_API_VERSION(8,10,0) -instance NFData FastString where - rnf = rwhnf -#endif - -instance NFData ParsedModule where - rnf = rwhnf - -instance Hashable InstalledUnitId where - hashWithSalt salt = hashWithSalt salt . installedUnitIdString - -instance Show HieFile where - show = show . hie_module - -instance NFData HieFile where - rnf = rwhnf - -deriving instance Eq SourceModified -deriving instance Show SourceModified -instance NFData SourceModified where - rnf = rwhnf - -instance Show ModuleName where - show = moduleNameString -instance Hashable ModuleName where - hashWithSalt salt = hashWithSalt salt . show - - -instance NFData a => NFData (IdentifierDetails a) where - rnf (IdentifierDetails a b) = rnf a `seq` rnf (length b) - -instance NFData RealSrcSpan where - rnf = rwhnf - -srcSpanFileTag, srcSpanStartLineTag, srcSpanStartColTag, - srcSpanEndLineTag, srcSpanEndColTag :: Text -srcSpanFileTag = "srcSpanFile" -srcSpanStartLineTag = "srcSpanStartLine" -srcSpanStartColTag = "srcSpanStartCol" -srcSpanEndLineTag = "srcSpanEndLine" -srcSpanEndColTag = "srcSpanEndCol" - -instance ToJSON RealSrcSpan where - toJSON spn = - object - [ srcSpanFileTag .= unpackFS (srcSpanFile spn) - , srcSpanStartLineTag .= srcSpanStartLine spn - , srcSpanStartColTag .= srcSpanStartCol spn - , srcSpanEndLineTag .= srcSpanEndLine spn - , srcSpanEndColTag .= srcSpanEndCol spn - ] - -instance FromJSON RealSrcSpan where - parseJSON = withObject "object" $ \obj -> do - file <- fromString <$> (obj .: srcSpanFileTag) - mkRealSrcSpan - <$> (mkRealSrcLoc file - <$> obj .: srcSpanStartLineTag - <*> obj .: srcSpanStartColTag - ) - <*> (mkRealSrcLoc file - <$> obj .: srcSpanEndLineTag - <*> obj .: srcSpanEndColTag - ) - -instance NFData Type where - rnf = rwhnf - -instance Show a => Show (Bag a) where - show = show . bagToList - -instance NFData HsDocString where - rnf = rwhnf - -instance Show ModGuts where - show _ = "modguts" -instance NFData ModGuts where - rnf = rwhnf - -instance NFData (ImportDecl GhcPs) where - rnf = rwhnf - -instance Show (Annotated ParsedSource) where - show _ = "" - -instance NFData (Annotated ParsedSource) where - rnf = rwhnf +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} +#include "ghc-api-version.h" + +-- | Orphan instances for GHC. +-- Note that the 'NFData' instances may not be law abiding. +module Development.IDE.GHC.Orphans() where + +import Bag +import Control.DeepSeq +import Data.Aeson +import Data.Hashable +import Data.String (IsString (fromString)) +import Data.Text (Text) +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Util +import GHC () +import GhcPlugins +import Retrie.ExactPrint (Annotated) +import qualified StringBuffer as SB + + +-- Orphan instances for types from the GHC API. +instance Show CoreModule where show = prettyPrint +instance NFData CoreModule where rnf = rwhnf +instance Show CgGuts where show = prettyPrint . cg_module +instance NFData CgGuts where rnf = rwhnf +instance Show ModDetails where show = const "" +instance NFData ModDetails where rnf = rwhnf +instance NFData SafeHaskellMode where rnf = rwhnf +instance Show Linkable where show = prettyPrint +instance NFData Linkable where rnf = rwhnf +instance Show PackageFlag where show = prettyPrint +instance Show InteractiveImport where show = prettyPrint +instance Show ComponentId where show = prettyPrint +instance Show PackageName where show = prettyPrint +instance Show SourcePackageId where show = prettyPrint + +instance Show InstalledUnitId where + show = installedUnitIdString + +instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS + +instance NFData SB.StringBuffer where rnf = rwhnf + +instance Show Module where + show = moduleNameString . moduleName + +instance Outputable a => Show (GenLocated SrcSpan a) where show = prettyPrint + +instance (NFData l, NFData e) => NFData (GenLocated l e) where + rnf (L l e) = rnf l `seq` rnf e + +instance Show ModSummary where + show = show . ms_mod + +instance Show ParsedModule where + show = show . pm_mod_summary + +instance NFData ModSummary where + rnf = rwhnf + +#if !MIN_GHC_API_VERSION(8,10,0) +instance NFData FastString where + rnf = rwhnf +#endif + +instance NFData ParsedModule where + rnf = rwhnf + +instance Hashable InstalledUnitId where + hashWithSalt salt = hashWithSalt salt . installedUnitIdString + +instance Show HieFile where + show = show . hie_module + +instance NFData HieFile where + rnf = rwhnf + +deriving instance Eq SourceModified +deriving instance Show SourceModified +instance NFData SourceModified where + rnf = rwhnf + +instance Show ModuleName where + show = moduleNameString +instance Hashable ModuleName where + hashWithSalt salt = hashWithSalt salt . show + + +instance NFData a => NFData (IdentifierDetails a) where + rnf (IdentifierDetails a b) = rnf a `seq` rnf (length b) + +instance NFData RealSrcSpan where + rnf = rwhnf + +srcSpanFileTag, srcSpanStartLineTag, srcSpanStartColTag, + srcSpanEndLineTag, srcSpanEndColTag :: Text +srcSpanFileTag = "srcSpanFile" +srcSpanStartLineTag = "srcSpanStartLine" +srcSpanStartColTag = "srcSpanStartCol" +srcSpanEndLineTag = "srcSpanEndLine" +srcSpanEndColTag = "srcSpanEndCol" + +instance ToJSON RealSrcSpan where + toJSON spn = + object + [ srcSpanFileTag .= unpackFS (srcSpanFile spn) + , srcSpanStartLineTag .= srcSpanStartLine spn + , srcSpanStartColTag .= srcSpanStartCol spn + , srcSpanEndLineTag .= srcSpanEndLine spn + , srcSpanEndColTag .= srcSpanEndCol spn + ] + +instance FromJSON RealSrcSpan where + parseJSON = withObject "object" $ \obj -> do + file <- fromString <$> (obj .: srcSpanFileTag) + mkRealSrcSpan + <$> (mkRealSrcLoc file + <$> obj .: srcSpanStartLineTag + <*> obj .: srcSpanStartColTag + ) + <*> (mkRealSrcLoc file + <$> obj .: srcSpanEndLineTag + <*> obj .: srcSpanEndColTag + ) + +instance NFData Type where + rnf = rwhnf + +instance Show a => Show (Bag a) where + show = show . bagToList + +instance NFData HsDocString where + rnf = rwhnf + +instance Show ModGuts where + show _ = "modguts" +instance NFData ModGuts where + rnf = rwhnf + +instance NFData (ImportDecl GhcPs) where + rnf = rwhnf + +instance Show (Annotated ParsedSource) where + show _ = "" + +instance NFData (Annotated ParsedSource) where + rnf = rwhnf diff --git a/src/Development/IDE/GHC/Util.hs b/src/Development/IDE/GHC/Util.hs --- a/src/Development/IDE/GHC/Util.hs +++ b/src/Development/IDE/GHC/Util.hs @@ -1,263 +1,280 @@ -{-# LANGUAGE CPP #-} --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - --- | General utility functions, mostly focused around GHC operations. -module Development.IDE.GHC.Util( - modifyDynFlags, - evalGhcEnv, - -- * GHC wrappers - prettyPrint, - unsafePrintSDoc, - printRdrName, - printName, - ParseResult(..), runParser, - lookupPackageConfig, - textToStringBuffer, - bytestringToStringBuffer, - stringBufferToByteString, - moduleImportPath, - cgGutsToCoreModule, - fingerprintToBS, - fingerprintFromStringBuffer, - -- * General utilities - readFileUtf8, - hDuplicateTo', - setHieDir, - dontWriteHieFiles, - disableWarningsAsErrors, - ) where - -import Control.Concurrent -import Data.List.Extra -import Data.ByteString.Internal (ByteString(..)) -import Data.Maybe -import Data.Typeable -import qualified Data.ByteString.Internal as BS -import Fingerprint -import GhcMonad -import DynFlags -import Control.Exception -import Data.IORef -import FileCleanup -import Foreign.Ptr -import Foreign.ForeignPtr -import Foreign.Storable -import GHC.IO.BufferedIO (BufferedIO) -import GHC.IO.Device as IODevice -import GHC.IO.Encoding -import GHC.IO.Exception -import GHC.IO.Handle.Types -import GHC.IO.Handle.Internals -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T -import qualified Data.ByteString as BS -import Lexer -import StringBuffer -import System.FilePath -import HscTypes (cg_binds, md_types, cg_module, ModDetails, CgGuts, ic_dflags, hsc_IC, HscEnv(hsc_dflags)) -import PackageConfig (PackageConfig) -import Outputable (SDoc, showSDocUnsafe, ppr, Outputable, mkUserStyle, renderWithStyle, neverQualify, Depth(..)) -import Packages (getPackageConfigMap, lookupPackage') -import SrcLoc (mkRealSrcLoc) -import FastString (mkFastString) -import Module (moduleNameSlashes) -import OccName (parenSymOcc) -import RdrName (nameRdrName, rdrNameOcc) - -import Development.IDE.GHC.Compat as GHC -import Development.IDE.Types.Location - - ----------------------------------------------------------------------- --- GHC setup - --- | Used to modify dyn flags in preference to calling 'setSessionDynFlags', --- since that function also reloads packages (which is very slow). -modifyDynFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m () -modifyDynFlags f = do - newFlags <- f <$> getSessionDynFlags - -- We do not use setSessionDynFlags here since we handle package - -- initialization separately. - modifySession $ \h -> - h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} } - --- | Given a 'UnitId' try and find the associated 'PackageConfig' in the environment. -lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig -lookupPackageConfig unitId env = - lookupPackage' False pkgConfigMap unitId - where - pkgConfigMap = - -- For some weird reason, the GHC API does not provide a way to get the PackageConfigMap - -- from PackageState so we have to wrap it in DynFlags first. - getPackageConfigMap $ hsc_dflags env - - --- | Convert from the @text@ package to the @GHC@ 'StringBuffer'. --- Currently implemented somewhat inefficiently (if it ever comes up in a profile). -textToStringBuffer :: T.Text -> StringBuffer -textToStringBuffer = stringToStringBuffer . T.unpack - -runParser :: DynFlags -> String -> P a -> ParseResult a -runParser flags str parser = unP parser parseState - where - filename = "" - location = mkRealSrcLoc (mkFastString filename) 1 1 - buffer = stringToStringBuffer str - parseState = mkPState flags buffer location - -stringBufferToByteString :: StringBuffer -> ByteString -stringBufferToByteString StringBuffer{..} = PS buf cur len - -bytestringToStringBuffer :: ByteString -> StringBuffer -bytestringToStringBuffer (PS buf cur len) = StringBuffer{..} - --- | Pretty print a GHC value using 'unsafeGlobalDynFlags '. -prettyPrint :: Outputable a => a -> String -prettyPrint = unsafePrintSDoc . ppr - -unsafePrintSDoc :: SDoc -> String -unsafePrintSDoc sdoc = renderWithStyle dflags sdoc (mkUserStyle dflags neverQualify AllTheWay) - where - dflags = unsafeGlobalDynFlags - --- | Pretty print a 'RdrName' wrapping operators in parens -printRdrName :: RdrName -> String -printRdrName name = showSDocUnsafe $ parenSymOcc rn (ppr rn) - where - rn = rdrNameOcc name - --- | Pretty print a 'Name' wrapping operators in parens -printName :: Name -> String -printName = printRdrName . nameRdrName - --- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required --- pieces, but designed to be more efficient than a standard 'runGhc'. -evalGhcEnv :: HscEnv -> Ghc b -> IO b -evalGhcEnv env act = snd <$> runGhcEnv env act - --- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required --- pieces, but designed to be more efficient than a standard 'runGhc'. -runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a) -runGhcEnv env act = do - filesToClean <- newIORef emptyFilesToClean - dirsToClean <- newIORef mempty - let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True} - ref <- newIORef env{hsc_dflags=dflags} - res <- unGhc act (Session ref) `finally` do - cleanTempFiles dflags - cleanTempDirs dflags - (,res) <$> readIORef ref - --- | Given a module location, and its parse tree, figure out what is the include directory implied by it. --- For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory --- @\/usr\/Test@ should be on the include path to find sibling modules. -moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath --- The call to takeDirectory is required since DAML does not require that --- the file name matches the module name in the last component. --- Once that has changed we can get rid of this. -moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn - -- This happens for single-component modules since takeDirectory "A" == "." - | modDir == "." = Just pathDir - | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir - where - -- A for module A.B - modDir = - takeDirectory $ - fromNormalizedFilePath $ toNormalizedFilePath' $ - moduleNameSlashes mn - --- | Read a UTF8 file, with lenient decoding, so it will never raise a decoding error. -readFileUtf8 :: FilePath -> IO T.Text -readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f - --- | Convert from a 'CgGuts' to a 'CoreModule'. -cgGutsToCoreModule :: SafeHaskellMode -> CgGuts -> ModDetails -> CoreModule -cgGutsToCoreModule safeMode guts modDetails = CoreModule - (cg_module guts) - (md_types modDetails) - (cg_binds guts) - safeMode - --- | Convert a 'Fingerprint' to a 'ByteString' by copying the byte across. --- Will produce an 8 byte unreadable ByteString. -fingerprintToBS :: Fingerprint -> BS.ByteString -fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do - ptr <- pure $ castPtr ptr - pokeElemOff ptr 0 a - pokeElemOff ptr 1 b - --- | Take the 'Fingerprint' of a 'StringBuffer'. -fingerprintFromStringBuffer :: StringBuffer -> IO Fingerprint -fingerprintFromStringBuffer (StringBuffer buf len cur) = - withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len - - --- | A slightly modified version of 'hDuplicateTo' from GHC. --- Importantly, it avoids the bug listed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2318. -hDuplicateTo' :: Handle -> Handle -> IO () -hDuplicateTo' h1@(FileHandle path m1) h2@(FileHandle _ m2) = do - withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do - -- The implementation in base has this call to hClose_help. - -- _ <- hClose_help h2_ - -- hClose_help does two things: - -- 1. It flushes the buffer, we replicate this here - _ <- flushWriteBuffer h2_ `catch` \(_ :: IOException) -> pure () - -- 2. It closes the handle. This is redundant since dup2 takes care of that - -- but even worse it is actively harmful! Once the handle has been closed - -- another thread is free to reallocate it. This leads to dup2 failing with EBUSY - -- if it happens just in the right moment. - withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do - dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer) -hDuplicateTo' h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2) = do - withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do - _ <- hClose_help w2_ - withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do - dupHandleTo path h1 Nothing w2_ w1_ (Just handleFinalizer) - withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do - _ <- hClose_help r2_ - withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do - dupHandleTo path h1 (Just w1) r2_ r1_ Nothing -hDuplicateTo' h1 _ = - ioe_dupHandlesNotCompatible h1 - --- | This is copied unmodified from GHC since it is not exposed. -dupHandleTo :: FilePath - -> Handle - -> Maybe (MVar Handle__) - -> Handle__ - -> Handle__ - -> Maybe HandleFinalizer - -> IO Handle__ -dupHandleTo filepath h other_side - _hto_@Handle__{haDevice=devTo} - h_@Handle__{haDevice=dev} mb_finalizer = do - flushBuffer h_ - case cast devTo of - Nothing -> ioe_dupHandlesNotCompatible h - Just dev' -> do - _ <- IODevice.dup2 dev dev' - FileHandle _ m <- dupHandle_ dev' filepath other_side h_ mb_finalizer - takeMVar m - --- | This is copied unmodified from GHC since it is not exposed. --- Note the beautiful inline comment! -dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev - -> FilePath - -> Maybe (MVar Handle__) - -> Handle__ - -> Maybe HandleFinalizer - -> IO Handle -dupHandle_ new_dev filepath other_side _h_@Handle__{..} mb_finalizer = do - -- XXX wrong! - mb_codec <- if isJust haEncoder then fmap Just getLocaleEncoding else return Nothing - mkHandle new_dev filepath haType True{-buffered-} mb_codec - NewlineMode { inputNL = haInputNL, outputNL = haOutputNL } - mb_finalizer other_side - --- | This is copied unmodified from GHC since it is not exposed. -ioe_dupHandlesNotCompatible :: Handle -> IO a -ioe_dupHandlesNotCompatible h = - ioException (IOError (Just h) IllegalOperation "hDuplicateTo" - "handles are incompatible" Nothing Nothing) +{-# LANGUAGE CPP #-} +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +-- | General utility functions, mostly focused around GHC operations. +module Development.IDE.GHC.Util( + modifyDynFlags, + evalGhcEnv, + -- * GHC wrappers + prettyPrint, + unsafePrintSDoc, + printRdrName, + printName, + ParseResult(..), runParser, + lookupPackageConfig, + textToStringBuffer, + bytestringToStringBuffer, + stringBufferToByteString, + moduleImportPath, + cgGutsToCoreModule, + fingerprintToBS, + fingerprintFromByteString, + fingerprintFromStringBuffer, + fingerprintFromPut, + -- * General utilities + readFileUtf8, + hDuplicateTo', + setHieDir, + dontWriteHieFiles, + disableWarningsAsErrors, + ) where + +import Control.Concurrent +import Control.Exception +import Data.Binary.Put (Put, runPut) +import qualified Data.ByteString as BS +import Data.ByteString.Internal (ByteString (..)) +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Lazy as LBS +import Data.IORef +import Data.List.Extra +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +import Data.Typeable +import Development.IDE.GHC.Compat as GHC +import Development.IDE.Types.Location +import FastString (mkFastString) +import FileCleanup +import Fingerprint +import Foreign.ForeignPtr +import Foreign.Ptr +import Foreign.Storable +import GHC.IO.BufferedIO (BufferedIO) +import GHC.IO.Device as IODevice +import GHC.IO.Encoding +import GHC.IO.Exception +import GHC.IO.Handle.Internals +import GHC.IO.Handle.Types +import GhcMonad +import HscTypes (CgGuts, HscEnv (hsc_dflags), + ModDetails, cg_binds, + cg_module, hsc_IC, ic_dflags, + md_types) +import Lexer +import Module (moduleNameSlashes) +import OccName (parenSymOcc) +import Outputable (Depth (..), Outputable, SDoc, + mkUserStyle, neverQualify, ppr, + renderWithStyle, + showSDocUnsafe) +import PackageConfig (PackageConfig) +import Packages (getPackageConfigMap, + lookupPackage') +import RdrName (nameRdrName, rdrNameOcc) +import SrcLoc (mkRealSrcLoc) +import StringBuffer +import System.FilePath + + +---------------------------------------------------------------------- +-- GHC setup + +-- | Used to modify dyn flags in preference to calling 'setSessionDynFlags', +-- since that function also reloads packages (which is very slow). +modifyDynFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m () +modifyDynFlags f = do + newFlags <- f <$> getSessionDynFlags + -- We do not use setSessionDynFlags here since we handle package + -- initialization separately. + modifySession $ \h -> + h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} } + +-- | Given a 'UnitId' try and find the associated 'PackageConfig' in the environment. +lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig +lookupPackageConfig unitId env = + lookupPackage' False pkgConfigMap unitId + where + pkgConfigMap = + -- For some weird reason, the GHC API does not provide a way to get the PackageConfigMap + -- from PackageState so we have to wrap it in DynFlags first. + getPackageConfigMap $ hsc_dflags env + + +-- | Convert from the @text@ package to the @GHC@ 'StringBuffer'. +-- Currently implemented somewhat inefficiently (if it ever comes up in a profile). +textToStringBuffer :: T.Text -> StringBuffer +textToStringBuffer = stringToStringBuffer . T.unpack + +runParser :: DynFlags -> String -> P a -> ParseResult a +runParser flags str parser = unP parser parseState + where + filename = "" + location = mkRealSrcLoc (mkFastString filename) 1 1 + buffer = stringToStringBuffer str + parseState = mkPState flags buffer location + +stringBufferToByteString :: StringBuffer -> ByteString +stringBufferToByteString StringBuffer{..} = PS buf cur len + +bytestringToStringBuffer :: ByteString -> StringBuffer +bytestringToStringBuffer (PS buf cur len) = StringBuffer{..} + +-- | Pretty print a GHC value using 'unsafeGlobalDynFlags '. +prettyPrint :: Outputable a => a -> String +prettyPrint = unsafePrintSDoc . ppr + +unsafePrintSDoc :: SDoc -> String +unsafePrintSDoc sdoc = renderWithStyle dflags sdoc (mkUserStyle dflags neverQualify AllTheWay) + where + dflags = unsafeGlobalDynFlags + +-- | Pretty print a 'RdrName' wrapping operators in parens +printRdrName :: RdrName -> String +printRdrName name = showSDocUnsafe $ parenSymOcc rn (ppr rn) + where + rn = rdrNameOcc name + +-- | Pretty print a 'Name' wrapping operators in parens +printName :: Name -> String +printName = printRdrName . nameRdrName + +-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required +-- pieces, but designed to be more efficient than a standard 'runGhc'. +evalGhcEnv :: HscEnv -> Ghc b -> IO b +evalGhcEnv env act = snd <$> runGhcEnv env act + +-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required +-- pieces, but designed to be more efficient than a standard 'runGhc'. +runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a) +runGhcEnv env act = do + filesToClean <- newIORef emptyFilesToClean + dirsToClean <- newIORef mempty + let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True} + ref <- newIORef env{hsc_dflags=dflags} + res <- unGhc act (Session ref) `finally` do + cleanTempFiles dflags + cleanTempDirs dflags + (,res) <$> readIORef ref + +-- | Given a module location, and its parse tree, figure out what is the include directory implied by it. +-- For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory +-- @\/usr\/Test@ should be on the include path to find sibling modules. +moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath +-- The call to takeDirectory is required since DAML does not require that +-- the file name matches the module name in the last component. +-- Once that has changed we can get rid of this. +moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn + -- This happens for single-component modules since takeDirectory "A" == "." + | modDir == "." = Just pathDir + | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir + where + -- A for module A.B + modDir = + takeDirectory $ + fromNormalizedFilePath $ toNormalizedFilePath' $ + moduleNameSlashes mn + +-- | Read a UTF8 file, with lenient decoding, so it will never raise a decoding error. +readFileUtf8 :: FilePath -> IO T.Text +readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f + +-- | Convert from a 'CgGuts' to a 'CoreModule'. +cgGutsToCoreModule :: SafeHaskellMode -> CgGuts -> ModDetails -> CoreModule +cgGutsToCoreModule safeMode guts modDetails = CoreModule + (cg_module guts) + (md_types modDetails) + (cg_binds guts) + safeMode + +-- | Convert a 'Fingerprint' to a 'ByteString' by copying the byte across. +-- Will produce an 8 byte unreadable ByteString. +fingerprintToBS :: Fingerprint -> BS.ByteString +fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do + ptr <- pure $ castPtr ptr + pokeElemOff ptr 0 a + pokeElemOff ptr 1 b + +-- | Take the 'Fingerprint' of a 'StringBuffer'. +fingerprintFromStringBuffer :: StringBuffer -> IO Fingerprint +fingerprintFromStringBuffer (StringBuffer buf len cur) = + withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len + +fingerprintFromByteString :: ByteString -> IO Fingerprint +fingerprintFromByteString bs = do + let (fptr, offset, len) = BS.toForeignPtr bs + withForeignPtr fptr $ \ptr -> + fingerprintData (ptr `plusPtr` offset) len + +fingerprintFromPut :: Put -> IO Fingerprint +fingerprintFromPut = fingerprintFromByteString . LBS.toStrict . runPut + +-- | A slightly modified version of 'hDuplicateTo' from GHC. +-- Importantly, it avoids the bug listed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2318. +hDuplicateTo' :: Handle -> Handle -> IO () +hDuplicateTo' h1@(FileHandle path m1) h2@(FileHandle _ m2) = do + withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do + -- The implementation in base has this call to hClose_help. + -- _ <- hClose_help h2_ + -- hClose_help does two things: + -- 1. It flushes the buffer, we replicate this here + _ <- flushWriteBuffer h2_ `catch` \(_ :: IOException) -> pure () + -- 2. It closes the handle. This is redundant since dup2 takes care of that + -- but even worse it is actively harmful! Once the handle has been closed + -- another thread is free to reallocate it. This leads to dup2 failing with EBUSY + -- if it happens just in the right moment. + withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do + dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer) +hDuplicateTo' h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2) = do + withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do + _ <- hClose_help w2_ + withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do + dupHandleTo path h1 Nothing w2_ w1_ (Just handleFinalizer) + withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do + _ <- hClose_help r2_ + withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do + dupHandleTo path h1 (Just w1) r2_ r1_ Nothing +hDuplicateTo' h1 _ = + ioe_dupHandlesNotCompatible h1 + +-- | This is copied unmodified from GHC since it is not exposed. +dupHandleTo :: FilePath + -> Handle + -> Maybe (MVar Handle__) + -> Handle__ + -> Handle__ + -> Maybe HandleFinalizer + -> IO Handle__ +dupHandleTo filepath h other_side + _hto_@Handle__{haDevice=devTo} + h_@Handle__{haDevice=dev} mb_finalizer = do + flushBuffer h_ + case cast devTo of + Nothing -> ioe_dupHandlesNotCompatible h + Just dev' -> do + _ <- IODevice.dup2 dev dev' + FileHandle _ m <- dupHandle_ dev' filepath other_side h_ mb_finalizer + takeMVar m + +-- | This is copied unmodified from GHC since it is not exposed. +-- Note the beautiful inline comment! +dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev + -> FilePath + -> Maybe (MVar Handle__) + -> Handle__ + -> Maybe HandleFinalizer + -> IO Handle +dupHandle_ new_dev filepath other_side _h_@Handle__{..} mb_finalizer = do + -- XXX wrong! + mb_codec <- if isJust haEncoder then fmap Just getLocaleEncoding else return Nothing + mkHandle new_dev filepath haType True{-buffered-} mb_codec + NewlineMode { inputNL = haInputNL, outputNL = haOutputNL } + mb_finalizer other_side + +-- | This is copied unmodified from GHC since it is not exposed. +ioe_dupHandlesNotCompatible :: Handle -> IO a +ioe_dupHandlesNotCompatible h = + ioException (IOError (Just h) IllegalOperation "hDuplicateTo" + "handles are incompatible" Nothing Nothing) diff --git a/src/Development/IDE/GHC/Warnings.hs b/src/Development/IDE/GHC/Warnings.hs --- a/src/Development/IDE/GHC/Warnings.hs +++ b/src/Development/IDE/GHC/Warnings.hs @@ -1,48 +1,48 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE ExplicitNamespaces #-} - -module Development.IDE.GHC.Warnings(withWarnings) where - -import Data.List -import ErrUtils -import GhcPlugins as GHC hiding (Var, (<>)) - -import Control.Concurrent.Extra -import qualified Data.Text as T - -import Development.IDE.Types.Diagnostics -import Development.IDE.GHC.Error -import Language.LSP.Types (type (|?)(..)) - - --- | Take a GHC monadic action (e.g. @typecheckModule pm@ for some --- parsed module 'pm@') and produce a "decorated" action that will --- harvest any warnings encountered executing the action. The 'phase' --- argument classifies the context (e.g. "Parser", "Typechecker"). --- --- The ModSummary function is required because of --- https://github.com/ghc/ghc/blob/5f1d949ab9e09b8d95319633854b7959df06eb58/compiler/main/GHC.hs#L623-L640 --- which basically says that log_action is taken from the ModSummary when GHC feels like it. --- The given argument lets you refresh a ModSummary log_action -withWarnings :: T.Text -> ((ModSummary -> ModSummary) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a) -withWarnings diagSource action = do - warnings <- newVar [] - let newAction :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () - newAction dynFlags wr _ loc style msg = do - let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc (queryQual style) msg - modifyVar_ warnings $ return . (wr_d:) - res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = newAction}} - warns <- readVar warnings - return (reverse $ concat warns, res) - -attachReason :: WarnReason -> Diagnostic -> Diagnostic -attachReason wr d = d{_code = InR <$> showReason wr} - where - showReason = \case - NoReason -> Nothing - Reason flag -> showFlag flag - ErrReason flag -> showFlag =<< flag - -showFlag :: WarningFlag -> Maybe T.Text -showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE ExplicitNamespaces #-} + +module Development.IDE.GHC.Warnings(withWarnings) where + +import Data.List +import ErrUtils +import GhcPlugins as GHC hiding (Var, (<>)) + +import Control.Concurrent.Strict +import qualified Data.Text as T + +import Development.IDE.GHC.Error +import Development.IDE.Types.Diagnostics +import Language.LSP.Types (type (|?) (..)) + + +-- | Take a GHC monadic action (e.g. @typecheckModule pm@ for some +-- parsed module 'pm@') and produce a "decorated" action that will +-- harvest any warnings encountered executing the action. The 'phase' +-- argument classifies the context (e.g. "Parser", "Typechecker"). +-- +-- The ModSummary function is required because of +-- https://github.com/ghc/ghc/blob/5f1d949ab9e09b8d95319633854b7959df06eb58/compiler/main/GHC.hs#L623-L640 +-- which basically says that log_action is taken from the ModSummary when GHC feels like it. +-- The given argument lets you refresh a ModSummary log_action +withWarnings :: T.Text -> ((ModSummary -> ModSummary) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a) +withWarnings diagSource action = do + warnings <- newVar [] + let newAction :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () + newAction dynFlags wr _ loc style msg = do + let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc (queryQual style) msg + modifyVar_ warnings $ return . (wr_d:) + res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = newAction}} + warns <- readVar warnings + return (reverse $ concat warns, res) + +attachReason :: WarnReason -> Diagnostic -> Diagnostic +attachReason wr d = d{_code = InR <$> showReason wr} + where + showReason = \case + NoReason -> Nothing + Reason flag -> showFlag flag + ErrReason flag -> showFlag =<< flag + +showFlag :: WarningFlag -> Maybe T.Text +showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags diff --git a/src/Development/IDE/Import/DependencyInformation.hs b/src/Development/IDE/Import/DependencyInformation.hs --- a/src/Development/IDE/Import/DependencyInformation.hs +++ b/src/Development/IDE/Import/DependencyInformation.hs @@ -1,377 +1,381 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -module Development.IDE.Import.DependencyInformation - ( DependencyInformation(..) - , ModuleImports(..) - , RawDependencyInformation(..) - , NodeError(..) - , ModuleParseError(..) - , TransitiveDependencies(..) - , FilePathId(..) - , NamedModuleDep(..) - , ShowableModuleName(..) - , PathIdMap - , emptyPathIdMap - , getPathId - , lookupPathToId - , insertImport - , pathToId - , idToPath - , reachableModules - , processDependencyInformation - , transitiveDeps - , transitiveReverseDependencies - , immediateReverseDependencies - - , BootIdMap - , insertBootId - ) where - -import Control.DeepSeq -import Data.Bifunctor -import Data.Coerce -import Data.List -import Data.Tuple.Extra hiding (first, second) -import Development.IDE.GHC.Orphans() -import Data.Either -import Data.Graph -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HMS -import Data.List.NonEmpty (NonEmpty(..), nonEmpty) -import qualified Data.List.NonEmpty as NonEmpty -import Data.IntMap (IntMap) -import qualified Data.IntMap.Strict as IntMap -import qualified Data.IntMap.Lazy as IntMapLazy -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet -import Data.Maybe -import GHC.Generics (Generic) - -import Development.IDE.Types.Diagnostics -import Development.IDE.Types.Location -import Development.IDE.Import.FindImports (ArtifactsLocation(..)) - -import GHC - --- | The imports for a given module. -newtype ModuleImports = ModuleImports - { moduleImports :: [(Located ModuleName, Maybe FilePathId)] - -- ^ Imports of a module in the current package and the file path of - -- that module on disk (if we found it) - } deriving Show - --- | For processing dependency information, we need lots of maps and sets of --- filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet --- instead and only convert at the edges. -newtype FilePathId = FilePathId { getFilePathId :: Int } - deriving (Show, NFData, Eq, Ord) - --- | Map from 'FilePathId' -type FilePathIdMap = IntMap - --- | Set of 'FilePathId's -type FilePathIdSet = IntSet - -data PathIdMap = PathIdMap - { idToPathMap :: !(FilePathIdMap ArtifactsLocation) - , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId) - } - deriving (Show, Generic) - -instance NFData PathIdMap - -emptyPathIdMap :: PathIdMap -emptyPathIdMap = PathIdMap IntMap.empty HMS.empty - -getPathId :: ArtifactsLocation -> PathIdMap -> (FilePathId, PathIdMap) -getPathId path m@PathIdMap{..} = - case HMS.lookup (artifactFilePath path) pathToIdMap of - Nothing -> - let !newId = FilePathId $ HMS.size pathToIdMap - in (newId, insertPathId path newId m) - Just id -> (id, m) - -insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap -insertPathId path id PathIdMap{..} = - PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (HMS.insert (artifactFilePath path) id pathToIdMap) - -insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation -insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) } - -pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId -pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path - -lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId -lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap - -idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath -idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId - -idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation -idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id - -type BootIdMap = FilePathIdMap FilePathId - -insertBootId :: FilePathId -> FilePathId -> BootIdMap -> BootIdMap -insertBootId k = IntMap.insert (getFilePathId k) - --- | Unprocessed results that we find by following imports recursively. -data RawDependencyInformation = RawDependencyInformation - { rawImports :: !(FilePathIdMap (Either ModuleParseError ModuleImports)) - , rawPathIdMap :: !PathIdMap - -- The rawBootMap maps the FilePathId of a hs-boot file to its - -- corresponding hs file. It is used when topologically sorting as we - -- need to add edges between .hs-boot and .hs so that the .hs files - -- appear later in the sort. - , rawBootMap :: !BootIdMap - } deriving Show - -data DependencyInformation = - DependencyInformation - { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError)) - -- ^ Nodes that cannot be processed correctly. - , depModuleNames :: !(FilePathIdMap ShowableModuleName) - , depModuleDeps :: !(FilePathIdMap FilePathIdSet) - -- ^ For a non-error node, this contains the set of module immediate dependencies - -- in the same package. - , depReverseModuleDeps :: !(IntMap IntSet) - -- ^ Contains a reverse mapping from a module to all those that immediately depend on it. - , depPathIdMap :: !PathIdMap - -- ^ Map from FilePath to FilePathId - , depBootMap :: !BootIdMap - -- ^ Map from hs-boot file to the corresponding hs file - } deriving (Show, Generic) - -newtype ShowableModuleName = - ShowableModuleName {showableModuleName :: ModuleName} - deriving NFData - -instance Show ShowableModuleName where show = moduleNameString . showableModuleName - -reachableModules :: DependencyInformation -> [NormalizedFilePath] -reachableModules DependencyInformation{..} = - map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps - -instance NFData DependencyInformation - --- | This does not contain the actual parse error as that is already reported by GetParsedModule. -data ModuleParseError = ModuleParseError - deriving (Show, Generic) - -instance NFData ModuleParseError - --- | Error when trying to locate a module. -data LocateError = LocateError [Diagnostic] - deriving (Eq, Show, Generic) - -instance NFData LocateError - --- | An error attached to a node in the dependency graph. -data NodeError - = PartOfCycle (Located ModuleName) [FilePathId] - -- ^ This module is part of an import cycle. The module name corresponds - -- to the import that enters the cycle starting from this module. - -- The list of filepaths represents the elements - -- in the cycle in unspecified order. - | FailedToLocateImport (Located ModuleName) - -- ^ This module has an import that couldn’t be located. - | ParseError ModuleParseError - | ParentOfErrorNode (Located ModuleName) - -- ^ This module is the parent of a module that cannot be - -- processed (either it cannot be parsed, is part of a cycle - -- or the parent of another error node). - deriving (Show, Generic) - -instance NFData NodeError where - rnf (PartOfCycle m fs) = m `seq` rnf fs - rnf (FailedToLocateImport m) = m `seq` () - rnf (ParseError e) = rnf e - rnf (ParentOfErrorNode m) = m `seq` () - --- | A processed node in the dependency graph. If there was any error --- during processing the node or any of its dependencies, this is an --- `ErrorNode`. Otherwise it is a `SuccessNode`. -data NodeResult - = ErrorNode (NonEmpty NodeError) - | SuccessNode [(Located ModuleName, FilePathId)] - deriving Show - -partitionNodeResults - :: [(a, NodeResult)] - -> ([(a, NonEmpty NodeError)], [(a, [(Located ModuleName, FilePathId)])]) -partitionNodeResults = partitionEithers . map f - where f (a, ErrorNode errs) = Left (a, errs) - f (a, SuccessNode imps) = Right (a, imps) - -instance Semigroup NodeResult where - ErrorNode errs <> ErrorNode errs' = ErrorNode (errs <> errs') - ErrorNode errs <> SuccessNode _ = ErrorNode errs - SuccessNode _ <> ErrorNode errs = ErrorNode errs - SuccessNode a <> SuccessNode _ = SuccessNode a - -processDependencyInformation :: RawDependencyInformation -> DependencyInformation -processDependencyInformation RawDependencyInformation{..} = - DependencyInformation - { depErrorNodes = IntMap.fromList errorNodes - , depModuleDeps = moduleDeps - , depReverseModuleDeps = reverseModuleDeps - , depModuleNames = IntMap.fromList $ coerce moduleNames - , depPathIdMap = rawPathIdMap - , depBootMap = rawBootMap - } - where resultGraph = buildResultGraph rawImports - (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph - moduleNames :: [(FilePathId, ModuleName)] - moduleNames = - [ (fId, modName) | (_, imports) <- successNodes, (L _ modName, fId) <- imports] - successEdges :: [(FilePathId, [FilePathId])] - successEdges = - map - (bimap FilePathId (map snd)) - successNodes - moduleDeps = - IntMap.fromList $ - map (\(FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs)) - successEdges - reverseModuleDeps = - foldr (\(p, cs) res -> - let new = IntMap.fromList (map (, IntSet.singleton (coerce p)) (coerce cs)) - in IntMap.unionWith IntSet.union new res ) IntMap.empty successEdges - - --- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows: --- 1. Mark each node that is part of an import cycle as an error node. --- 2. Mark each node that has a parse error as an error node. --- 3. Mark each node whose immediate children could not be located as an error. --- 4. Recursively propagate errors to parents if they are not already error nodes. -buildResultGraph :: FilePathIdMap (Either ModuleParseError ModuleImports) -> FilePathIdMap NodeResult -buildResultGraph g = propagatedErrors - where - sccs = stronglyConnComp (graphEdges g) - (_, cycles) = partitionSCC sccs - cycleErrors :: IntMap NodeResult - cycleErrors = IntMap.unionsWith (<>) $ map errorsForCycle cycles - errorsForCycle :: [FilePathId] -> IntMap NodeResult - errorsForCycle files = - IntMap.fromListWith (<>) $ coerce $ concatMap (cycleErrorsForFile files) files - cycleErrorsForFile :: [FilePathId] -> FilePathId -> [(FilePathId,NodeResult)] - cycleErrorsForFile cycle f = - let entryPoints = mapMaybe (findImport f) cycle - in map (\imp -> (f, ErrorNode (PartOfCycle imp cycle :| []))) entryPoints - otherErrors = IntMap.map otherErrorsForFile g - otherErrorsForFile :: Either ModuleParseError ModuleImports -> NodeResult - otherErrorsForFile (Left err) = ErrorNode (ParseError err :| []) - otherErrorsForFile (Right ModuleImports{moduleImports}) = - let toEither (imp, Nothing) = Left imp - toEither (imp, Just path) = Right (imp, path) - (errs, imports') = partitionEithers (map toEither moduleImports) - in case nonEmpty errs of - Nothing -> SuccessNode imports' - Just errs' -> ErrorNode (NonEmpty.map FailedToLocateImport errs') - - unpropagatedErrors = IntMap.unionWith (<>) cycleErrors otherErrors - -- The recursion here is fine since we use a lazy map and - -- we only recurse on SuccessNodes. In particular, we do not recurse - -- on nodes that are part of a cycle as they are already marked as - -- error nodes. - propagatedErrors = - IntMapLazy.map propagate unpropagatedErrors - propagate :: NodeResult -> NodeResult - propagate n@(ErrorNode _) = n - propagate n@(SuccessNode imps) = - let results = map (\(imp, FilePathId dep) -> (imp, propagatedErrors IntMap.! dep)) imps - (errs, _) = partitionNodeResults results - in case nonEmpty errs of - Nothing -> n - Just errs' -> ErrorNode (NonEmpty.map (ParentOfErrorNode . fst) errs') - findImport :: FilePathId -> FilePathId -> Maybe (Located ModuleName) - findImport (FilePathId file) importedFile = - case g IntMap.! file of - Left _ -> error "Tried to call findImport on a module with a parse error" - Right ModuleImports{moduleImports} -> - fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports - -graphEdges :: FilePathIdMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])] -graphEdges g = - map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g - where deps :: Either e ModuleImports -> [FilePathId] - deps (Left _) = [] - deps (Right ModuleImports{moduleImports}) = mapMaybe snd moduleImports - -partitionSCC :: [SCC a] -> ([a], [[a]]) -partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest -partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest -partitionSCC [] = ([], []) - --- | Transitive reverse dependencies of a file -transitiveReverseDependencies :: NormalizedFilePath -> DependencyInformation -> Maybe [NormalizedFilePath] -transitiveReverseDependencies file DependencyInformation{..} = do - FilePathId cur_id <- lookupPathToId depPathIdMap file - return $ map (idToPath depPathIdMap . FilePathId) (IntSet.toList (go cur_id IntSet.empty)) - where - go :: Int -> IntSet -> IntSet - go k i = - let outwards = fromMaybe IntSet.empty (IntMap.lookup k depReverseModuleDeps) - res = IntSet.union i outwards - new = IntSet.difference i outwards - in IntSet.foldr go res new - --- | Immediate reverse dependencies of a file -immediateReverseDependencies :: NormalizedFilePath -> DependencyInformation -> Maybe [NormalizedFilePath] -immediateReverseDependencies file DependencyInformation{..} = do - FilePathId cur_id <- lookupPathToId depPathIdMap file - return $ map (idToPath depPathIdMap . FilePathId) (maybe mempty IntSet.toList (IntMap.lookup cur_id depReverseModuleDeps)) - -transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies -transitiveDeps DependencyInformation{..} file = do - let !fileId = pathToId depPathIdMap file - reachableVs <- - -- Delete the starting node - IntSet.delete (getFilePathId fileId) . - IntSet.fromList . map (fst3 . fromVertex) . - reachable g <$> toVertex (getFilePathId fileId) - let transitiveModuleDepIds = - filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs - let transitiveModuleDeps = - map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds - pure TransitiveDependencies {..} - where - (g, fromVertex, toVertex) = graphFromEdges edges - edges = map (\(f, fs) -> (f, f, IntSet.toList fs ++ boot_edge f)) $ IntMap.toList depModuleDeps - - -- Need to add an edge between the .hs and .hs-boot file if it exists - -- so the .hs file gets loaded after the .hs-boot file and the right - -- stuff ends up in the HPT. If you don't have this check then GHC will - -- fail to work with ghcide. - boot_edge f = [getFilePathId f' | Just f' <- [IntMap.lookup f depBootMap]] - - vs = topSort g - -newtype TransitiveDependencies = TransitiveDependencies - { transitiveModuleDeps :: [NormalizedFilePath] - -- ^ Transitive module dependencies in topological order. - -- The module itself is not included. - } deriving (Eq, Show, Generic) - -instance NFData TransitiveDependencies - -data NamedModuleDep = NamedModuleDep { - nmdFilePath :: !NormalizedFilePath, - nmdModuleName :: !ModuleName, - nmdModLocation :: !(Maybe ModLocation) - } - deriving Generic - -instance Eq NamedModuleDep where - a == b = nmdFilePath a == nmdFilePath b - -instance NFData NamedModuleDep where - rnf NamedModuleDep{..} = - rnf nmdFilePath `seq` - rnf nmdModuleName `seq` - -- 'ModLocation' lacks an 'NFData' instance - rwhnf nmdModLocation - -instance Show NamedModuleDep where - show NamedModuleDep{..} = show nmdFilePath +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Development.IDE.Import.DependencyInformation + ( DependencyInformation(..) + , ModuleImports(..) + , RawDependencyInformation(..) + , NodeError(..) + , ModuleParseError(..) + , TransitiveDependencies(..) + , FilePathId(..) + , NamedModuleDep(..) + , ShowableModuleName(..) + , PathIdMap + , emptyPathIdMap + , getPathId + , lookupPathToId + , insertImport + , pathToId + , idToPath + , reachableModules + , processDependencyInformation + , transitiveDeps + , transitiveReverseDependencies + , immediateReverseDependencies + + , BootIdMap + , insertBootId + ) where + +import Control.DeepSeq +import Data.Bifunctor +import Data.Coerce +import Data.Either +import Data.Graph +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HMS +import Data.IntMap (IntMap) +import qualified Data.IntMap.Lazy as IntMapLazy +import qualified Data.IntMap.Strict as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.List +import Data.List.NonEmpty (NonEmpty (..), nonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe +import Data.Tuple.Extra hiding (first, second) +import Development.IDE.GHC.Orphans () +import GHC.Generics (Generic) + +import Development.IDE.Import.FindImports (ArtifactsLocation (..)) +import Development.IDE.Types.Diagnostics +import Development.IDE.Types.Location + +import GHC + +-- | The imports for a given module. +newtype ModuleImports = ModuleImports + { moduleImports :: [(Located ModuleName, Maybe FilePathId)] + -- ^ Imports of a module in the current package and the file path of + -- that module on disk (if we found it) + } deriving Show + +-- | For processing dependency information, we need lots of maps and sets of +-- filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet +-- instead and only convert at the edges. +newtype FilePathId = FilePathId { getFilePathId :: Int } + deriving (Show, NFData, Eq, Ord) + +-- | Map from 'FilePathId' +type FilePathIdMap = IntMap + +-- | Set of 'FilePathId's +type FilePathIdSet = IntSet + +data PathIdMap = PathIdMap + { idToPathMap :: !(FilePathIdMap ArtifactsLocation) + , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId) + , nextFreshId :: !Int + } + deriving (Show, Generic) + +instance NFData PathIdMap + +emptyPathIdMap :: PathIdMap +emptyPathIdMap = PathIdMap IntMap.empty HMS.empty 0 + +getPathId :: ArtifactsLocation -> PathIdMap -> (FilePathId, PathIdMap) +getPathId path m@PathIdMap{..} = + case HMS.lookup (artifactFilePath path) pathToIdMap of + Nothing -> + let !newId = FilePathId nextFreshId + in (newId, insertPathId path newId m) + Just id -> (id, m) + where + insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap + insertPathId path id PathIdMap{..} = + PathIdMap + (IntMap.insert (getFilePathId id) path idToPathMap) + (HMS.insert (artifactFilePath path) id pathToIdMap) + (succ nextFreshId) + +insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation +insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) } + +pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId +pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path + +lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId +lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap + +idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath +idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId + +idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation +idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id + +type BootIdMap = FilePathIdMap FilePathId + +insertBootId :: FilePathId -> FilePathId -> BootIdMap -> BootIdMap +insertBootId k = IntMap.insert (getFilePathId k) + +-- | Unprocessed results that we find by following imports recursively. +data RawDependencyInformation = RawDependencyInformation + { rawImports :: !(FilePathIdMap (Either ModuleParseError ModuleImports)) + , rawPathIdMap :: !PathIdMap + -- The rawBootMap maps the FilePathId of a hs-boot file to its + -- corresponding hs file. It is used when topologically sorting as we + -- need to add edges between .hs-boot and .hs so that the .hs files + -- appear later in the sort. + , rawBootMap :: !BootIdMap + } deriving Show + +data DependencyInformation = + DependencyInformation + { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError)) + -- ^ Nodes that cannot be processed correctly. + , depModuleNames :: !(FilePathIdMap ShowableModuleName) + , depModuleDeps :: !(FilePathIdMap FilePathIdSet) + -- ^ For a non-error node, this contains the set of module immediate dependencies + -- in the same package. + , depReverseModuleDeps :: !(IntMap IntSet) + -- ^ Contains a reverse mapping from a module to all those that immediately depend on it. + , depPathIdMap :: !PathIdMap + -- ^ Map from FilePath to FilePathId + , depBootMap :: !BootIdMap + -- ^ Map from hs-boot file to the corresponding hs file + } deriving (Show, Generic) + +newtype ShowableModuleName = + ShowableModuleName {showableModuleName :: ModuleName} + deriving NFData + +instance Show ShowableModuleName where show = moduleNameString . showableModuleName + +reachableModules :: DependencyInformation -> [NormalizedFilePath] +reachableModules DependencyInformation{..} = + map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps + +instance NFData DependencyInformation + +-- | This does not contain the actual parse error as that is already reported by GetParsedModule. +data ModuleParseError = ModuleParseError + deriving (Show, Generic) + +instance NFData ModuleParseError + +-- | Error when trying to locate a module. +data LocateError = LocateError [Diagnostic] + deriving (Eq, Show, Generic) + +instance NFData LocateError + +-- | An error attached to a node in the dependency graph. +data NodeError + = PartOfCycle (Located ModuleName) [FilePathId] + -- ^ This module is part of an import cycle. The module name corresponds + -- to the import that enters the cycle starting from this module. + -- The list of filepaths represents the elements + -- in the cycle in unspecified order. + | FailedToLocateImport (Located ModuleName) + -- ^ This module has an import that couldn’t be located. + | ParseError ModuleParseError + | ParentOfErrorNode (Located ModuleName) + -- ^ This module is the parent of a module that cannot be + -- processed (either it cannot be parsed, is part of a cycle + -- or the parent of another error node). + deriving (Show, Generic) + +instance NFData NodeError where + rnf (PartOfCycle m fs) = m `seq` rnf fs + rnf (FailedToLocateImport m) = m `seq` () + rnf (ParseError e) = rnf e + rnf (ParentOfErrorNode m) = m `seq` () + +-- | A processed node in the dependency graph. If there was any error +-- during processing the node or any of its dependencies, this is an +-- `ErrorNode`. Otherwise it is a `SuccessNode`. +data NodeResult + = ErrorNode (NonEmpty NodeError) + | SuccessNode [(Located ModuleName, FilePathId)] + deriving Show + +partitionNodeResults + :: [(a, NodeResult)] + -> ([(a, NonEmpty NodeError)], [(a, [(Located ModuleName, FilePathId)])]) +partitionNodeResults = partitionEithers . map f + where f (a, ErrorNode errs) = Left (a, errs) + f (a, SuccessNode imps) = Right (a, imps) + +instance Semigroup NodeResult where + ErrorNode errs <> ErrorNode errs' = ErrorNode (errs <> errs') + ErrorNode errs <> SuccessNode _ = ErrorNode errs + SuccessNode _ <> ErrorNode errs = ErrorNode errs + SuccessNode a <> SuccessNode _ = SuccessNode a + +processDependencyInformation :: RawDependencyInformation -> DependencyInformation +processDependencyInformation RawDependencyInformation{..} = + DependencyInformation + { depErrorNodes = IntMap.fromList errorNodes + , depModuleDeps = moduleDeps + , depReverseModuleDeps = reverseModuleDeps + , depModuleNames = IntMap.fromList $ coerce moduleNames + , depPathIdMap = rawPathIdMap + , depBootMap = rawBootMap + } + where resultGraph = buildResultGraph rawImports + (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph + moduleNames :: [(FilePathId, ModuleName)] + moduleNames = + [ (fId, modName) | (_, imports) <- successNodes, (L _ modName, fId) <- imports] + successEdges :: [(FilePathId, [FilePathId])] + successEdges = + map + (bimap FilePathId (map snd)) + successNodes + moduleDeps = + IntMap.fromList $ + map (\(FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs)) + successEdges + reverseModuleDeps = + foldr (\(p, cs) res -> + let new = IntMap.fromList (map (, IntSet.singleton (coerce p)) (coerce cs)) + in IntMap.unionWith IntSet.union new res ) IntMap.empty successEdges + + +-- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows: +-- 1. Mark each node that is part of an import cycle as an error node. +-- 2. Mark each node that has a parse error as an error node. +-- 3. Mark each node whose immediate children could not be located as an error. +-- 4. Recursively propagate errors to parents if they are not already error nodes. +buildResultGraph :: FilePathIdMap (Either ModuleParseError ModuleImports) -> FilePathIdMap NodeResult +buildResultGraph g = propagatedErrors + where + sccs = stronglyConnComp (graphEdges g) + (_, cycles) = partitionSCC sccs + cycleErrors :: IntMap NodeResult + cycleErrors = IntMap.unionsWith (<>) $ map errorsForCycle cycles + errorsForCycle :: [FilePathId] -> IntMap NodeResult + errorsForCycle files = + IntMap.fromListWith (<>) $ coerce $ concatMap (cycleErrorsForFile files) files + cycleErrorsForFile :: [FilePathId] -> FilePathId -> [(FilePathId,NodeResult)] + cycleErrorsForFile cycle f = + let entryPoints = mapMaybe (findImport f) cycle + in map (\imp -> (f, ErrorNode (PartOfCycle imp cycle :| []))) entryPoints + otherErrors = IntMap.map otherErrorsForFile g + otherErrorsForFile :: Either ModuleParseError ModuleImports -> NodeResult + otherErrorsForFile (Left err) = ErrorNode (ParseError err :| []) + otherErrorsForFile (Right ModuleImports{moduleImports}) = + let toEither (imp, Nothing) = Left imp + toEither (imp, Just path) = Right (imp, path) + (errs, imports') = partitionEithers (map toEither moduleImports) + in case nonEmpty errs of + Nothing -> SuccessNode imports' + Just errs' -> ErrorNode (NonEmpty.map FailedToLocateImport errs') + + unpropagatedErrors = IntMap.unionWith (<>) cycleErrors otherErrors + -- The recursion here is fine since we use a lazy map and + -- we only recurse on SuccessNodes. In particular, we do not recurse + -- on nodes that are part of a cycle as they are already marked as + -- error nodes. + propagatedErrors = + IntMapLazy.map propagate unpropagatedErrors + propagate :: NodeResult -> NodeResult + propagate n@(ErrorNode _) = n + propagate n@(SuccessNode imps) = + let results = map (\(imp, FilePathId dep) -> (imp, propagatedErrors IntMap.! dep)) imps + (errs, _) = partitionNodeResults results + in case nonEmpty errs of + Nothing -> n + Just errs' -> ErrorNode (NonEmpty.map (ParentOfErrorNode . fst) errs') + findImport :: FilePathId -> FilePathId -> Maybe (Located ModuleName) + findImport (FilePathId file) importedFile = + case g IntMap.! file of + Left _ -> error "Tried to call findImport on a module with a parse error" + Right ModuleImports{moduleImports} -> + fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports + +graphEdges :: FilePathIdMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])] +graphEdges g = + map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g + where deps :: Either e ModuleImports -> [FilePathId] + deps (Left _) = [] + deps (Right ModuleImports{moduleImports}) = mapMaybe snd moduleImports + +partitionSCC :: [SCC a] -> ([a], [[a]]) +partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest +partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest +partitionSCC [] = ([], []) + +-- | Transitive reverse dependencies of a file +transitiveReverseDependencies :: NormalizedFilePath -> DependencyInformation -> Maybe [NormalizedFilePath] +transitiveReverseDependencies file DependencyInformation{..} = do + FilePathId cur_id <- lookupPathToId depPathIdMap file + return $ map (idToPath depPathIdMap . FilePathId) (IntSet.toList (go cur_id IntSet.empty)) + where + go :: Int -> IntSet -> IntSet + go k i = + let outwards = fromMaybe IntSet.empty (IntMap.lookup k depReverseModuleDeps) + res = IntSet.union i outwards + new = IntSet.difference i outwards + in IntSet.foldr go res new + +-- | Immediate reverse dependencies of a file +immediateReverseDependencies :: NormalizedFilePath -> DependencyInformation -> Maybe [NormalizedFilePath] +immediateReverseDependencies file DependencyInformation{..} = do + FilePathId cur_id <- lookupPathToId depPathIdMap file + return $ map (idToPath depPathIdMap . FilePathId) (maybe mempty IntSet.toList (IntMap.lookup cur_id depReverseModuleDeps)) + +transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies +transitiveDeps DependencyInformation{..} file = do + let !fileId = pathToId depPathIdMap file + reachableVs <- + -- Delete the starting node + IntSet.delete (getFilePathId fileId) . + IntSet.fromList . map (fst3 . fromVertex) . + reachable g <$> toVertex (getFilePathId fileId) + let transitiveModuleDepIds = + filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs + let transitiveModuleDeps = + map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds + pure TransitiveDependencies {..} + where + (g, fromVertex, toVertex) = graphFromEdges edges + edges = map (\(f, fs) -> (f, f, IntSet.toList fs ++ boot_edge f)) $ IntMap.toList depModuleDeps + + -- Need to add an edge between the .hs and .hs-boot file if it exists + -- so the .hs file gets loaded after the .hs-boot file and the right + -- stuff ends up in the HPT. If you don't have this check then GHC will + -- fail to work with ghcide. + boot_edge f = [getFilePathId f' | Just f' <- [IntMap.lookup f depBootMap]] + + vs = topSort g + +newtype TransitiveDependencies = TransitiveDependencies + { transitiveModuleDeps :: [NormalizedFilePath] + -- ^ Transitive module dependencies in topological order. + -- The module itself is not included. + } deriving (Eq, Show, Generic) + +instance NFData TransitiveDependencies + +data NamedModuleDep = NamedModuleDep { + nmdFilePath :: !NormalizedFilePath, + nmdModuleName :: !ModuleName, + nmdModLocation :: !(Maybe ModLocation) + } + deriving Generic + +instance Eq NamedModuleDep where + a == b = nmdFilePath a == nmdFilePath b + +instance NFData NamedModuleDep where + rnf NamedModuleDep{..} = + rnf nmdFilePath `seq` + rnf nmdModuleName `seq` + -- 'ModLocation' lacks an 'NFData' instance + rwhnf nmdModLocation + +instance Show NamedModuleDep where + show NamedModuleDep{..} = show nmdFilePath diff --git a/src/Development/IDE/Import/FindImports.hs b/src/Development/IDE/Import/FindImports.hs --- a/src/Development/IDE/Import/FindImports.hs +++ b/src/Development/IDE/Import/FindImports.hs @@ -1,179 +1,179 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE CPP #-} -#include "ghc-api-version.h" - -module Development.IDE.Import.FindImports - ( locateModule - , locateModuleFile - , Import(..) - , ArtifactsLocation(..) - , modSummaryToArtifactsLocation - , isBootLocation - , mkImportDirs - ) where - -import Development.IDE.GHC.Error as ErrUtils -import Development.IDE.GHC.Orphans() -import Development.IDE.Types.Diagnostics -import Development.IDE.Types.Location -import Development.IDE.GHC.Compat --- GHC imports -import FastString -import qualified Module as M -import Packages -import Outputable (showSDoc, ppr, pprPanic) -import Finder -import Control.DeepSeq - --- standard imports -import Control.Monad.Extra -import Control.Monad.IO.Class -import System.FilePath -import DriverPhases -import Data.Maybe -import Data.List (isSuffixOf) - -data Import - = FileImport !ArtifactsLocation - | PackageImport - deriving (Show) - -data ArtifactsLocation = ArtifactsLocation - { artifactFilePath :: !NormalizedFilePath - , artifactModLocation :: !(Maybe ModLocation) - , artifactIsSource :: !Bool -- ^ True if a module is a source input - } - deriving (Show) - -instance NFData ArtifactsLocation where - rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource - -isBootLocation :: ArtifactsLocation -> Bool -isBootLocation = not . artifactIsSource - -instance NFData Import where - rnf (FileImport x) = rnf x - rnf PackageImport = () - -modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation -modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source - where - isSource HsSrcFile = True - isSource _ = False - source = case ms of - Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp - Just ms -> isSource (ms_hsc_src ms) - --- | locate a module in the file system. Where we go from *daml to Haskell -locateModuleFile :: MonadIO m - => [[FilePath]] - -> [String] - -> (ModuleName -> NormalizedFilePath -> m Bool) - -> Bool - -> ModuleName - -> m (Maybe NormalizedFilePath) -locateModuleFile import_dirss exts doesExist isSource modName = do - let candidates import_dirs = - [ toNormalizedFilePath' (prefix M.moduleNameSlashes modName <.> maybeBoot ext) - | prefix <- import_dirs , ext <- exts] - findM (doesExist modName) (concatMap candidates import_dirss) - where - maybeBoot ext - | isSource = ext ++ "-boot" - | otherwise = ext - --- | This function is used to map a package name to a set of import paths. --- It only returns Just for unit-ids which are possible to import into the --- current module. In particular, it will return Nothing for 'main' components --- as they can never be imported into another package. -mkImportDirs :: DynFlags -> (M.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath]) -mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName df i - --- | locate a module in either the file system or the package database. Where we go from *daml to --- Haskell -locateModule - :: MonadIO m - => DynFlags - -> [(M.InstalledUnitId, DynFlags)] -- ^ Import directories - -> [String] -- ^ File extensions - -> (ModuleName -> NormalizedFilePath -> m Bool) -- ^ does file exist predicate - -> Located ModuleName -- ^ Module name - -> Maybe FastString -- ^ Package name - -> Bool -- ^ Is boot module - -> m (Either [FileDiagnostic] Import) -locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do - case mbPkgName of - -- "this" means that we should only look in the current package - Just "this" -> do - lookupLocal [importPaths dflags] - -- if a package name is given we only go look for a package - Just pkgName - | Just dirs <- lookup (PackageName pkgName) import_paths - -> lookupLocal [dirs] - | otherwise -> lookupInPackageDB dflags - Nothing -> do - -- first try to find the module as a file. If we can't find it try to find it in the package - -- database. - -- Here the importPaths for the current modules are added to the front of the import paths from the other components. - -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in - -- each component will end up being found in the wrong place and cause a multi-cradle match failure. - mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts doesExist isSource $ unLoc modName - case mbFile of - Nothing -> lookupInPackageDB dflags - Just file -> toModLocation file - where - import_paths = mapMaybe (mkImportDirs dflags) comp_info - toModLocation file = liftIO $ do - loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) - return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) - - lookupLocal dirs = do - mbFile <- locateModuleFile dirs exts doesExist isSource $ unLoc modName - case mbFile of - Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound [] - Just file -> toModLocation file - - lookupInPackageDB dfs = - case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of - LookupFound _m _pkgConfig -> return $ Right PackageImport - reason -> return $ Left $ notFoundErr dfs modName reason - --- | Don't call this on a found module. -notFoundErr :: DynFlags -> Located M.ModuleName -> LookupResult -> [FileDiagnostic] -notFoundErr dfs modName reason = - mkError' $ ppr' $ cannotFindModule dfs modName0 $ lookupToFindResult reason - where - mkError' = diagFromString "not found" DsError (getLoc modName) - modName0 = unLoc modName - ppr' = showSDoc dfs - -- We convert the lookup result to a find result to reuse GHC's cannotFindMoudle pretty printer. - lookupToFindResult = - \case - LookupFound _m _pkgConfig -> - pprPanic "Impossible: called lookupToFind on found module." (ppr modName0) - LookupMultiple rs -> FoundMultiple rs - LookupHidden pkg_hiddens mod_hiddens -> - notFound - { fr_pkgs_hidden = map (moduleUnitId . fst) pkg_hiddens - , fr_mods_hidden = map (moduleUnitId . fst) mod_hiddens - } - LookupUnusable unusable -> - let unusables' = map get_unusable unusable - get_unusable (m, ModUnusable r) = (moduleUnitId m, r) - get_unusable (_, r) = - pprPanic "findLookupResult: unexpected origin" (ppr r) - in notFound {fr_unusables = unusables'} - LookupNotFound suggest -> - notFound {fr_suggestions = suggest} - -notFound :: FindResult -notFound = NotFound - { fr_paths = [] - , fr_pkg = Nothing - , fr_pkgs_hidden = [] - , fr_mods_hidden = [] - , fr_unusables = [] - , fr_suggestions = [] - } +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE CPP #-} +#include "ghc-api-version.h" + +module Development.IDE.Import.FindImports + ( locateModule + , locateModuleFile + , Import(..) + , ArtifactsLocation(..) + , modSummaryToArtifactsLocation + , isBootLocation + , mkImportDirs + ) where + +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Error as ErrUtils +import Development.IDE.GHC.Orphans () +import Development.IDE.Types.Diagnostics +import Development.IDE.Types.Location +-- GHC imports +import Control.DeepSeq +import FastString +import Finder +import qualified Module as M +import Outputable (ppr, pprPanic, showSDoc) +import Packages + +-- standard imports +import Control.Monad.Extra +import Control.Monad.IO.Class +import Data.List (isSuffixOf) +import Data.Maybe +import DriverPhases +import System.FilePath + +data Import + = FileImport !ArtifactsLocation + | PackageImport + deriving (Show) + +data ArtifactsLocation = ArtifactsLocation + { artifactFilePath :: !NormalizedFilePath + , artifactModLocation :: !(Maybe ModLocation) + , artifactIsSource :: !Bool -- ^ True if a module is a source input + } + deriving (Show) + +instance NFData ArtifactsLocation where + rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource + +isBootLocation :: ArtifactsLocation -> Bool +isBootLocation = not . artifactIsSource + +instance NFData Import where + rnf (FileImport x) = rnf x + rnf PackageImport = () + +modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation +modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source + where + isSource HsSrcFile = True + isSource _ = False + source = case ms of + Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp + Just ms -> isSource (ms_hsc_src ms) + +-- | locate a module in the file system. Where we go from *daml to Haskell +locateModuleFile :: MonadIO m + => [[FilePath]] + -> [String] + -> (ModuleName -> NormalizedFilePath -> m Bool) + -> Bool + -> ModuleName + -> m (Maybe NormalizedFilePath) +locateModuleFile import_dirss exts doesExist isSource modName = do + let candidates import_dirs = + [ toNormalizedFilePath' (prefix M.moduleNameSlashes modName <.> maybeBoot ext) + | prefix <- import_dirs , ext <- exts] + findM (doesExist modName) (concatMap candidates import_dirss) + where + maybeBoot ext + | isSource = ext ++ "-boot" + | otherwise = ext + +-- | This function is used to map a package name to a set of import paths. +-- It only returns Just for unit-ids which are possible to import into the +-- current module. In particular, it will return Nothing for 'main' components +-- as they can never be imported into another package. +mkImportDirs :: DynFlags -> (M.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath]) +mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName df i + +-- | locate a module in either the file system or the package database. Where we go from *daml to +-- Haskell +locateModule + :: MonadIO m + => DynFlags + -> [(M.InstalledUnitId, DynFlags)] -- ^ Import directories + -> [String] -- ^ File extensions + -> (ModuleName -> NormalizedFilePath -> m Bool) -- ^ does file exist predicate + -> Located ModuleName -- ^ Module name + -> Maybe FastString -- ^ Package name + -> Bool -- ^ Is boot module + -> m (Either [FileDiagnostic] Import) +locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do + case mbPkgName of + -- "this" means that we should only look in the current package + Just "this" -> do + lookupLocal [importPaths dflags] + -- if a package name is given we only go look for a package + Just pkgName + | Just dirs <- lookup (PackageName pkgName) import_paths + -> lookupLocal [dirs] + | otherwise -> lookupInPackageDB dflags + Nothing -> do + -- first try to find the module as a file. If we can't find it try to find it in the package + -- database. + -- Here the importPaths for the current modules are added to the front of the import paths from the other components. + -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in + -- each component will end up being found in the wrong place and cause a multi-cradle match failure. + mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts doesExist isSource $ unLoc modName + case mbFile of + Nothing -> lookupInPackageDB dflags + Just file -> toModLocation file + where + import_paths = mapMaybe (mkImportDirs dflags) comp_info + toModLocation file = liftIO $ do + loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) + return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) + + lookupLocal dirs = do + mbFile <- locateModuleFile dirs exts doesExist isSource $ unLoc modName + case mbFile of + Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound [] + Just file -> toModLocation file + + lookupInPackageDB dfs = + case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of + LookupFound _m _pkgConfig -> return $ Right PackageImport + reason -> return $ Left $ notFoundErr dfs modName reason + +-- | Don't call this on a found module. +notFoundErr :: DynFlags -> Located M.ModuleName -> LookupResult -> [FileDiagnostic] +notFoundErr dfs modName reason = + mkError' $ ppr' $ cannotFindModule dfs modName0 $ lookupToFindResult reason + where + mkError' = diagFromString "not found" DsError (getLoc modName) + modName0 = unLoc modName + ppr' = showSDoc dfs + -- We convert the lookup result to a find result to reuse GHC's cannotFindMoudle pretty printer. + lookupToFindResult = + \case + LookupFound _m _pkgConfig -> + pprPanic "Impossible: called lookupToFind on found module." (ppr modName0) + LookupMultiple rs -> FoundMultiple rs + LookupHidden pkg_hiddens mod_hiddens -> + notFound + { fr_pkgs_hidden = map (moduleUnitId . fst) pkg_hiddens + , fr_mods_hidden = map (moduleUnitId . fst) mod_hiddens + } + LookupUnusable unusable -> + let unusables' = map get_unusable unusable + get_unusable (m, ModUnusable r) = (moduleUnitId m, r) + get_unusable (_, r) = + pprPanic "findLookupResult: unexpected origin" (ppr r) + in notFound {fr_unusables = unusables'} + LookupNotFound suggest -> + notFound {fr_suggestions = suggest} + +notFound :: FindResult +notFound = NotFound + { fr_paths = [] + , fr_pkg = Nothing + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_unusables = [] + , fr_suggestions = [] + } diff --git a/src/Development/IDE/LSP/HoverDefinition.hs b/src/Development/IDE/LSP/HoverDefinition.hs --- a/src/Development/IDE/LSP/HoverDefinition.hs +++ b/src/Development/IDE/LSP/HoverDefinition.hs @@ -1,88 +1,88 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} - --- | Display information on hover. -module Development.IDE.LSP.HoverDefinition - ( setIdeHandlers - -- * For haskell-language-server - , hover - , gotoDefinition - , gotoTypeDefinition - ) where - -import Control.Monad.IO.Class -import Development.IDE.Core.Rules -import Development.IDE.Core.Shake -import Development.IDE.LSP.Server -import Development.IDE.Types.Location -import Development.IDE.Types.Logger -import qualified Language.LSP.Server as LSP -import Language.LSP.Types - -import qualified Data.Text as T - -gotoDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentDefinition)) -hover :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (Maybe Hover)) -gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentTypeDefinition)) -documentHighlight :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (List DocumentHighlight)) -gotoDefinition = request "Definition" getDefinition (InR $ InL $ List []) (InR . InL . List) -gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InL $ List []) (InR . InL . List) -hover = request "Hover" getAtPoint Nothing foundHover -documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List - -references :: IdeState -> ReferenceParams -> LSP.LspM c (Either ResponseError (List Location)) -references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = liftIO $ - case uriToFilePath' uri of - Just path -> do - let filePath = toNormalizedFilePath' path - logDebug (ideLogger ide) $ - "References request at position " <> T.pack (showPosition pos) <> - " in file: " <> T.pack path - Right . List <$> (runAction "references" ide $ refsAtPoint filePath pos) - Nothing -> pure $ Left $ ResponseError InvalidParams ("Invalid URI " <> T.pack (show uri)) Nothing - -wsSymbols :: IdeState -> WorkspaceSymbolParams -> LSP.LspM c (Either ResponseError (List SymbolInformation)) -wsSymbols ide (WorkspaceSymbolParams _ _ query) = liftIO $ do - logDebug (ideLogger ide) $ "Workspace symbols request: " <> query - runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ Right . maybe (List []) List <$> workspaceSymbols query - -foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover -foundHover (mbRange, contents) = - Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange - -setIdeHandlers :: LSP.Handlers (ServerM c) -setIdeHandlers = mconcat - [ requestHandler STextDocumentDefinition $ \ide DefinitionParams{..} -> - gotoDefinition ide TextDocumentPositionParams{..} - , requestHandler STextDocumentTypeDefinition $ \ide TypeDefinitionParams{..} -> - gotoTypeDefinition ide TextDocumentPositionParams{..} - , requestHandler STextDocumentDocumentHighlight $ \ide DocumentHighlightParams{..} -> - documentHighlight ide TextDocumentPositionParams{..} - , requestHandler STextDocumentReferences references - , requestHandler SWorkspaceSymbol wsSymbols - ] - --- | Respond to and log a hover or go-to-definition request -request - :: T.Text - -> (NormalizedFilePath -> Position -> IdeAction (Maybe a)) - -> b - -> (a -> b) - -> IdeState - -> TextDocumentPositionParams - -> LSP.LspM c (Either ResponseError b) -request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do - mbResult <- case uriToFilePath' uri of - Just path -> logAndRunRequest label getResults ide pos path - Nothing -> pure Nothing - pure $ Right $ maybe notFound found mbResult - -logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b -logAndRunRequest label getResults ide pos path = do - let filePath = toNormalizedFilePath' path - logDebug (ideLogger ide) $ - label <> " request at position " <> T.pack (showPosition pos) <> - " in file: " <> T.pack path - runIdeAction (T.unpack label) (shakeExtras ide) (getResults filePath pos) +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} + +-- | Display information on hover. +module Development.IDE.LSP.HoverDefinition + ( setIdeHandlers + -- * For haskell-language-server + , hover + , gotoDefinition + , gotoTypeDefinition + ) where + +import Control.Monad.IO.Class +import Development.IDE.Core.Rules +import Development.IDE.Core.Shake +import Development.IDE.LSP.Server +import Development.IDE.Types.Location +import Development.IDE.Types.Logger +import qualified Language.LSP.Server as LSP +import Language.LSP.Types + +import qualified Data.Text as T + +gotoDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentDefinition)) +hover :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (Maybe Hover)) +gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentTypeDefinition)) +documentHighlight :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (List DocumentHighlight)) +gotoDefinition = request "Definition" getDefinition (InR $ InL $ List []) (InR . InL . List) +gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InL $ List []) (InR . InL . List) +hover = request "Hover" getAtPoint Nothing foundHover +documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List + +references :: IdeState -> ReferenceParams -> LSP.LspM c (Either ResponseError (List Location)) +references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = liftIO $ + case uriToFilePath' uri of + Just path -> do + let filePath = toNormalizedFilePath' path + logDebug (ideLogger ide) $ + "References request at position " <> T.pack (showPosition pos) <> + " in file: " <> T.pack path + Right . List <$> (runAction "references" ide $ refsAtPoint filePath pos) + Nothing -> pure $ Left $ ResponseError InvalidParams ("Invalid URI " <> T.pack (show uri)) Nothing + +wsSymbols :: IdeState -> WorkspaceSymbolParams -> LSP.LspM c (Either ResponseError (List SymbolInformation)) +wsSymbols ide (WorkspaceSymbolParams _ _ query) = liftIO $ do + logDebug (ideLogger ide) $ "Workspace symbols request: " <> query + runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ Right . maybe (List []) List <$> workspaceSymbols query + +foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover +foundHover (mbRange, contents) = + Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange + +setIdeHandlers :: LSP.Handlers (ServerM c) +setIdeHandlers = mconcat + [ requestHandler STextDocumentDefinition $ \ide DefinitionParams{..} -> + gotoDefinition ide TextDocumentPositionParams{..} + , requestHandler STextDocumentTypeDefinition $ \ide TypeDefinitionParams{..} -> + gotoTypeDefinition ide TextDocumentPositionParams{..} + , requestHandler STextDocumentDocumentHighlight $ \ide DocumentHighlightParams{..} -> + documentHighlight ide TextDocumentPositionParams{..} + , requestHandler STextDocumentReferences references + , requestHandler SWorkspaceSymbol wsSymbols + ] + +-- | Respond to and log a hover or go-to-definition request +request + :: T.Text + -> (NormalizedFilePath -> Position -> IdeAction (Maybe a)) + -> b + -> (a -> b) + -> IdeState + -> TextDocumentPositionParams + -> LSP.LspM c (Either ResponseError b) +request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do + mbResult <- case uriToFilePath' uri of + Just path -> logAndRunRequest label getResults ide pos path + Nothing -> pure Nothing + pure $ Right $ maybe notFound found mbResult + +logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b +logAndRunRequest label getResults ide pos path = do + let filePath = toNormalizedFilePath' path + logDebug (ideLogger ide) $ + label <> " request at position " <> T.pack (showPosition pos) <> + " in file: " <> T.pack path + runIdeAction (T.unpack label) (shakeExtras ide) (getResults filePath pos) diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -1,210 +1,216 @@ - -- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} - --- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync --- This version removes the daml: handling -module Development.IDE.LSP.LanguageServer - ( runLanguageServer - ) where - -import Language.LSP.Types -import Development.IDE.LSP.Server -import qualified Development.IDE.GHC.Util as Ghcide -import qualified Language.LSP.Server as LSP -import Control.Concurrent.Extra (newBarrier, signalBarrier, waitBarrier) -import Control.Concurrent.STM -import Data.Maybe -import Data.Aeson (Value) -import qualified Data.Set as Set -import qualified Data.Text as T -import GHC.IO.Handle (hDuplicate) -import System.IO -import Control.Monad.Extra -import UnliftIO.Exception -import UnliftIO.Async -import UnliftIO.Concurrent -import UnliftIO.Directory -import Control.Monad.IO.Class -import Control.Monad.Reader -import Ide.Types (traceWithSpan) -import Development.IDE.Session (runWithDb) - -import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.Shake -import Development.IDE.LSP.HoverDefinition -import Development.IDE.LSP.Notifications -import Development.IDE.Types.Logger -import Development.IDE.Core.FileStore -import Development.IDE.Core.Tracing - -import System.IO.Unsafe (unsafeInterleaveIO) - -runLanguageServer - :: forall config. (Show config) - => LSP.Options - -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project - -> (IdeState -> Value -> IO (Either T.Text config)) - -> LSP.Handlers (ServerM config) - -> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> HieDb -> IndexQueue -> IO IdeState) - -> IO () -runLanguageServer options getHieDbLoc onConfigurationChange userHandlers getIdeState = do - -- Move stdout to another file descriptor and duplicate stderr - -- to stdout. This guards against stray prints from corrupting the JSON-RPC - -- message stream. - newStdout <- hDuplicate stdout - stderr `Ghcide.hDuplicateTo'` stdout - hSetBuffering stderr NoBuffering - hSetBuffering stdout NoBuffering - - -- Print out a single space to assert that the above redirection works. - -- This is interleaved with the logger, hence we just print a space here in - -- order not to mess up the output too much. Verified that this breaks - -- the language server tests without the redirection. - putStr " " >> hFlush stdout - - -- These barriers are signaled when the threads reading from these chans exit. - -- This should not happen but if it does, we will make sure that the whole server - -- dies and can be restarted instead of losing threads silently. - clientMsgBarrier <- newBarrier - -- Forcefully exit - let exit = signalBarrier clientMsgBarrier () - - -- The set of requests ids that we have received but not finished processing - pendingRequests <- newTVarIO Set.empty - -- The set of requests that have been cancelled and are also in pendingRequests - cancelledRequests <- newTVarIO Set.empty - - let cancelRequest reqId = atomically $ do - queued <- readTVar pendingRequests - -- We want to avoid that the list of cancelled requests - -- keeps growing if we receive cancellations for requests - -- that do not exist or have already been processed. - when (reqId `elem` queued) $ - modifyTVar cancelledRequests (Set.insert reqId) - let clearReqId reqId = atomically $ do - modifyTVar pendingRequests (Set.delete reqId) - modifyTVar cancelledRequests (Set.delete reqId) - -- We implement request cancellation by racing waitForCancel against - -- the actual request handler. - let waitForCancel reqId = atomically $ do - cancelled <- readTVar cancelledRequests - unless (reqId `Set.member` cancelled) retry - - let ideHandlers = mconcat - [ setIdeHandlers - , userHandlers - , setHandlersNotifications -- absolutely critical, join them with user notifications - ] - - -- Send everything over a channel, since you need to wait until after initialise before - -- LspFuncs is available - clientMsgChan :: Chan ReactorMessage <- newChan - - let asyncHandlers = mconcat - [ ideHandlers - , cancelHandler cancelRequest - , exitHandler exit - ] - -- Cancel requests are special since they need to be handled - -- out of order to be useful. Existing handlers are run afterwards. - - - let serverDefinition = LSP.ServerDefinition - { LSP.onConfigurationChange = \v -> do - (_chan, ide) <- ask - liftIO $ onConfigurationChange ide v - , LSP.doInitialize = handleInit exit clearReqId waitForCancel clientMsgChan - , LSP.staticHandlers = asyncHandlers - , LSP.interpretHandler = \(env, st) -> LSP.Iso (LSP.runLspT env . flip runReaderT (clientMsgChan,st)) liftIO - , LSP.options = modifyOptions options - } - - void $ waitAnyCancel =<< traverse async - [ void $ LSP.runServerWithHandles - stdin - newStdout - serverDefinition - , void $ waitBarrier clientMsgBarrier - ] - - where - handleInit - :: IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage - -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) - handleInit exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do - traceWithSpan sp params - let root = LSP.resRootPath env - - dir <- getCurrentDirectory - dbLoc <- getHieDbLoc dir - - -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference - -- to 'getIdeState', so we use this dirty trick - dbMVar <- newEmptyMVar - ~(hiedb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar - - ide <- getIdeState env (makeLSPVFSHandle env) root hiedb hieChan - - let initConfig = parseConfiguration params - logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig - registerIdeConfiguration (shakeExtras ide) initConfig - - _ <- flip forkFinally (const exitClientMsg) $ runWithDb dbLoc $ \hiedb hieChan -> do - putMVar dbMVar (hiedb,hieChan) - forever $ do - msg <- readChan clientMsgChan - -- We dispatch notifications synchronously and requests asynchronously - -- This is to ensure that all file edits and config changes are applied before a request is handled - case msg of - ReactorNotification act -> do - catch act $ \(e :: SomeException) -> - logError (ideLogger ide) $ T.pack $ - "Unexpected exception on notification, please report!\n" ++ - "Exception: " ++ show e - ReactorRequest _id act k -> void $ async $ - checkCancelled ide clearReqId waitForCancel _id act k - pure $ Right (env,ide) - - checkCancelled - :: IdeState -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> SomeLspId - -> IO () -> (ResponseError -> IO ()) -> IO () - checkCancelled ide clearReqId waitForCancel _id act k = - flip finally (clearReqId _id) $ - catch (do - -- We could optimize this by first checking if the id - -- is in the cancelled set. However, this is unlikely to be a - -- bottleneck and the additional check might hide - -- issues with async exceptions that need to be fixed. - cancelOrRes <- race (waitForCancel _id) act - case cancelOrRes of - Left () -> do - logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id - k $ ResponseError RequestCancelled "" Nothing - Right res -> pure res - ) $ \(e :: SomeException) -> do - logError (ideLogger ide) $ T.pack $ - "Unexpected exception on request, please report!\n" ++ - "Exception: " ++ show e - k $ ResponseError InternalError (T.pack $ show e) Nothing - - -cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) -cancelHandler cancelRequest = LSP.notificationHandler SCancelRequest $ \NotificationMessage{_params=CancelParams{_id}} -> - liftIO $ cancelRequest (SomeLspId _id) - -exitHandler :: IO () -> LSP.Handlers (ServerM c) -exitHandler exit = LSP.notificationHandler SExit (const $ liftIO exit) - -modifyOptions :: LSP.Options -> LSP.Options -modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS - } - where - tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ InR $ SaveOptions Nothing} - origTDS = fromMaybe tdsDefault $ LSP.textDocumentSync x - tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing - + -- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} + +-- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync +-- This version removes the daml: handling +module Development.IDE.LSP.LanguageServer + ( runLanguageServer + ) where + +import Control.Concurrent.Extra (newBarrier, + signalBarrier, + waitBarrier) +import Control.Concurrent.STM +import Control.Monad.Extra +import Control.Monad.IO.Class +import Control.Monad.Reader +import Data.Aeson (Value) +import Data.Maybe +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Development.IDE.GHC.Util as Ghcide +import Development.IDE.LSP.Server +import Development.IDE.Session (runWithDb) +import GHC.IO.Handle (hDuplicate) +import Ide.Types (traceWithSpan) +import qualified Language.LSP.Server as LSP +import Language.LSP.Types +import System.IO +import UnliftIO.Async +import UnliftIO.Concurrent +import UnliftIO.Directory +import UnliftIO.Exception + +import Development.IDE.Core.FileStore +import Development.IDE.Core.IdeConfiguration +import Development.IDE.Core.Shake +import Development.IDE.Core.Tracing +import Development.IDE.LSP.HoverDefinition +import Development.IDE.LSP.Notifications +import Development.IDE.Types.Logger + +import System.IO.Unsafe (unsafeInterleaveIO) + +runLanguageServer + :: forall config. (Show config) + => LSP.Options + -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project + -> (IdeState -> Value -> IO (Either T.Text config)) + -> LSP.Handlers (ServerM config) + -> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> HieDb -> IndexQueue -> IO IdeState) + -> IO () +runLanguageServer options getHieDbLoc onConfigurationChange userHandlers getIdeState = do + -- Move stdout to another file descriptor and duplicate stderr + -- to stdout. This guards against stray prints from corrupting the JSON-RPC + -- message stream. + newStdout <- hDuplicate stdout + stderr `Ghcide.hDuplicateTo'` stdout + hSetBuffering stderr NoBuffering + hSetBuffering stdout NoBuffering + + -- Print out a single space to assert that the above redirection works. + -- This is interleaved with the logger, hence we just print a space here in + -- order not to mess up the output too much. Verified that this breaks + -- the language server tests without the redirection. + putStr " " >> hFlush stdout + + -- These barriers are signaled when the threads reading from these chans exit. + -- This should not happen but if it does, we will make sure that the whole server + -- dies and can be restarted instead of losing threads silently. + clientMsgBarrier <- newBarrier + -- Forcefully exit + let exit = signalBarrier clientMsgBarrier () + + -- The set of requests ids that we have received but not finished processing + pendingRequests <- newTVarIO Set.empty + -- The set of requests that have been cancelled and are also in pendingRequests + cancelledRequests <- newTVarIO Set.empty + + let cancelRequest reqId = atomically $ do + queued <- readTVar pendingRequests + -- We want to avoid that the list of cancelled requests + -- keeps growing if we receive cancellations for requests + -- that do not exist or have already been processed. + when (reqId `elem` queued) $ + modifyTVar cancelledRequests (Set.insert reqId) + let clearReqId reqId = atomically $ do + modifyTVar pendingRequests (Set.delete reqId) + modifyTVar cancelledRequests (Set.delete reqId) + -- We implement request cancellation by racing waitForCancel against + -- the actual request handler. + let waitForCancel reqId = atomically $ do + cancelled <- readTVar cancelledRequests + unless (reqId `Set.member` cancelled) retry + + let ideHandlers = mconcat + [ setIdeHandlers + , userHandlers + , setHandlersNotifications -- absolutely critical, join them with user notifications + ] + + -- Send everything over a channel, since you need to wait until after initialise before + -- LspFuncs is available + clientMsgChan :: Chan ReactorMessage <- newChan + + let asyncHandlers = mconcat + [ ideHandlers + , cancelHandler cancelRequest + , exitHandler exit + ] + -- Cancel requests are special since they need to be handled + -- out of order to be useful. Existing handlers are run afterwards. + + + let serverDefinition = LSP.ServerDefinition + { LSP.onConfigurationChange = \v -> do + (_chan, ide) <- ask + liftIO $ onConfigurationChange ide v + , LSP.doInitialize = handleInit exit clearReqId waitForCancel clientMsgChan + , LSP.staticHandlers = asyncHandlers + , LSP.interpretHandler = \(env, st) -> LSP.Iso (LSP.runLspT env . flip runReaderT (clientMsgChan,st)) liftIO + , LSP.options = modifyOptions options + } + + void $ waitAnyCancel =<< traverse async + [ void $ LSP.runServerWithHandles + stdin + newStdout + serverDefinition + , void $ waitBarrier clientMsgBarrier + ] + + where + handleInit + :: IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage + -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) + handleInit exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do + traceWithSpan sp params + let root = LSP.resRootPath env + + dir <- getCurrentDirectory + dbLoc <- getHieDbLoc dir + + -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference + -- to 'getIdeState', so we use this dirty trick + dbMVar <- newEmptyMVar + ~(hiedb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar + + ide <- getIdeState env (makeLSPVFSHandle env) root hiedb hieChan + + let initConfig = parseConfiguration params + logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig + registerIdeConfiguration (shakeExtras ide) initConfig + + _ <- flip forkFinally (const exitClientMsg) $ runWithDb dbLoc $ \hiedb hieChan -> do + putMVar dbMVar (hiedb,hieChan) + forever $ do + msg <- readChan clientMsgChan + -- We dispatch notifications synchronously and requests asynchronously + -- This is to ensure that all file edits and config changes are applied before a request is handled + case msg of + ReactorNotification act -> do + catch act $ \(e :: SomeException) -> + logError (ideLogger ide) $ T.pack $ + "Unexpected exception on notification, please report!\n" ++ + "Exception: " ++ show e + ReactorRequest _id act k -> void $ async $ + checkCancelled ide clearReqId waitForCancel _id act k + pure $ Right (env,ide) + + checkCancelled + :: IdeState -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> SomeLspId + -> IO () -> (ResponseError -> IO ()) -> IO () + checkCancelled ide clearReqId waitForCancel _id act k = + flip finally (clearReqId _id) $ + catch (do + -- We could optimize this by first checking if the id + -- is in the cancelled set. However, this is unlikely to be a + -- bottleneck and the additional check might hide + -- issues with async exceptions that need to be fixed. + cancelOrRes <- race (waitForCancel _id) act + case cancelOrRes of + Left () -> do + logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id + k $ ResponseError RequestCancelled "" Nothing + Right res -> pure res + ) $ \(e :: SomeException) -> do + logError (ideLogger ide) $ T.pack $ + "Unexpected exception on request, please report!\n" ++ + "Exception: " ++ show e + k $ ResponseError InternalError (T.pack $ show e) Nothing + + +cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) +cancelHandler cancelRequest = LSP.notificationHandler SCancelRequest $ \NotificationMessage{_params=CancelParams{_id}} -> + liftIO $ cancelRequest (SomeLspId _id) + +exitHandler :: IO () -> LSP.Handlers (ServerM c) +exitHandler exit = LSP.notificationHandler SExit $ const $ do + (_, ide) <- ask + -- flush out the Shake session to record a Shake profile if applicable + liftIO $ restartShakeSession (shakeExtras ide) [] + liftIO exit + +modifyOptions :: LSP.Options -> LSP.Options +modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS + } + where + tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ InR $ SaveOptions Nothing} + origTDS = fromMaybe tdsDefault $ LSP.textDocumentSync x + tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing + diff --git a/src/Development/IDE/LSP/Notifications.hs b/src/Development/IDE/LSP/Notifications.hs --- a/src/Development/IDE/LSP/Notifications.hs +++ b/src/Development/IDE/LSP/Notifications.hs @@ -1,144 +1,140 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} - -module Development.IDE.LSP.Notifications - ( setHandlersNotifications - ) where - -import qualified Language.LSP.Server as LSP -import Language.LSP.Types -import qualified Language.LSP.Types as LSP -import qualified Language.LSP.Types.Capabilities as LSP - -import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.Service -import Development.IDE.LSP.Server -import Development.IDE.Core.Shake -import Development.IDE.Types.Location -import Development.IDE.Types.Logger -import Development.IDE.Types.Options - -import Control.Monad.Extra -import Data.Foldable as F -import Data.Maybe -import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as S -import qualified Data.Text as Text - -import Development.IDE.Core.FileStore (setSomethingModified, setFileModified, typecheckParents) -import Development.IDE.Core.FileExists (modifyFileExists, watchedGlobs) -import Development.IDE.Core.OfInterest -import Ide.Plugin.Config (CheckParents(CheckOnClose)) -import Control.Monad.IO.Class - - -whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () -whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath' - -setHandlersNotifications :: LSP.Handlers (ServerM c) -setHandlersNotifications = mconcat - [ notificationHandler LSP.STextDocumentDidOpen $ - \ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do - updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List []) - whenUriFile _uri $ \file -> do - -- We don't know if the file actually exists, or if the contents match those on disk - -- For example, vscode restores previously unsaved contents on open - modifyFilesOfInterest ide (M.insert file Modified{firstOpen=True}) - setFileModified ide False file - logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri - - , notificationHandler LSP.STextDocumentDidChange $ - \ide (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do - updatePositionMapping ide identifier changes - whenUriFile _uri $ \file -> do - modifyFilesOfInterest ide (M.insert file Modified{firstOpen=False}) - setFileModified ide False file - logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri - - , notificationHandler LSP.STextDocumentDidSave $ - \ide (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do - whenUriFile _uri $ \file -> do - modifyFilesOfInterest ide (M.insert file OnDisk) - setFileModified ide True file - logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri - - , notificationHandler LSP.STextDocumentDidClose $ - \ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do - whenUriFile _uri $ \file -> do - modifyFilesOfInterest ide (M.delete file) - -- Refresh all the files that depended on this - checkParents <- optCheckParents =<< getIdeOptionsIO (shakeExtras ide) - when (checkParents >= CheckOnClose) $ typecheckParents ide file - logDebug (ideLogger ide) $ "Closed text document: " <> getUri _uri - - , notificationHandler LSP.SWorkspaceDidChangeWatchedFiles $ - \ide (DidChangeWatchedFilesParams fileEvents) -> liftIO $ do - -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and - -- what we do with them - let events = - mapMaybe - (\(FileEvent uri ev) -> - (, ev /= FcDeleted) . toNormalizedFilePath' - <$> LSP.uriToFilePath uri - ) - ( F.toList fileEvents ) - let msg = Text.pack $ show events - logDebug (ideLogger ide) $ "Files created or deleted: " <> msg - modifyFileExists ide events - setSomethingModified ide - - , notificationHandler LSP.SWorkspaceDidChangeWorkspaceFolders $ - \ide (DidChangeWorkspaceFoldersParams events) -> liftIO $ do - let add = S.union - substract = flip S.difference - modifyWorkspaceFolders ide - $ add (foldMap (S.singleton . parseWorkspaceFolder) (_added events)) - . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events)) - - , notificationHandler LSP.SWorkspaceDidChangeConfiguration $ - \ide (DidChangeConfigurationParams cfg) -> liftIO $ do - let msg = Text.pack $ show cfg - logDebug (ideLogger ide) $ "Configuration changed: " <> msg - modifyClientSettings ide (const $ Just cfg) - setSomethingModified ide - - , notificationHandler LSP.SInitialized $ \ide _ -> do - clientCapabilities <- LSP.getClientCapabilities - let watchSupported = case () of - _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities - , Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace - , Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles - , Just True <- _dynamicRegistration - -> True - | otherwise -> False - if watchSupported - then do - opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide - let - regParams = RegistrationParams (List [SomeRegistration registration]) - -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't). - -- We could also use something like a random UUID, as some other servers do, but this works for - -- our purposes. - registration = Registration "globalFileWatches" - SWorkspaceDidChangeWatchedFiles - regOptions - regOptions = - DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers } - -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind - watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True} - -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is - -- The patterns will be something like "**/.hs", i.e. "any number of directory segments, - -- followed by a file with an extension 'hs'. - watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind } - -- We use multiple watchers instead of one using '{}' because lsp-test doesn't - -- support that: https://github.com/bubba/lsp-test/issues/77 - watchers = [ watcher (Text.pack glob) | glob <- watchedGlobs opts ] - - void $ LSP.sendRequest SClientRegisterCapability regParams (const $ pure ()) -- TODO handle response - else liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling" - ] +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} + +module Development.IDE.LSP.Notifications + ( setHandlersNotifications + ) where + +import qualified Language.LSP.Server as LSP +import Language.LSP.Types +import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Types.Capabilities as LSP + +import Development.IDE.Core.IdeConfiguration +import Development.IDE.Core.Service +import Development.IDE.Core.Shake +import Development.IDE.LSP.Server +import Development.IDE.Types.Location +import Development.IDE.Types.Logger +import Development.IDE.Types.Options + +import Control.Monad.Extra +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import qualified Data.Text as Text + +import Control.Monad.IO.Class +import Development.IDE.Core.FileExists (modifyFileExists, + watchedGlobs) +import Development.IDE.Core.FileStore (resetFileStore, + setFileModified, + setSomethingModified, + typecheckParents) +import Development.IDE.Core.OfInterest +import Ide.Plugin.Config (CheckParents (CheckOnClose)) + + +whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () +whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath' + +setHandlersNotifications :: LSP.Handlers (ServerM c) +setHandlersNotifications = mconcat + [ notificationHandler LSP.STextDocumentDidOpen $ + \ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do + updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List []) + whenUriFile _uri $ \file -> do + -- We don't know if the file actually exists, or if the contents match those on disk + -- For example, vscode restores previously unsaved contents on open + modifyFilesOfInterest ide (M.insert file Modified{firstOpen=True}) + setFileModified ide False file + logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri + + , notificationHandler LSP.STextDocumentDidChange $ + \ide (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do + updatePositionMapping ide identifier changes + whenUriFile _uri $ \file -> do + modifyFilesOfInterest ide (M.insert file Modified{firstOpen=False}) + setFileModified ide False file + logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri + + , notificationHandler LSP.STextDocumentDidSave $ + \ide (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do + whenUriFile _uri $ \file -> do + modifyFilesOfInterest ide (M.insert file OnDisk) + setFileModified ide True file + logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri + + , notificationHandler LSP.STextDocumentDidClose $ + \ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do + whenUriFile _uri $ \file -> do + modifyFilesOfInterest ide (M.delete file) + -- Refresh all the files that depended on this + checkParents <- optCheckParents =<< getIdeOptionsIO (shakeExtras ide) + when (checkParents >= CheckOnClose) $ typecheckParents ide file + logDebug (ideLogger ide) $ "Closed text document: " <> getUri _uri + + , notificationHandler LSP.SWorkspaceDidChangeWatchedFiles $ + \ide (DidChangeWatchedFilesParams (List fileEvents)) -> liftIO $ do + -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and + -- what we do with them + let msg = Text.pack $ show fileEvents + logDebug (ideLogger ide) $ "Watched file events: " <> msg + modifyFileExists ide fileEvents + resetFileStore ide fileEvents + setSomethingModified ide + + , notificationHandler LSP.SWorkspaceDidChangeWorkspaceFolders $ + \ide (DidChangeWorkspaceFoldersParams events) -> liftIO $ do + let add = S.union + substract = flip S.difference + modifyWorkspaceFolders ide + $ add (foldMap (S.singleton . parseWorkspaceFolder) (_added events)) + . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events)) + + , notificationHandler LSP.SWorkspaceDidChangeConfiguration $ + \ide (DidChangeConfigurationParams cfg) -> liftIO $ do + let msg = Text.pack $ show cfg + logDebug (ideLogger ide) $ "Configuration changed: " <> msg + modifyClientSettings ide (const $ Just cfg) + setSomethingModified ide + + , notificationHandler LSP.SInitialized $ \ide _ -> do + clientCapabilities <- LSP.getClientCapabilities + let watchSupported = case () of + _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities + , Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace + , Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles + , Just True <- _dynamicRegistration + -> True + | otherwise -> False + if watchSupported + then do + opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide + let + regParams = RegistrationParams (List [SomeRegistration registration]) + -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't). + -- We could also use something like a random UUID, as some other servers do, but this works for + -- our purposes. + registration = Registration "globalFileWatches" + SWorkspaceDidChangeWatchedFiles + regOptions + regOptions = + DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers } + -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind + watchKind = WatchKind { _watchCreate = True, _watchChange = True, _watchDelete = True} + -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is + -- The patterns will be something like "**/.hs", i.e. "any number of directory segments, + -- followed by a file with an extension 'hs'. + watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind } + -- We use multiple watchers instead of one using '{}' because lsp-test doesn't + -- support that: https://github.com/bubba/lsp-test/issues/77 + watchers = [ watcher (Text.pack glob) | glob <- watchedGlobs opts ] + + void $ LSP.sendRequest SClientRegisterCapability regParams (const $ pure ()) -- TODO handle response + else liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling" + ] diff --git a/src/Development/IDE/LSP/Outline.hs b/src/Development/IDE/LSP/Outline.hs --- a/src/Development/IDE/LSP/Outline.hs +++ b/src/Development/IDE/LSP/Outline.hs @@ -1,225 +1,221 @@ -{-# LANGUAGE CPP #-} - -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DuplicateRecordFields #-} -#include "ghc-api-version.h" - -module Development.IDE.LSP.Outline - ( moduleOutline - ) -where - -import Language.LSP.Types -import Language.LSP.Server (LspM) -import Control.Monad.IO.Class -import Data.Functor -import Data.Generics -import Data.Maybe -import Data.Text ( Text - , pack - ) -import qualified Data.Text as T -import Development.IDE.Core.Rules -import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat -import Development.IDE.GHC.Error ( realSrcSpanToRange ) -import Development.IDE.Types.Location -import Outputable ( Outputable - , ppr - , showSDocUnsafe - ) - -moduleOutline - :: IdeState -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation)) -moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri } - = liftIO $ case uriToFilePath uri of - Just (toNormalizedFilePath' -> fp) -> do - mb_decls <- fmap fst <$> runAction "Outline" ideState (useWithStale GetParsedModule fp) - pure $ Right $ case mb_decls of - Nothing -> InL (List []) - Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } } - -> let - declSymbols = mapMaybe documentSymbolForDecl hsmodDecls - moduleSymbol = hsmodName >>= \case - (L (RealSrcSpan l) m) -> Just $ - (defDocumentSymbol l :: DocumentSymbol) - { _name = pprText m - , _kind = SkFile - , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0 - } - _ -> Nothing - importSymbols = maybe [] pure $ - documentSymbolForImportSummary - (mapMaybe documentSymbolForImport hsmodImports) - allSymbols = case moduleSymbol of - Nothing -> importSymbols <> declSymbols - Just x -> - [ x { _children = Just (List (importSymbols <> declSymbols)) - } - ] - in - InL (List allSymbols) - - - Nothing -> pure $ Right $ InL (List []) - -documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol -documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) - = Just (defDocumentSymbol l :: DocumentSymbol) - { _name = showRdrName n - <> (case pprText fdTyVars of - "" -> "" - t -> " " <> t - ) - , _detail = Just $ pprText fdInfo - , _kind = SkClass - } -documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) - = Just (defDocumentSymbol l :: DocumentSymbol) - { _name = showRdrName name - <> (case pprText tcdTyVars of - "" -> "" - t -> " " <> t - ) - , _kind = SkClass - , _detail = Just "class" - , _children = - Just $ List - [ (defDocumentSymbol l :: DocumentSymbol) - { _name = showRdrName n - , _kind = SkMethod - , _selectionRange = realSrcSpanToRange l' - } - | L (RealSrcSpan l) (ClassOpSig _ False names _) <- tcdSigs - , L (RealSrcSpan l') n <- names - ] - } -documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) - = Just (defDocumentSymbol l :: DocumentSymbol) - { _name = showRdrName name - , _kind = SkStruct - , _children = - Just $ List - [ (defDocumentSymbol l :: DocumentSymbol) - { _name = showRdrName n - , _kind = SkConstructor - , _selectionRange = realSrcSpanToRange l' - , _children = conArgRecordFields (getConArgs x) - } - | L (RealSrcSpan l ) x <- dd_cons - , L (RealSrcSpan l') n <- getConNames x - ] - } - where - -- | Extract the record fields of a constructor - conArgRecordFields (RecCon (L _ lcdfs)) = Just $ List - [ (defDocumentSymbol l :: DocumentSymbol) - { _name = showRdrName n - , _kind = SkField - } - | L _ cdf <- lcdfs - , L (RealSrcSpan l) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf - ] - conArgRecordFields _ = Nothing -documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ SynDecl { tcdLName = L (RealSrcSpan l') n })) = Just - (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n - , _kind = SkTypeParameter - , _selectionRange = realSrcSpanToRange l' - } -documentSymbolForDecl (L (RealSrcSpan l) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) - = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty - , _kind = SkInterface - } -documentSymbolForDecl (L (RealSrcSpan l) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) - = Just (defDocumentSymbol l :: DocumentSymbol) - { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords - (map pprText feqn_pats) - , _kind = SkInterface - } -documentSymbolForDecl (L (RealSrcSpan l) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) - = Just (defDocumentSymbol l :: DocumentSymbol) - { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords - (map pprText feqn_pats) - , _kind = SkInterface - } -documentSymbolForDecl (L (RealSrcSpan l) (DerivD _ DerivDecl { deriv_type })) = - gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) -> - (defDocumentSymbol l :: DocumentSymbol) { _name = pprText @(HsType GhcPs) - name - , _kind = SkInterface - } -documentSymbolForDecl (L (RealSrcSpan l) (ValD _ FunBind{fun_id = L _ name})) = Just - (defDocumentSymbol l :: DocumentSymbol) - { _name = showRdrName name - , _kind = SkFunction - } -documentSymbolForDecl (L (RealSrcSpan l) (ValD _ PatBind{pat_lhs})) = Just - (defDocumentSymbol l :: DocumentSymbol) - { _name = pprText pat_lhs - , _kind = SkFunction - } - -documentSymbolForDecl (L (RealSrcSpan l) (ForD _ x)) = Just - (defDocumentSymbol l :: DocumentSymbol) - { _name = case x of - ForeignImport{} -> name - ForeignExport{} -> name - XForeignDecl{} -> "?" - , _kind = SkObject - , _detail = case x of - ForeignImport{} -> Just "import" - ForeignExport{} -> Just "export" - XForeignDecl{} -> Nothing - } - where name = showRdrName $ unLoc $ fd_name x - -documentSymbolForDecl _ = Nothing - --- | Wrap the Document imports into a hierarchical outline for --- a better overview of symbols in scope. --- If there are no imports, then no hierarchy will be created. -documentSymbolForImportSummary :: [DocumentSymbol] -> Maybe DocumentSymbol -documentSymbolForImportSummary [] = Nothing -documentSymbolForImportSummary importSymbols = - let - -- safe because if we have no ranges then we don't take this branch - mergeRanges xs = Range (minimum $ map _start xs) (maximum $ map _end xs) - importRange = mergeRanges $ map (_range :: DocumentSymbol -> Range) importSymbols - in - Just (defDocumentSymbol empty :: DocumentSymbol) - { _name = "imports" - , _kind = SkModule - , _children = Just (List importSymbols) - , _range = importRange - , _selectionRange = importRange - } - -documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol -documentSymbolForImport (L (RealSrcSpan l) ImportDecl { ideclName, ideclQualified }) = Just - (defDocumentSymbol l :: DocumentSymbol) - { _name = "import " <> pprText ideclName - , _kind = SkModule -#if MIN_GHC_API_VERSION(8,10,0) - , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" } -#else - , _detail = if ideclQualified then Just "qualified" else Nothing -#endif - } -documentSymbolForImport _ = Nothing - -defDocumentSymbol :: RealSrcSpan -> DocumentSymbol -defDocumentSymbol l = DocumentSymbol { .. } where - _detail = Nothing - _deprecated = Nothing - _name = "" - _kind = SkUnknown 0 - _range = realSrcSpanToRange l - _selectionRange = realSrcSpanToRange l - _children = Nothing - -showRdrName :: RdrName -> Text -showRdrName = pprText - -pprText :: Outputable a => a -> Text -pprText = pack . showSDocUnsafe . ppr +{-# LANGUAGE CPP #-} + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +#include "ghc-api-version.h" + +module Development.IDE.LSP.Outline + ( moduleOutline + ) +where + +import Control.Monad.IO.Class +import Data.Functor +import Data.Generics +import Data.Maybe +import Data.Text (Text, pack) +import qualified Data.Text as T +import Development.IDE.Core.Rules +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Error (realSrcSpanToRange) +import Development.IDE.Types.Location +import Language.LSP.Server (LspM) +import Language.LSP.Types +import Outputable (Outputable, ppr, + showSDocUnsafe) + +moduleOutline + :: IdeState -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation)) +moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri } + = liftIO $ case uriToFilePath uri of + Just (toNormalizedFilePath' -> fp) -> do + mb_decls <- fmap fst <$> runAction "Outline" ideState (useWithStale GetParsedModule fp) + pure $ Right $ case mb_decls of + Nothing -> InL (List []) + Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } } + -> let + declSymbols = mapMaybe documentSymbolForDecl hsmodDecls + moduleSymbol = hsmodName >>= \case + (L (RealSrcSpan l) m) -> Just $ + (defDocumentSymbol l :: DocumentSymbol) + { _name = pprText m + , _kind = SkFile + , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0 + } + _ -> Nothing + importSymbols = maybe [] pure $ + documentSymbolForImportSummary + (mapMaybe documentSymbolForImport hsmodImports) + allSymbols = case moduleSymbol of + Nothing -> importSymbols <> declSymbols + Just x -> + [ x { _children = Just (List (importSymbols <> declSymbols)) + } + ] + in + InL (List allSymbols) + + + Nothing -> pure $ Right $ InL (List []) + +documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol +documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) + = Just (defDocumentSymbol l :: DocumentSymbol) + { _name = showRdrName n + <> (case pprText fdTyVars of + "" -> "" + t -> " " <> t + ) + , _detail = Just $ pprText fdInfo + , _kind = SkClass + } +documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) + = Just (defDocumentSymbol l :: DocumentSymbol) + { _name = showRdrName name + <> (case pprText tcdTyVars of + "" -> "" + t -> " " <> t + ) + , _kind = SkClass + , _detail = Just "class" + , _children = + Just $ List + [ (defDocumentSymbol l :: DocumentSymbol) + { _name = showRdrName n + , _kind = SkMethod + , _selectionRange = realSrcSpanToRange l' + } + | L (RealSrcSpan l) (ClassOpSig _ False names _) <- tcdSigs + , L (RealSrcSpan l') n <- names + ] + } +documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) + = Just (defDocumentSymbol l :: DocumentSymbol) + { _name = showRdrName name + , _kind = SkStruct + , _children = + Just $ List + [ (defDocumentSymbol l :: DocumentSymbol) + { _name = showRdrName n + , _kind = SkConstructor + , _selectionRange = realSrcSpanToRange l' + , _children = conArgRecordFields (getConArgs x) + } + | L (RealSrcSpan l ) x <- dd_cons + , L (RealSrcSpan l') n <- getConNames x + ] + } + where + -- | Extract the record fields of a constructor + conArgRecordFields (RecCon (L _ lcdfs)) = Just $ List + [ (defDocumentSymbol l :: DocumentSymbol) + { _name = showRdrName n + , _kind = SkField + } + | L _ cdf <- lcdfs + , L (RealSrcSpan l) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf + ] + conArgRecordFields _ = Nothing +documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ SynDecl { tcdLName = L (RealSrcSpan l') n })) = Just + (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n + , _kind = SkTypeParameter + , _selectionRange = realSrcSpanToRange l' + } +documentSymbolForDecl (L (RealSrcSpan l) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) + = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty + , _kind = SkInterface + } +documentSymbolForDecl (L (RealSrcSpan l) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) + = Just (defDocumentSymbol l :: DocumentSymbol) + { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords + (map pprText feqn_pats) + , _kind = SkInterface + } +documentSymbolForDecl (L (RealSrcSpan l) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) + = Just (defDocumentSymbol l :: DocumentSymbol) + { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords + (map pprText feqn_pats) + , _kind = SkInterface + } +documentSymbolForDecl (L (RealSrcSpan l) (DerivD _ DerivDecl { deriv_type })) = + gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) -> + (defDocumentSymbol l :: DocumentSymbol) { _name = pprText @(HsType GhcPs) + name + , _kind = SkInterface + } +documentSymbolForDecl (L (RealSrcSpan l) (ValD _ FunBind{fun_id = L _ name})) = Just + (defDocumentSymbol l :: DocumentSymbol) + { _name = showRdrName name + , _kind = SkFunction + } +documentSymbolForDecl (L (RealSrcSpan l) (ValD _ PatBind{pat_lhs})) = Just + (defDocumentSymbol l :: DocumentSymbol) + { _name = pprText pat_lhs + , _kind = SkFunction + } + +documentSymbolForDecl (L (RealSrcSpan l) (ForD _ x)) = Just + (defDocumentSymbol l :: DocumentSymbol) + { _name = case x of + ForeignImport{} -> name + ForeignExport{} -> name + XForeignDecl{} -> "?" + , _kind = SkObject + , _detail = case x of + ForeignImport{} -> Just "import" + ForeignExport{} -> Just "export" + XForeignDecl{} -> Nothing + } + where name = showRdrName $ unLoc $ fd_name x + +documentSymbolForDecl _ = Nothing + +-- | Wrap the Document imports into a hierarchical outline for +-- a better overview of symbols in scope. +-- If there are no imports, then no hierarchy will be created. +documentSymbolForImportSummary :: [DocumentSymbol] -> Maybe DocumentSymbol +documentSymbolForImportSummary [] = Nothing +documentSymbolForImportSummary importSymbols = + let + -- safe because if we have no ranges then we don't take this branch + mergeRanges xs = Range (minimum $ map _start xs) (maximum $ map _end xs) + importRange = mergeRanges $ map (_range :: DocumentSymbol -> Range) importSymbols + in + Just (defDocumentSymbol empty :: DocumentSymbol) + { _name = "imports" + , _kind = SkModule + , _children = Just (List importSymbols) + , _range = importRange + , _selectionRange = importRange + } + +documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol +documentSymbolForImport (L (RealSrcSpan l) ImportDecl { ideclName, ideclQualified }) = Just + (defDocumentSymbol l :: DocumentSymbol) + { _name = "import " <> pprText ideclName + , _kind = SkModule +#if MIN_GHC_API_VERSION(8,10,0) + , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" } +#else + , _detail = if ideclQualified then Just "qualified" else Nothing +#endif + } +documentSymbolForImport _ = Nothing + +defDocumentSymbol :: RealSrcSpan -> DocumentSymbol +defDocumentSymbol l = DocumentSymbol { .. } where + _detail = Nothing + _deprecated = Nothing + _name = "" + _kind = SkUnknown 0 + _range = realSrcSpanToRange l + _selectionRange = realSrcSpanToRange l + _children = Nothing + +showRdrName :: RdrName -> Text +showRdrName = pprText + +pprText :: Outputable a => a -> Text +pprText = pack . showSDocUnsafe . ppr diff --git a/src/Development/IDE/LSP/Server.hs b/src/Development/IDE/LSP/Server.hs --- a/src/Development/IDE/LSP/Server.hs +++ b/src/Development/IDE/LSP/Server.hs @@ -1,61 +1,61 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE GADTs #-} -module Development.IDE.LSP.Server - ( ReactorMessage(..) - , ReactorChan - , ServerM - , requestHandler - , notificationHandler - ) where - -import Language.LSP.Server (LspM, Handlers) -import Language.LSP.Types -import qualified Language.LSP.Server as LSP -import Development.IDE.Core.Shake -import UnliftIO.Chan -import Control.Monad.Reader -import Ide.Types (HasTracing, traceWithSpan) -import Development.IDE.Core.Tracing - -data ReactorMessage - = ReactorNotification (IO ()) - | ReactorRequest SomeLspId (IO ()) (ResponseError -> IO ()) - -type ReactorChan = Chan ReactorMessage -type ServerM c = ReaderT (ReactorChan, IdeState) (LspM c) - -requestHandler - :: forall (m :: Method FromClient Request) c. (HasTracing (MessageParams m)) => - SMethod m - -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (ResponseResult m))) - -> Handlers (ServerM c) -requestHandler m k = LSP.requestHandler m $ \RequestMessage{_method,_id,_params} resp -> do - st@(chan,ide) <- ask - env <- LSP.getLspEnv - let resp' = flip runReaderT st . resp - trace x = otTracedHandler "Request" (show _method) $ \sp -> do - traceWithSpan sp _params - x - writeChan chan $ ReactorRequest (SomeLspId _id) (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left) - -notificationHandler - :: forall (m :: Method FromClient Notification) c. (HasTracing (MessageParams m)) => - SMethod m - -> (IdeState -> MessageParams m -> LspM c ()) - -> Handlers (ServerM c) -notificationHandler m k = LSP.notificationHandler m $ \NotificationMessage{_params,_method}-> do - (chan,ide) <- ask - env <- LSP.getLspEnv - let trace x = otTracedHandler "Notification" (show _method) $ \sp -> do - traceWithSpan sp _params - x - writeChan chan $ ReactorNotification (trace $ LSP.runLspT env $ k ide _params) - - +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +module Development.IDE.LSP.Server + ( ReactorMessage(..) + , ReactorChan + , ServerM + , requestHandler + , notificationHandler + ) where + +import Control.Monad.Reader +import Development.IDE.Core.Shake +import Development.IDE.Core.Tracing +import Ide.Types (HasTracing, traceWithSpan) +import Language.LSP.Server (Handlers, LspM) +import qualified Language.LSP.Server as LSP +import Language.LSP.Types +import UnliftIO.Chan + +data ReactorMessage + = ReactorNotification (IO ()) + | ReactorRequest SomeLspId (IO ()) (ResponseError -> IO ()) + +type ReactorChan = Chan ReactorMessage +type ServerM c = ReaderT (ReactorChan, IdeState) (LspM c) + +requestHandler + :: forall (m :: Method FromClient Request) c. (HasTracing (MessageParams m)) => + SMethod m + -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (ResponseResult m))) + -> Handlers (ServerM c) +requestHandler m k = LSP.requestHandler m $ \RequestMessage{_method,_id,_params} resp -> do + st@(chan,ide) <- ask + env <- LSP.getLspEnv + let resp' = flip runReaderT st . resp + trace x = otTracedHandler "Request" (show _method) $ \sp -> do + traceWithSpan sp _params + x + writeChan chan $ ReactorRequest (SomeLspId _id) (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left) + +notificationHandler + :: forall (m :: Method FromClient Notification) c. (HasTracing (MessageParams m)) => + SMethod m + -> (IdeState -> MessageParams m -> LspM c ()) + -> Handlers (ServerM c) +notificationHandler m k = LSP.notificationHandler m $ \NotificationMessage{_params,_method}-> do + (chan,ide) <- ask + env <- LSP.getLspEnv + let trace x = otTracedHandler "Notification" (show _method) $ \sp -> do + traceWithSpan sp _params + x + writeChan chan $ ReactorNotification (trace $ LSP.runLspT env $ k ide _params) + + diff --git a/src/Development/IDE/Main.hs b/src/Development/IDE/Main.hs --- a/src/Development/IDE/Main.hs +++ b/src/Development/IDE/Main.hs @@ -1,225 +1,242 @@ -module Development.IDE.Main (Arguments(..), defaultMain) where -import Control.Concurrent.Extra (readVar) -import Control.Exception.Safe ( - Exception (displayException), - catchAny, - ) -import Control.Monad.Extra (concatMapM, unless, when) -import Data.Default (Default (def)) -import qualified Data.HashMap.Strict as HashMap -import Data.List.Extra ( - intercalate, - isPrefixOf, - nub, - nubOrd, - partition, - ) -import Data.Maybe (catMaybes, fromMaybe, isJust) -import qualified Data.Text as T -import Development.IDE (Action, Rules, noLogging) -import Development.IDE.Core.Debouncer (newAsyncDebouncer) -import Development.IDE.Core.FileStore (makeVFSHandle) -import Development.IDE.Core.OfInterest ( - FileOfInterestStatus (OnDisk), - kick, - setFilesOfInterest, - ) -import Development.IDE.Core.RuleTypes ( - GenerateCore (GenerateCore), - GetHieAst (GetHieAst), - GhcSession (GhcSession), - GhcSessionDeps (GhcSessionDeps), - TypeCheck (TypeCheck), - ) -import Development.IDE.Core.Rules ( - GhcSessionIO (GhcSessionIO), - mainRule, - ) -import Development.IDE.Core.Service (initialise, runAction) -import Development.IDE.Core.Shake ( - IdeState (shakeExtras), - ShakeExtras (state), - uses, - ) -import Development.IDE.Core.Tracing (measureMemory) -import Development.IDE.LSP.LanguageServer (runLanguageServer) -import Development.IDE.Plugin ( - Plugin (pluginHandlers, pluginRules), - ) -import Development.IDE.Plugin.HLS (asGhcIdePlugin) -import Development.IDE.Session (SessionLoadingOptions, loadSessionWithOptions, setInitialDynFlags, getHieDbLoc, runWithDb) -import Development.IDE.Types.Location (toNormalizedFilePath') -import Development.IDE.Types.Logger (Logger) -import Development.IDE.Types.Options ( - IdeGhcSession, - IdeOptions (optCheckParents, optCheckProject, optReportProgress), - clientSupportsProgress, - defaultIdeOptions, - ) -import Development.IDE.Types.Shake (Key (Key)) -import Development.Shake (action) -import HIE.Bios.Cradle (findCradle) -import Ide.Plugin.Config (CheckParents (NeverCheck), Config, getConfigFromNotification) -import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins) -import Ide.Types (IdePlugins) -import qualified Language.LSP.Server as LSP -import qualified System.Directory.Extra as IO -import System.Exit (ExitCode (ExitFailure), exitWith) -import System.FilePath (takeExtension, takeFileName) -import System.IO (hPutStrLn, hSetEncoding, stderr, stdout, utf8) -import System.Time.Extra (offsetTime, showDuration) -import Text.Printf (printf) -import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide - -data Arguments = Arguments - { argsOTMemoryProfiling :: Bool - , argFiles :: Maybe [FilePath] -- ^ Nothing: lsp server ; Just: typecheck and exit - , argsLogger :: Logger - , argsRules :: Rules () - , argsHlsPlugins :: IdePlugins IdeState - , argsGhcidePlugin :: Plugin Config -- ^ Deprecated - , argsSessionLoadingOptions :: SessionLoadingOptions - , argsIdeOptions :: Maybe Config -> Action IdeGhcSession -> IdeOptions - , argsLspOptions :: LSP.Options - , argsDefaultHlsConfig :: Config - , argsGetHieDbLoc :: FilePath -> IO FilePath -- ^ Map project roots to the location of the hiedb for the project - } - -instance Default Arguments where - def = Arguments - { argsOTMemoryProfiling = False - , argFiles = Nothing - , argsLogger = noLogging - , argsRules = mainRule >> action kick - , argsGhcidePlugin = mempty - , argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors - , argsSessionLoadingOptions = def - , argsIdeOptions = const defaultIdeOptions - , argsLspOptions = def {LSP.completionTriggerCharacters = Just "."} - , argsDefaultHlsConfig = def - , argsGetHieDbLoc = getHieDbLoc - } - -defaultMain :: Arguments -> IO () -defaultMain Arguments{..} = do - pid <- T.pack . show <$> getProcessID - - let hlsPlugin = asGhcIdePlugin argsDefaultHlsConfig argsHlsPlugins - hlsCommands = allLspCmdIds' pid argsHlsPlugins - plugins = hlsPlugin <> argsGhcidePlugin - options = argsLspOptions { LSP.executeCommandCommands = Just hlsCommands } - argsOnConfigChange _ide = pure . getConfigFromNotification argsDefaultHlsConfig - rules = argsRules >> pluginRules plugins - - case argFiles of - Nothing -> do - t <- offsetTime - hPutStrLn stderr "Starting LSP server..." - hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" - runLanguageServer options argsGetHieDbLoc argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do - t <- t - hPutStrLn stderr $ "Started LSP server in " ++ showDuration t - - dir <- IO.getCurrentDirectory - - -- We want to set the global DynFlags right now, so that we can use - -- `unsafeGlobalDynFlags` even before the project is configured - -- We do it here since haskell-lsp changes our working directory to the correct place ('rootPath') - -- before calling this function - _mlibdir <- - setInitialDynFlags argsSessionLoadingOptions - `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing) - - sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions $ fromMaybe dir rootPath - config <- LSP.runLspT env LSP.getConfig - let options = (argsIdeOptions config sessionLoader) - { optReportProgress = clientSupportsProgress caps - } - caps = LSP.resClientCapabilities env - debouncer <- newAsyncDebouncer - initialise - argsDefaultHlsConfig - rules - (Just env) - argsLogger - debouncer - options - vfs - hiedb - hieChan - Just argFiles -> do - dir <- IO.getCurrentDirectory - dbLoc <- getHieDbLoc dir - runWithDb dbLoc $ \hiedb hieChan -> do - -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error - hSetEncoding stdout utf8 - hSetEncoding stderr utf8 - - putStrLn $ "ghcide setup tester in " ++ dir ++ "." - putStrLn "Report bugs at https://github.com/haskell/haskell-language-server/issues" - - 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 files - let ucradles = nubOrd cradles - let n = length ucradles - putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1] - when (n > 0) $ putStrLn $ " (" ++ intercalate ", " (catMaybes ucradles) ++ ")" - putStrLn "\nStep 3/4: Initializing the IDE" - vfs <- makeVFSHandle - debouncer <- newAsyncDebouncer - sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir - let options = (argsIdeOptions Nothing sessionLoader) - { optCheckParents = pure NeverCheck - , optCheckProject = pure False - } - ide <- initialise argsDefaultHlsConfig rules Nothing argsLogger debouncer options vfs hiedb hieChan - - 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) - _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' files) - _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' files) - let (worked, failed) = partition fst $ zip (map isJust results) files - when (failed /= []) $ - putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed - - let nfiles xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files" - putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)" - - when argsOTMemoryProfiling $ do - let valuesRef = state $ shakeExtras ide - values <- readVar valuesRef - let consoleObserver Nothing = return $ \size -> printf "Total: %.2fMB\n" (fromIntegral @Int @Double size / 1e6) - consoleObserver (Just k) = return $ \size -> printf " - %s: %.2fKB\n" (show k) (fromIntegral @Int @Double size / 1e3) - - printf "# Shake value store contents(%d):\n" (length values) - let keys = - nub $ - Key GhcSession : - Key GhcSessionDeps : - [k | (_, k) <- HashMap.keys values, k /= Key GhcSessionIO] - ++ [Key GhcSessionIO] - measureMemory argsLogger [keys] consoleObserver valuesRef - - unless (null failed) (exitWith $ ExitFailure (length failed)) -{-# ANN defaultMain ("HLint: ignore Use nubOrd" :: String) #-} - -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 +module Development.IDE.Main (Arguments(..), defaultMain) where +import Control.Concurrent.Extra (newLock, readVar, + withLock) +import Control.Exception.Safe (Exception (displayException), + catchAny) +import Control.Monad.Extra (concatMapM, unless, + when) +import Data.Default (Default (def)) +import qualified Data.HashMap.Strict as HashMap +import Data.Hashable (hashed) +import Data.List.Extra (intercalate, isPrefixOf, + nub, nubOrd, partition) +import Data.Maybe (catMaybes, fromMaybe, + isJust) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Development.IDE (Action, Rules) +import Development.IDE.Core.Debouncer (Debouncer, + newAsyncDebouncer) +import Development.IDE.Core.FileStore (makeVFSHandle) +import Development.IDE.Core.IdeConfiguration (IdeConfiguration (..), + registerIdeConfiguration) +import Development.IDE.Core.OfInterest (FileOfInterestStatus (OnDisk), + kick, + setFilesOfInterest) +import Development.IDE.Core.RuleTypes (GenerateCore (GenerateCore), + GetHieAst (GetHieAst), + GhcSession (GhcSession), + GhcSessionDeps (GhcSessionDeps), + TypeCheck (TypeCheck)) +import Development.IDE.Core.Rules (GhcSessionIO (GhcSessionIO), + mainRule) +import Development.IDE.Core.Service (initialise, runAction) +import Development.IDE.Core.Shake (IdeState (shakeExtras), + ShakeExtras (state), + uses) +import Development.IDE.Core.Tracing (measureMemory) +import Development.IDE.LSP.LanguageServer (runLanguageServer) +import Development.IDE.Plugin (Plugin (pluginHandlers, pluginRules)) +import Development.IDE.Plugin.HLS (asGhcIdePlugin) +import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide +import Development.IDE.Session (SessionLoadingOptions, + getHieDbLoc, + loadSessionWithOptions, + runWithDb, + setInitialDynFlags) +import Development.IDE.Types.Location (NormalizedUri, + toNormalizedFilePath') +import Development.IDE.Types.Logger (Logger (Logger)) +import Development.IDE.Types.Options (IdeGhcSession, + IdeOptions (optCheckParents, optCheckProject, optReportProgress), + clientSupportsProgress, + defaultIdeOptions) +import Development.IDE.Types.Shake (Key (Key)) +import Development.Shake (action) +import HIE.Bios.Cradle (findCradle) +import Ide.Plugin.Config (CheckParents (NeverCheck), + Config, + getConfigFromNotification) +import Ide.PluginUtils (allLspCmdIds', + getProcessID, + pluginDescToIdePlugins) +import Ide.Types (IdePlugins) +import qualified Language.LSP.Server as LSP +import qualified System.Directory.Extra as IO +import System.Exit (ExitCode (ExitFailure), + exitWith) +import System.FilePath (takeExtension, + takeFileName) +import System.IO (BufferMode (LineBuffering), + hPutStrLn, + hSetBuffering, + hSetEncoding, stderr, + stdout, utf8) +import System.Time.Extra (offsetTime, + showDuration) +import Text.Printf (printf) + +data Arguments = Arguments + { argsOTMemoryProfiling :: Bool + , argFiles :: Maybe [FilePath] -- ^ Nothing: lsp server ; Just: typecheck and exit + , argsLogger :: IO Logger + , argsRules :: Rules () + , argsHlsPlugins :: IdePlugins IdeState + , argsGhcidePlugin :: Plugin Config -- ^ Deprecated + , argsSessionLoadingOptions :: SessionLoadingOptions + , argsIdeOptions :: Maybe Config -> Action IdeGhcSession -> IdeOptions + , argsLspOptions :: LSP.Options + , argsDefaultHlsConfig :: Config + , argsGetHieDbLoc :: FilePath -> IO FilePath -- ^ Map project roots to the location of the hiedb for the project + , argsDebouncer :: IO (Debouncer NormalizedUri) -- ^ Debouncer used for diagnostics + } + +instance Default Arguments where + def = Arguments + { argsOTMemoryProfiling = False + , argFiles = Nothing + , argsLogger = stderrLogger + , argsRules = mainRule >> action kick + , argsGhcidePlugin = mempty + , argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors + , argsSessionLoadingOptions = def + , argsIdeOptions = const defaultIdeOptions + , argsLspOptions = def {LSP.completionTriggerCharacters = Just "."} + , argsDefaultHlsConfig = def + , argsGetHieDbLoc = getHieDbLoc + , argsDebouncer = newAsyncDebouncer + } + +-- | Cheap stderr logger that relies on LineBuffering +stderrLogger :: IO Logger +stderrLogger = do + lock <- newLock + return $ Logger $ \p m -> withLock lock $ + T.hPutStrLn stderr $ "[" <> T.pack (show p) <> "] " <> m + +defaultMain :: Arguments -> IO () +defaultMain Arguments{..} = do + pid <- T.pack . show <$> getProcessID + logger <- argsLogger + hSetBuffering stderr LineBuffering + + let hlsPlugin = asGhcIdePlugin argsDefaultHlsConfig argsHlsPlugins + hlsCommands = allLspCmdIds' pid argsHlsPlugins + plugins = hlsPlugin <> argsGhcidePlugin + options = argsLspOptions { LSP.executeCommandCommands = Just hlsCommands } + argsOnConfigChange _ide = pure . getConfigFromNotification argsDefaultHlsConfig + rules = argsRules >> pluginRules plugins + + debouncer <- argsDebouncer + + case argFiles of + Nothing -> do + t <- offsetTime + hPutStrLn stderr "Starting LSP server..." + hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" + runLanguageServer options argsGetHieDbLoc argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do + t <- t + hPutStrLn stderr $ "Started LSP server in " ++ showDuration t + + dir <- IO.getCurrentDirectory + + -- We want to set the global DynFlags right now, so that we can use + -- `unsafeGlobalDynFlags` even before the project is configured + -- We do it here since haskell-lsp changes our working directory to the correct place ('rootPath') + -- before calling this function + _mlibdir <- + setInitialDynFlags argsSessionLoadingOptions + `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing) + + sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions $ fromMaybe dir rootPath + config <- LSP.runLspT env LSP.getConfig + let options = (argsIdeOptions config sessionLoader) + { optReportProgress = clientSupportsProgress caps + } + caps = LSP.resClientCapabilities env + initialise + argsDefaultHlsConfig + rules + (Just env) + logger + debouncer + options + vfs + hiedb + hieChan + Just argFiles -> do + dir <- IO.getCurrentDirectory + dbLoc <- getHieDbLoc dir + runWithDb dbLoc $ \hiedb hieChan -> do + -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 + + putStrLn $ "ghcide setup tester in " ++ dir ++ "." + putStrLn "Report bugs at https://github.com/haskell/haskell-language-server/issues" + + 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 files + let ucradles = nubOrd cradles + let n = length ucradles + putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1] + when (n > 0) $ putStrLn $ " (" ++ intercalate ", " (catMaybes ucradles) ++ ")" + putStrLn "\nStep 3/4: Initializing the IDE" + vfs <- makeVFSHandle + sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir + let options = (argsIdeOptions Nothing sessionLoader) + { optCheckParents = pure NeverCheck + , optCheckProject = pure False + } + ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan + registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) + + 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) + _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' files) + _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' files) + let (worked, failed) = partition fst $ zip (map isJust results) files + when (failed /= []) $ + putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed + + let nfiles xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files" + putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)" + + when argsOTMemoryProfiling $ do + let valuesRef = state $ shakeExtras ide + values <- readVar valuesRef + let consoleObserver Nothing = return $ \size -> printf "Total: %.2fMB\n" (fromIntegral @Int @Double size / 1e6) + consoleObserver (Just k) = return $ \size -> printf " - %s: %.2fKB\n" (show k) (fromIntegral @Int @Double size / 1e3) + + printf "# Shake value store contents(%d):\n" (length values) + let keys = + nub $ + Key GhcSession : + Key GhcSessionDeps : + [k | (_, k) <- HashMap.keys values, k /= Key GhcSessionIO] + ++ [Key GhcSessionIO] + measureMemory logger [keys] consoleObserver valuesRef + + unless (null failed) (exitWith $ ExitFailure (length failed)) +{-# ANN defaultMain ("HLint: ignore Use nubOrd" :: String) #-} + +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 diff --git a/src/Development/IDE/Plugin.hs b/src/Development/IDE/Plugin.hs --- a/src/Development/IDE/Plugin.hs +++ b/src/Development/IDE/Plugin.hs @@ -1,21 +1,21 @@ -module Development.IDE.Plugin ( Plugin(..) ) where - -import Data.Default -import Development.Shake - -import Development.IDE.LSP.Server -import qualified Language.LSP.Server as LSP - -data Plugin c = Plugin - {pluginRules :: Rules () - ,pluginHandlers :: LSP.Handlers (ServerM c) - } - -instance Default (Plugin c) where - def = Plugin mempty mempty - -instance Semigroup (Plugin c) where - Plugin x1 h1 <> Plugin x2 h2 = Plugin (x1<>x2) (h1 <> h2) - -instance Monoid (Plugin c) where - mempty = def +module Development.IDE.Plugin ( Plugin(..) ) where + +import Data.Default +import Development.Shake + +import Development.IDE.LSP.Server +import qualified Language.LSP.Server as LSP + +data Plugin c = Plugin + {pluginRules :: Rules () + ,pluginHandlers :: LSP.Handlers (ServerM c) + } + +instance Default (Plugin c) where + def = Plugin mempty mempty + +instance Semigroup (Plugin c) where + Plugin x1 h1 <> Plugin x2 h2 = Plugin (x1<>x2) (h1 <> h2) + +instance Monoid (Plugin c) where + mempty = def diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs --- a/src/Development/IDE/Plugin/CodeAction.hs +++ b/src/Development/IDE/Plugin/CodeAction.hs @@ -1,1444 +1,1503 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -#include "ghc-api-version.h" - --- | Go to the definition of a variable. -module Development.IDE.Plugin.CodeAction - ( descriptor - - -- * For testing - , matchRegExMultipleImports - ) where - -import Control.Monad (join, guard) -import Control.Monad.IO.Class -import Development.IDE.GHC.Compat -import Development.IDE.Core.Rules -import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Service -import Development.IDE.Core.Shake -import Development.IDE.GHC.Error -import Development.IDE.GHC.ExactPrint -import Development.IDE.Plugin.CodeAction.ExactPrint -import Development.IDE.Plugin.CodeAction.PositionIndexed -import Development.IDE.Plugin.TypeLenses (suggestSignature) -import Development.IDE.Types.Exports -import Development.IDE.Types.HscEnvEq -import Development.IDE.Types.Location -import Development.IDE.Types.Options -import qualified Data.HashMap.Strict as Map -import qualified Language.LSP.Server as LSP -import Language.LSP.VFS -import Language.LSP.Types -import qualified Data.Rope.UTF16 as Rope -import Data.Char -import Data.Maybe -import Data.List.Extra -import Data.List.NonEmpty (NonEmpty((:|))) -import qualified Data.List.NonEmpty as NE -import qualified Data.Text as T -import Text.Regex.TDFA (mrAfter, (=~), (=~~)) -import Outputable (Outputable, ppr, showSDoc, showSDocUnsafe) -import Data.Function -import Control.Arrow ((>>>), second) -import Data.Functor -import Control.Applicative ((<|>)) -import Safe (atMay) -import Bag (isEmptyBag) -import qualified Data.HashSet as Set -import Control.Concurrent.Extra (readVar) -import Development.IDE.GHC.Util (printRdrName, prettyPrint) -import Ide.PluginUtils (subRange) -import Ide.Types -import qualified Data.DList as DL -import Development.IDE.Spans.Common -import OccName -import qualified GHC.LanguageExtensions as Lang -import Control.Lens (alaf) -import Data.Monoid (Ap(..)) -import TcRnTypes (TcGblEnv(..), ImportAvails(..)) -import HscTypes (ImportedModsVal(..), importedByUser) -import RdrName (GlobalRdrElt(..), lookupGlobalRdrEnv) -import SrcLoc (realSrcSpanStart) -import Module (moduleEnvElts) -import qualified Data.Map as M -import qualified Data.Set as S - -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = - (defaultPluginDescriptor plId) - { pluginRules = mempty, - pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction - } - --- | Generate code actions. -codeAction - :: IdeState - -> PluginId - -> CodeActionParams - -> LSP.LspM c (Either ResponseError (List (Command |? CodeAction))) -codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs}) = do - contents <- LSP.getVirtualFile $ toNormalizedUri uri - liftIO $ do - let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents - mbFile = toNormalizedFilePath' <$> uriToFilePath uri - diag <- fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state - (ideOptions, join -> parsedModule, join -> env, join -> annotatedPS, join -> tcM, join -> har) <- runAction "CodeAction" state $ - (,,,,,) <$> getIdeOptions - <*> getParsedModule `traverse` mbFile - <*> use GhcSession `traverse` mbFile - <*> use GetAnnotatedParsedSource `traverse` mbFile - <*> use TypeCheck `traverse` mbFile - <*> use GetHieAst `traverse` mbFile - -- This is quite expensive 0.6-0.7s on GHC - pkgExports <- maybe mempty envPackageExports env - localExports <- readVar (exportsMap $ shakeExtras state) - let - exportsMap = localExports <> pkgExports - df = ms_hspp_opts . pm_mod_summary <$> parsedModule - actions = - [ mkCA title [x] edit - | x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text df annotatedPS tcM har x - , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing - ] - actions' = caRemoveRedundantImports parsedModule text diag xs uri - <> actions - <> caRemoveInvalidExports parsedModule text diag xs uri - pure $ Right $ List actions' - -mkCA :: T.Text -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction) -mkCA title diags edit = - InR $ CodeAction title (Just CodeActionQuickFix) (Just $ List diags) Nothing Nothing (Just edit) Nothing - -rewrite :: - Maybe DynFlags -> - Maybe (Annotated ParsedSource) -> - (DynFlags -> ParsedSource -> [(T.Text, [Rewrite])]) -> - [(T.Text, [TextEdit])] -rewrite (Just df) (Just ps) f - | Right edit <- (traverse . traverse) - (alaf Ap foldMap (rewriteToEdit df (annsA ps))) - (f df $ astA ps) = edit -rewrite _ _ _ = [] - -suggestAction - :: ExportsMap - -> IdeOptions - -> Maybe ParsedModule - -> Maybe T.Text - -> Maybe DynFlags - -> Maybe (Annotated ParsedSource) - -> Maybe TcModuleResult - -> Maybe HieAstResult - -> Diagnostic - -> [(T.Text, [TextEdit])] -suggestAction packageExports ideOptions parsedModule text df annSource tcM har diag = - concat - -- Order these suggestions by priority - [ suggestSignature True diag - , rewrite df annSource $ \_ ps -> suggestExtendImport packageExports ps diag - , rewrite df annSource $ \df ps -> - suggestImportDisambiguation df text ps diag - , suggestFillTypeWildcard diag - , suggestFixConstructorImport text diag - , suggestModuleTypo diag - , suggestReplaceIdentifier text diag - , removeRedundantConstraints text diag - , suggestAddTypeAnnotationToSatisfyContraints text diag - , rewrite df annSource $ \df ps -> suggestConstraint df ps diag - , rewrite df annSource $ \_ ps -> suggestImplicitParameter ps diag - , rewrite df annSource $ \_ ps -> suggestHideShadow ps tcM har diag - ] ++ concat - [ suggestNewDefinition ideOptions pm text diag - ++ suggestNewImport packageExports pm diag - ++ suggestDeleteUnusedBinding pm text diag - ++ suggestExportUnusedTopBinding text pm diag - | Just pm <- [parsedModule] - ] ++ - suggestFillHole diag -- Lowest priority - -findSigOfDecl :: (IdP p -> Bool) -> [LHsDecl p] -> Maybe (Sig p) -findSigOfDecl pred decls = - listToMaybe - [ sig - | L _ (SigD _ sig@(TypeSig _ idsSig _)) <- decls, - any (pred . unLoc) idsSig - ] - -findInstanceHead :: (Outputable (HsType p)) => DynFlags -> String -> [LHsDecl p] -> Maybe (LHsType p) -findInstanceHead df instanceHead decls = - listToMaybe - [ hsib_body - | L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = HsIB {hsib_body}})) <- decls, - showSDoc df (ppr hsib_body) == instanceHead - ] - -findDeclContainingLoc :: Position -> [Located a] -> Maybe (Located a) -findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` l) - --- Single: --- This binding for ‘mod’ shadows the existing binding --- imported from ‘Prelude’ at haskell-language-server/ghcide/src/Development/IDE/Plugin/CodeAction.hs:10:8-40 --- (and originally defined in ‘GHC.Real’)typecheck(-Wname-shadowing) --- Multi: ---This binding for ‘pack’ shadows the existing bindings --- imported from ‘Data.ByteString’ at B.hs:6:1-22 --- imported from ‘Data.ByteString.Lazy’ at B.hs:8:1-27 --- imported from ‘Data.Text’ at B.hs:7:1-16 -suggestHideShadow :: ParsedSource -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Rewrite])] -suggestHideShadow pm@(L _ HsModule {hsmodImports}) mTcM mHar Diagnostic {_message, _range} - | Just [identifier, modName, s] <- - matchRegexUnifySpaces - _message - "This binding for ‘([^`]+)’ shadows the existing binding imported from ‘([^`]+)’ at ([^ ]*)" = - suggests identifier modName s - | Just [identifier] <- - matchRegexUnifySpaces - _message - "This binding for ‘([^`]+)’ shadows the existing bindings", - Just matched <- allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’ at ([^ ]*)", - mods <- [(modName, s) | [_, modName, s] <- matched], - result <- nubOrdBy (compare `on` fst) $ mods >>= uncurry (suggests identifier), - hideAll <- ("Hide " <> identifier <> " from all occurence imports", concat $ snd <$> result) = - result <> [hideAll] - | otherwise = [] - where - suggests identifier modName s - | Just tcM <- mTcM, - Just har <- mHar, - [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack s], - isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (RealSrcSpan s'), - mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName, - title <- "Hide " <> identifier <> " from " <> modName = - if modName == "Prelude" && null mDecl - then [(title, maybeToList $ hideImplicitPreludeSymbol (T.unpack identifier) pm)] - else maybeToList $ (title,) . pure . hideSymbol (T.unpack identifier) <$> mDecl - | otherwise = [] - -findImportDeclByModuleName :: [LImportDecl GhcPs] -> String -> Maybe (LImportDecl GhcPs) -findImportDeclByModuleName decls modName = flip find decls $ \case - (L _ ImportDecl {..}) -> modName == moduleNameString (unLoc ideclName) - _ -> error "impossible" - -isTheSameLine :: SrcSpan -> SrcSpan -> Bool -isTheSameLine s1 s2 - | Just sl1 <- getStartLine s1, - Just sl2 <- getStartLine s2 = - sl1 == sl2 - | otherwise = False - where - getStartLine x = srcLocLine . realSrcSpanStart <$> realSpan x - -isUnusedImportedId :: TcModuleResult -> HieAstResult -> String -> String -> SrcSpan -> Bool -isUnusedImportedId - TcModuleResult {tmrTypechecked = TcGblEnv {tcg_imports = ImportAvails {imp_mods}}} - HAR {refMap} - identifier - modName - importSpan - | occ <- mkVarOcc identifier, - impModsVals <- importedByUser . concat $ moduleEnvElts imp_mods, - Just rdrEnv <- - listToMaybe - [ imv_all_exports - | ImportedModsVal {..} <- impModsVals, - imv_name == mkModuleName modName, - isTheSameLine imv_span importSpan - ], - [GRE {..}] <- lookupGlobalRdrEnv rdrEnv occ, - importedIdentifier <- Right gre_name, - refs <- M.lookup importedIdentifier refMap = - maybe True (not . any (\(_, IdentifierDetails {..}) -> identInfo == S.singleton Use)) refs - | otherwise = False - -suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..} --- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant - | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant" - , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == Just _range ) hsmodImports - , Just c <- contents - , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings) - , ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges) - , not (null ranges') - = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )] - --- File.hs:16:1: warning: --- The import of `Data.List' is redundant --- except perhaps to import instances from `Data.List' --- To import instances alone, use: import Data.List() - | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String) - = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])] - | otherwise = [] - -caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] -caRemoveRedundantImports m contents digs ctxDigs uri - | Just pm <- m, - r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) digs, - allEdits <- [ e | (_, (_, edits)) <- r, e <- edits], - caRemoveAll <- removeAll allEdits, - ctxEdits <- [ x | x@(d, _) <- r, d `elem` ctxDigs], - not $ null ctxEdits, - caRemoveCtx <- map (\(d, (title, tedit)) -> removeSingle title tedit d) ctxEdits - = caRemoveCtx ++ [caRemoveAll] - | otherwise = [] - where - removeSingle title tedit diagnostic = mkCA title [diagnostic] WorkspaceEdit{..} where - _changes = Just $ Map.singleton uri $ List tedit - _documentChanges = Nothing - removeAll tedit = InR $ CodeAction{..} where - _changes = Just $ Map.singleton uri $ List tedit - _title = "Remove all redundant imports" - _kind = Just CodeActionQuickFix - _diagnostics = Nothing - _documentChanges = Nothing - _edit = Just WorkspaceEdit{..} - _isPreferred = Nothing - _command = Nothing - _disabled = Nothing - -caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] -caRemoveInvalidExports m contents digs ctxDigs uri - | Just pm <- m, - Just txt <- contents, - txt' <- indexedByPosition $ T.unpack txt, - r <- mapMaybe (groupDiag pm) digs, - r' <- map (\(t,d,rs) -> (t,d,extend txt' rs)) r, - caRemoveCtx <- mapMaybe removeSingle r', - allRanges <- nubOrd $ [ range | (_,_,ranges) <- r, range <- ranges], - allRanges' <- extend txt' allRanges, - Just caRemoveAll <- removeAll allRanges', - ctxEdits <- [ x | x@(_, d, _) <- r, d `elem` ctxDigs], - not $ null ctxEdits - = caRemoveCtx ++ [caRemoveAll] - | otherwise = [] - where - extend txt ranges = extendAllToIncludeCommaIfPossible True txt ranges - - groupDiag pm dig - | Just (title, ranges) <- suggestRemoveRedundantExport pm dig - = Just (title, dig, ranges) - | otherwise = Nothing - - removeSingle (_, _, []) = Nothing - removeSingle (title, diagnostic, ranges) = Just $ InR $ CodeAction{..} where - tedit = concatMap (\r -> [TextEdit r ""]) $ nubOrd ranges - _changes = Just $ Map.singleton uri $ List tedit - _title = title - _kind = Just CodeActionQuickFix - _diagnostics = Just $ List [diagnostic] - _documentChanges = Nothing - _edit = Just WorkspaceEdit{..} - _command = Nothing - _isPreferred = Nothing - _disabled = Nothing - removeAll [] = Nothing - removeAll ranges = Just $ InR $ CodeAction{..} where - tedit = concatMap (\r -> [TextEdit r ""]) ranges - _changes = Just $ Map.singleton uri $ List tedit - _title = "Remove all redundant exports" - _kind = Just CodeActionQuickFix - _diagnostics = Nothing - _documentChanges = Nothing - _edit = Just WorkspaceEdit{..} - _command = Nothing - _isPreferred = Nothing - _disabled = Nothing - -suggestRemoveRedundantExport :: ParsedModule -> Diagnostic -> Maybe (T.Text, [Range]) -suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} - | msg <- unifySpaces _message - , Just export <- hsmodExports - , Just exportRange <- getLocatedRange export - , exports <- unLoc export - , Just (removeFromExport, !ranges) <- fmap (getRanges exports . notInScope) (extractNotInScopeName msg) - <|> (,[_range]) <$> matchExportItem msg - <|> (,[_range]) <$> matchDupExport msg - , subRange _range exportRange - = Just ("Remove ‘" <> removeFromExport <> "’ from export", ranges) - where - matchExportItem msg = regexSingleMatch msg "The export item ‘([^’]+)’" - matchDupExport msg = regexSingleMatch msg "Duplicate ‘([^’]+)’ in export list" - getRanges exports txt = case smallerRangesForBindingExport exports (T.unpack txt) of - [] -> (txt, [_range]) - ranges -> (txt, ranges) -suggestRemoveRedundantExport _ _ = Nothing - -suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestDeleteUnusedBinding - ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} - contents - Diagnostic{_range=_range,..} --- Foo.hs:4:1: warning: [-Wunused-binds] Defined but not used: ‘f’ - | Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’" - , Just indexedContent <- indexedByPosition . T.unpack <$> contents - = let edits = flip TextEdit "" <$> relatedRanges indexedContent (T.unpack name) - in ([("Delete ‘" <> name <> "’", edits) | not (null edits)]) - | otherwise = [] - where - relatedRanges indexedContent name = - concatMap (findRelatedSpans indexedContent name) hsmodDecls - toRange = realSrcSpanToRange - extendForSpaces = extendToIncludePreviousNewlineIfPossible - - findRelatedSpans :: PositionIndexedString -> String -> Located (HsDecl GhcPs) -> [Range] - findRelatedSpans - indexedContent - name - (L (RealSrcSpan l) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) = - case lname of - (L nLoc _name) | isTheBinding nLoc -> - let findSig (L (RealSrcSpan l) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig - findSig _ = [] - in - extendForSpaces indexedContent (toRange l) : - concatMap findSig hsmodDecls - _ -> concatMap (findRelatedSpanForMatch indexedContent name) matches - findRelatedSpans _ _ _ = [] - - extractNameAndMatchesFromFunBind - :: HsBind GhcPs - -> Maybe (Located (IdP GhcPs), [LMatch GhcPs (LHsExpr GhcPs)]) - extractNameAndMatchesFromFunBind - FunBind - { fun_id=lname - , fun_matches=MG {mg_alts=L _ matches} - } = Just (lname, matches) - extractNameAndMatchesFromFunBind _ = Nothing - - findRelatedSigSpan :: PositionIndexedString -> String -> RealSrcSpan -> Sig GhcPs -> [Range] - findRelatedSigSpan indexedContent name l sig = - let maybeSpan = findRelatedSigSpan1 name sig - in case maybeSpan of - Just (_span, True) -> pure $ extendForSpaces indexedContent $ toRange l -- a :: Int - Just (RealSrcSpan span, False) -> pure $ toRange span -- a, b :: Int, a is unused - _ -> [] - - -- Second of the tuple means there is only one match - findRelatedSigSpan1 :: String -> Sig GhcPs -> Maybe (SrcSpan, Bool) - findRelatedSigSpan1 name (TypeSig _ lnames _) = - let maybeIdx = findIndex (\(L _ id) -> isSameName id name) lnames - in case maybeIdx of - Nothing -> Nothing - Just _ | length lnames == 1 -> Just (getLoc $ head lnames, True) - Just idx -> - let targetLname = getLoc $ lnames !! idx - startLoc = srcSpanStart targetLname - endLoc = srcSpanEnd targetLname - startLoc' = if idx == 0 - then startLoc - else srcSpanEnd . getLoc $ lnames !! (idx - 1) - endLoc' = if idx == 0 && idx < length lnames - 1 - then srcSpanStart . getLoc $ lnames !! (idx + 1) - else endLoc - in Just (mkSrcSpan startLoc' endLoc', False) - findRelatedSigSpan1 _ _ = Nothing - - -- for where clause - findRelatedSpanForMatch - :: PositionIndexedString - -> String - -> LMatch GhcPs (LHsExpr GhcPs) - -> [Range] - findRelatedSpanForMatch - indexedContent - name - (L _ Match{m_grhss=GRHSs{grhssLocalBinds}}) = do - case grhssLocalBinds of - (L _ (HsValBinds _ (ValBinds _ bag lsigs))) -> - if isEmptyBag bag - then [] - else concatMap (findRelatedSpanForHsBind indexedContent name lsigs) bag - _ -> [] - findRelatedSpanForMatch _ _ _ = [] - - findRelatedSpanForHsBind - :: PositionIndexedString - -> String - -> [LSig GhcPs] - -> LHsBind GhcPs - -> [Range] - findRelatedSpanForHsBind - indexedContent - name - lsigs - (L (RealSrcSpan l) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) = - if isTheBinding (getLoc lname) - then - let findSig (L (RealSrcSpan l) sig) = findRelatedSigSpan indexedContent name l sig - findSig _ = [] - in extendForSpaces indexedContent (toRange l) : concatMap findSig lsigs - else concatMap (findRelatedSpanForMatch indexedContent name) matches - findRelatedSpanForHsBind _ _ _ _ = [] - - isTheBinding :: SrcSpan -> Bool - isTheBinding span = srcSpanToRange span == Just _range - - isSameName :: IdP GhcPs -> String -> Bool - isSameName x name = showSDocUnsafe (ppr x) == name - -data ExportsAs = ExportName | ExportPattern | ExportAll - deriving (Eq) - -getLocatedRange :: Located a -> Maybe Range -getLocatedRange = srcSpanToRange . getLoc - -suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])] -suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} --- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’ --- Foo.hs:5:1: warning: [-Wunused-top-binds] Defined but not used: type constructor or class ‘F’ --- Foo.hs:6:1: warning: [-Wunused-top-binds] Defined but not used: data constructor ‘Bar’ - | Just source <- srcOpt - , Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’" - <|> matchRegexUnifySpaces _message ".*Defined but not used: type constructor or class ‘([^ ]+)’" - <|> matchRegexUnifySpaces _message ".*Defined but not used: data constructor ‘([^ ]+)’" - , Just (exportType, _) <- find (matchWithDiagnostic _range . snd) - . mapMaybe - (\(L l b) -> if maybe False isTopLevel $ srcSpanToRange l - then exportsAs b else Nothing) - $ hsmodDecls - , Just pos <- fmap _end . getLocatedRange =<< hsmodExports - , Just needComma <- needsComma source <$> hsmodExports - , let exportName = (if needComma then "," else "") <> printExport exportType name - insertPos = pos {_character = pred $ _character pos} - = [("Export ‘" <> name <> "’", [TextEdit (Range insertPos insertPos) exportName])] - | otherwise = [] - where - -- we get the last export and the closing bracket and check for comma in that range - needsComma :: T.Text -> Located [LIE GhcPs] -> Bool - needsComma _ (L _ []) = False - needsComma source (L (RealSrcSpan l) exports) = - let closeParan = _end $ realSrcSpanToRange l - lastExport = fmap _end . getLocatedRange $ last exports - in case lastExport of - Just lastExport -> not $ T.isInfixOf "," $ textInRange (Range lastExport closeParan) source - _ -> False - needsComma _ _ = False - - opLetter :: String - opLetter = ":!#$%&*+./<=>?@\\^|-~" - - parenthesizeIfNeeds :: Bool -> T.Text -> T.Text - parenthesizeIfNeeds needsTypeKeyword x - | T.head x `elem` opLetter = (if needsTypeKeyword then "type " else "") <> "(" <> x <>")" - | otherwise = x - - matchWithDiagnostic :: Range -> Located (IdP GhcPs) -> Bool - matchWithDiagnostic Range{_start=l,_end=r} x = - let loc = fmap _start . getLocatedRange $ x - in loc >= Just l && loc <= Just r - - printExport :: ExportsAs -> T.Text -> T.Text - printExport ExportName x = parenthesizeIfNeeds False x - printExport ExportPattern x = "pattern " <> x - printExport ExportAll x = parenthesizeIfNeeds True x <> "(..)" - - isTopLevel :: Range -> Bool - isTopLevel l = (_character . _start) l == 0 - - exportsAs :: HsDecl p -> Maybe (ExportsAs, Located (IdP p)) - exportsAs (ValD _ FunBind {fun_id}) = Just (ExportName, fun_id) - exportsAs (ValD _ (PatSynBind _ PSB {psb_id})) = Just (ExportPattern, psb_id) - exportsAs (TyClD _ SynDecl{tcdLName}) = Just (ExportName, tcdLName) - exportsAs (TyClD _ DataDecl{tcdLName}) = Just (ExportAll, tcdLName) - exportsAs (TyClD _ ClassDecl{tcdLName}) = Just (ExportAll, tcdLName) - exportsAs (TyClD _ FamDecl{tcdFam}) = Just (ExportAll, fdLName tcdFam) - exportsAs _ = Nothing - -suggestAddTypeAnnotationToSatisfyContraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestAddTypeAnnotationToSatisfyContraints sourceOpt Diagnostic{_range=_range,..} --- File.hs:52:41: warning: --- * Defaulting the following constraint to type ‘Integer’ --- Num p0 arising from the literal ‘1’ --- * In the expression: 1 --- In an equation for ‘f’: f = 1 --- File.hs:52:41: warning: --- * Defaulting the following constraints to type ‘[Char]’ --- (Show a0) --- arising from a use of ‘traceShow’ --- at A.hs:228:7-25 --- (IsString a0) --- arising from the literal ‘"debug"’ --- at A.hs:228:17-23 --- * In the expression: traceShow "debug" a --- In an equation for ‘f’: f a = traceShow "debug" a --- File.hs:52:41: warning: --- * Defaulting the following constraints to type ‘[Char]’ --- (Show a0) --- arising from a use of ‘traceShow’ --- at A.hs:255:28-43 --- (IsString a0) --- arising from the literal ‘"test"’ --- at /Users/serhiip/workspace/ghcide/src/Development/IDE/Plugin/CodeAction.hs:255:38-43 --- * In the fourth argument of ‘seq’, namely ‘(traceShow "test")’ --- In the expression: seq "test" seq "test" (traceShow "test") --- In an equation for ‘f’: --- f = seq "test" seq "test" (traceShow "test") - | Just [ty, lit] <- matchRegexUnifySpaces _message (pat False False True False) - <|> matchRegexUnifySpaces _message (pat False False False True) - <|> matchRegexUnifySpaces _message (pat False False False False) - = codeEdit ty lit (makeAnnotatedLit ty lit) - | Just source <- sourceOpt - , Just [ty, lit] <- matchRegexUnifySpaces _message (pat True True False False) - = let lit' = makeAnnotatedLit ty lit; - tir = textInRange _range source - in codeEdit ty lit (T.replace lit lit' tir) - | otherwise = [] - where - makeAnnotatedLit ty lit = "(" <> lit <> " :: " <> ty <> ")" - pat multiple at inArg inExpr = T.concat [ ".*Defaulting the following constraint" - , if multiple then "s" else "" - , " to type ‘([^ ]+)’ " - , ".*arising from the literal ‘(.+)’" - , if inArg then ".+In the.+argument" else "" - , if at then ".+at" else "" - , if inExpr then ".+In the expression" else "" - , ".+In the expression" - ] - codeEdit ty lit replacement = - let title = "Add type annotation ‘" <> ty <> "’ to ‘" <> lit <> "’" - edits = [TextEdit _range replacement] - in [( title, edits )] - - -suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestReplaceIdentifier contents Diagnostic{_range=_range,..} --- File.hs:52:41: error: --- * Variable not in scope: --- suggestAcion :: Maybe T.Text -> Range -> Range --- * Perhaps you meant ‘suggestAction’ (line 83) --- File.hs:94:37: error: --- Not in scope: ‘T.isPrfixOf’ --- Perhaps you meant one of these: --- ‘T.isPrefixOf’ (imported from Data.Text), --- ‘T.isInfixOf’ (imported from Data.Text), --- ‘T.isSuffixOf’ (imported from Data.Text) --- Module ‘Data.Text’ does not export ‘isPrfixOf’. - | renameSuggestions@(_:_) <- extractRenamableTerms _message - = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ] - | otherwise = [] - -suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestNewDefinition ideOptions parsedModule contents Diagnostic{_message, _range} --- * Variable not in scope: --- suggestAcion :: Maybe T.Text -> Range -> Range - | Just [name, typ] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)" - = newDefinitionAction ideOptions parsedModule _range name typ - | Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps" - , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ - = [(label, mkRenameEdit contents _range name : newDefinitionEdits)] - | otherwise = [] - where - message = unifySpaces _message - -newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text -> [(T.Text, [TextEdit])] -newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ - | Range _ lastLineP : _ <- - [ realSrcSpanToRange sp - | (L l@(RealSrcSpan sp) _) <- hsmodDecls - , _start `isInsideSrcSpan` l] - , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0} - = [ ("Define " <> sig - , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = error \"not implemented\""])] - )] - | otherwise = [] - where - colon = if optNewColonConvention then " : " else " :: " - sig = name <> colon <> T.dropWhileEnd isSpace typ - ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule - - -suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])] -suggestFillTypeWildcard Diagnostic{_range=_range,..} --- Foo.hs:3:8: error: --- * Found type wildcard `_' standing for `p -> p1 -> p' - - | "Found type wildcard" `T.isInfixOf` _message - , " standing for " `T.isInfixOf` _message - , typeSignature <- extractWildCardTypeSignature _message - = [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])] - | otherwise = [] - -suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])] -suggestModuleTypo Diagnostic{_range=_range,..} --- src/Development/IDE/Core/Compile.hs:58:1: error: --- Could not find module ‘Data.Cha’ --- Perhaps you meant Data.Char (from base-4.12.0.0) - | "Could not find module" `T.isInfixOf` _message - , "Perhaps you meant" `T.isInfixOf` _message = let - findSuggestedModules = map (head . T.words) . drop 2 . T.lines - proposeModule mod = ("replace with " <> mod, [TextEdit _range mod]) - in map proposeModule $ nubOrd $ findSuggestedModules _message - | otherwise = [] - -suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])] -suggestFillHole Diagnostic{_range=_range,..} - | Just holeName <- extractHoleName _message - , (holeFits, refFits) <- processHoleSuggestions (T.lines _message) - = map (proposeHoleFit holeName False) holeFits - ++ map (proposeHoleFit holeName True) refFits - | otherwise = [] - where - extractHoleName = fmap head . flip matchRegexUnifySpaces "Found hole: ([^ ]*)" - proposeHoleFit holeName parenthise name = - ( "replace " <> holeName <> " with " <> name - , [TextEdit _range $ if parenthise then parens name else name]) - parens x = "(" <> x <> ")" - -processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text]) -processHoleSuggestions mm = (holeSuggestions, refSuggestions) -{- - • Found hole: _ :: LSP.Handlers - - Valid hole fits include def - Valid refinement hole fits include - fromMaybe (_ :: LSP.Handlers) (_ :: Maybe LSP.Handlers) - fromJust (_ :: Maybe LSP.Handlers) - haskell-lsp-types-0.22.0.0:Language.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams - LSP.Handlers) - T.foldl (_ :: LSP.Handlers -> Char -> LSP.Handlers) - (_ :: LSP.Handlers) - (_ :: T.Text) - T.foldl' (_ :: LSP.Handlers -> Char -> LSP.Handlers) - (_ :: LSP.Handlers) - (_ :: T.Text) --} - where - t = id @T.Text - holeSuggestions = do - -- get the text indented under Valid hole fits - validHolesSection <- - getIndentedGroupsBy (=~ t " *Valid (hole fits|substitutions) include") mm - -- the Valid hole fits line can contain a hole fit - holeFitLine <- - mapHead - (mrAfter . (=~ t " *Valid (hole fits|substitutions) include")) - validHolesSection - let holeFit = T.strip $ T.takeWhile (/= ':') holeFitLine - guard (not $ T.null holeFit) - return holeFit - refSuggestions = do -- @[] - -- get the text indented under Valid refinement hole fits - refinementSection <- - getIndentedGroupsBy (=~ t " *Valid refinement hole fits include") mm - -- get the text for each hole fit - holeFitLines <- getIndentedGroups (tail refinementSection) - let holeFit = T.strip $ T.unwords holeFitLines - guard $ not $ holeFit =~ t "Some refinement hole fits suppressed" - return holeFit - - mapHead f (a:aa) = f a : aa - mapHead _ [] = [] - --- > getIndentedGroups [" H1", " l1", " l2", " H2", " l3"] = [[" H1,", " l1", " l2"], [" H2", " l3"]] -getIndentedGroups :: [T.Text] -> [[T.Text]] -getIndentedGroups [] = [] -getIndentedGroups ll@(l:_) = getIndentedGroupsBy ((== indentation l) . indentation) ll --- | --- > getIndentedGroupsBy (" H" `isPrefixOf`) [" H1", " l1", " l2", " H2", " l3"] = [[" H1", " l1", " l2"], [" H2", " l3"]] -getIndentedGroupsBy :: (T.Text -> Bool) -> [T.Text] -> [[T.Text]] -getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of - (l:ll) -> case span (\l' -> indentation l < indentation l') ll of - (indented, rest) -> (l:indented) : getIndentedGroupsBy pred rest - _ -> [] - -indentation :: T.Text -> Int -indentation = T.length . T.takeWhile isSpace - -suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, [Rewrite])] -suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_range,..} - | Just [binding, mod, srcspan] <- - matchRegexUnifySpaces _message - "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$" - = suggestions hsmodImports binding mod srcspan - | Just (binding, mod_srcspan) <- - matchRegExMultipleImports _message - = mod_srcspan >>= uncurry (suggestions hsmodImports binding) - | otherwise = [] - where - unImportStyle (ImportTopLevel x) = (Nothing, T.unpack x) - unImportStyle (ImportViaParent x y) = (Just $ T.unpack y, T.unpack x) - suggestions decls binding mod srcspan - | range <- case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of - [s] -> let x = realSrcSpanToRange s - in x{_end = (_end x){_character = succ (_character (_end x))}} - _ -> error "bug in srcspan parser", - Just decl <- findImportDeclByRange decls range, - Just ident <- lookupExportMap binding mod - = [ ( "Add " <> renderImportStyle importStyle <> " to the import list of " <> mod - , [uncurry extendImport (unImportStyle importStyle) decl] - ) - | importStyle <- NE.toList $ importStyles ident - ] - | otherwise = [] - lookupExportMap binding mod - | Just match <- Map.lookup binding (getExportsMap exportsMap) - , [ident] <- filter (\ident -> moduleNameText ident == mod) (Set.toList match) - = Just ident - - -- fallback to using GHC suggestion even though it is not always correct - | otherwise - = Just IdentInfo - { name = binding - , rendered = binding - , parent = Nothing - , isDatacon = False - , moduleNameText = mod} - -data HidingMode - = HideOthers [ModuleTarget] - | ToQualified - Bool - -- ^ Parenthesised? - ModuleName - deriving (Show) - -data ModuleTarget - = ExistingImp (NonEmpty (LImportDecl GhcPs)) - | ImplicitPrelude [LImportDecl GhcPs] - deriving (Show) - -targetImports :: ModuleTarget -> [LImportDecl GhcPs] -targetImports (ExistingImp ne) = NE.toList ne -targetImports (ImplicitPrelude xs) = xs - -oneAndOthers :: [a] -> [(a, [a])] -oneAndOthers = go - where - go [] = [] - go (x : xs) = (x, xs) : map (second (x :)) (go xs) - -isPreludeImplicit :: DynFlags -> Bool -isPreludeImplicit = xopt Lang.ImplicitPrelude - --- | Suggests disambiguation for ambiguous symbols. -suggestImportDisambiguation :: - DynFlags -> - Maybe T.Text -> - ParsedSource -> - Diagnostic -> - [(T.Text, [Rewrite])] -suggestImportDisambiguation df (Just txt) ps@(L _ HsModule {hsmodImports}) diag@Diagnostic {..} - | Just [ambiguous] <- - matchRegexUnifySpaces - _message - "Ambiguous occurrence ‘([^’]+)’" - , Just modules <- - map last - <$> allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’" = - suggestions ambiguous modules - | otherwise = [] - where - locDic = - fmap (NE.fromList . DL.toList) $ - Map.fromListWith (<>) $ - map - ( \i@(L _ idecl) -> - ( T.pack $ moduleNameString $ unLoc $ ideclName idecl - , DL.singleton i - ) - ) - hsmodImports - toModuleTarget "Prelude" - | isPreludeImplicit df - = Just $ ImplicitPrelude $ - maybe [] NE.toList (Map.lookup "Prelude" locDic) - toModuleTarget mName = ExistingImp <$> Map.lookup mName locDic - parensed = - "(" `T.isPrefixOf` T.strip (textInRange _range txt) - suggestions symbol mods - | Just targets <- mapM toModuleTarget mods = - sortOn fst - [ ( renderUniquify mode modNameText symbol - , disambiguateSymbol ps diag symbol mode - ) - | (modTarget, restImports) <- oneAndOthers targets - , let modName = targetModuleName modTarget - modNameText = T.pack $ moduleNameString modName - , mode <- - HideOthers restImports : - [ ToQualified parensed qual - | ExistingImp imps <- [modTarget] - , L _ qual <- nubOrd $ mapMaybe (ideclAs . unLoc) - $ NE.toList imps - ] - ++ [ToQualified parensed modName - | any (occursUnqualified symbol . unLoc) - (targetImports modTarget) - || case modTarget of - ImplicitPrelude{} -> True - _ -> False - ] - ] - | otherwise = [] - renderUniquify HideOthers {} modName symbol = - "Use " <> modName <> " for " <> symbol <> ", hiding other imports" - renderUniquify (ToQualified _ qual) _ symbol = - "Replace with qualified: " - <> T.pack (moduleNameString qual) - <> "." - <> symbol -suggestImportDisambiguation _ _ _ _ = [] - -occursUnqualified :: T.Text -> ImportDecl GhcPs -> Bool -occursUnqualified symbol ImportDecl{..} - | isNothing ideclAs = Just False /= - -- I don't find this particularly comprehensible, - -- but HLint suggested me to do so... - (ideclHiding <&> \(isHiding, L _ ents) -> - let occurs = any ((symbol `symbolOccursIn`) . unLoc) ents - in isHiding && not occurs || not isHiding && occurs - ) -occursUnqualified _ _ = False - -symbolOccursIn :: T.Text -> IE GhcPs -> Bool -symbolOccursIn symb = any ((== symb). showNameWithoutUniques) . ieNames - -targetModuleName :: ModuleTarget -> ModuleName -targetModuleName ImplicitPrelude{} = mkModuleName "Prelude" -targetModuleName (ExistingImp (L _ ImportDecl{..} :| _)) = - unLoc ideclName -targetModuleName (ExistingImp _) = - error "Cannot happen!" - -disambiguateSymbol :: - ParsedSource -> - Diagnostic -> - T.Text -> - HidingMode -> - [Rewrite] -disambiguateSymbol pm Diagnostic {..} (T.unpack -> symbol) = \case - (HideOthers hiddens0) -> - [ hideSymbol symbol idecl - | ExistingImp idecls <- hiddens0 - , idecl <- NE.toList idecls - ] - ++ mconcat - [ if null imps - then maybeToList $ hideImplicitPreludeSymbol symbol pm - else hideSymbol symbol <$> imps - | ImplicitPrelude imps <- hiddens0 - ] - (ToQualified parensed qualMod) -> - let occSym = mkVarOcc symbol - rdr = Qual qualMod occSym - in [ if parensed - then Rewrite (rangeToSrcSpan "" _range) $ \df -> - liftParseAST @(HsExpr GhcPs) df $ - prettyPrint $ - HsVar @GhcPs noExtField $ - L (UnhelpfulSpan "") rdr - else Rewrite (rangeToSrcSpan "" _range) $ \df -> - liftParseAST @RdrName df $ - prettyPrint $ L (UnhelpfulSpan "") rdr - ] - -findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs) -findImportDeclByRange xs range = find (\(L l _)-> srcSpanToRange l == Just range) xs - -suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestFixConstructorImport _ Diagnostic{_range=_range,..} - -- ‘Success’ is a data constructor of ‘Result’ - -- To import it use - -- import Data.Aeson.Types( Result( Success ) ) - -- or - -- import Data.Aeson.Types( Result(..) ) (lsp-ui) - | Just [constructor, typ] <- - matchRegexUnifySpaces _message - "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use" - = let fixedImport = typ <> "(" <> constructor <> ")" - in [("Fix import of " <> fixedImport, [TextEdit _range fixedImport])] - | otherwise = [] --- | Suggests a constraint for a declaration for which a constraint is missing. -suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, [Rewrite])] -suggestConstraint df parsedModule diag@Diagnostic {..} - | Just missingConstraint <- findMissingConstraint _message - = let codeAction = if _message =~ ("the type signature for:" :: String) - then suggestFunctionConstraint df parsedModule - else suggestInstanceConstraint df parsedModule - in map (second (:[])) $ codeAction diag missingConstraint - | otherwise = [] - where - findMissingConstraint :: T.Text -> Maybe T.Text - findMissingConstraint t = - let regex = "(No instance for|Could not deduce) \\((.+)\\) arising from" -- a use of / a do statement - regexImplicitParams = "Could not deduce: (\\?.+) arising from a use of" - match = matchRegexUnifySpaces t regex - matchImplicitParams = matchRegexUnifySpaces t regexImplicitParams - in match <|> matchImplicitParams <&> last - --- | Suggests a constraint for an instance declaration for which a constraint is missing. -suggestInstanceConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] - -suggestInstanceConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint - | Just instHead <- instanceHead - = [(actionTitle missingConstraint , appendConstraint (T.unpack missingConstraint) instHead)] - | otherwise = [] - where - instanceHead - -- Suggests a constraint for an instance declaration with no existing constraints. - -- • No instance for (Eq a) arising from a use of ‘==’ - -- Possible fix: add (Eq a) to the context of the instance declaration - -- • In the expression: x == y - -- In an equation for ‘==’: (Wrap x) == (Wrap y) = x == y - -- In the instance declaration for ‘Eq (Wrap a)’ - | Just [instanceDeclaration] <- matchRegexUnifySpaces _message "In the instance declaration for ‘([^`]*)’" - , Just instHead <- findInstanceHead df (T.unpack instanceDeclaration) hsmodDecls - = Just instHead - -- Suggests a constraint for an instance declaration with one or more existing constraints. - -- • Could not deduce (Eq b) arising from a use of ‘==’ - -- from the context: Eq a - -- bound by the instance declaration at /path/to/Main.hs:7:10-32 - -- Possible fix: add (Eq b) to the context of the instance declaration - -- • In the second argument of ‘(&&)’, namely ‘x' == y'’ - -- In the expression: x == y && x' == y' - -- In an equation for ‘==’: - -- (Pair x x') == (Pair y y') = x == y && x' == y' - | Just [instanceLineStr, constraintFirstCharStr] - <- matchRegexUnifySpaces _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)" - , Just (L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = HsIB{hsib_body}}))) - <- findDeclContainingLoc (Position (readPositionNumber instanceLineStr) (readPositionNumber constraintFirstCharStr)) hsmodDecls - = Just hsib_body - | otherwise - = Nothing - - readPositionNumber :: T.Text -> Int - readPositionNumber = T.unpack >>> read - - actionTitle :: T.Text -> T.Text - actionTitle constraint = "Add `" <> constraint - <> "` to the context of the instance declaration" - -suggestImplicitParameter :: - ParsedSource -> - Diagnostic -> - [(T.Text, [Rewrite])] -suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _range} - | Just [implicitT] <- matchRegexUnifySpaces _message "Unbound implicit parameter \\(([^:]+::.+)\\) arising", - Just (L _ (ValD _ FunBind {fun_id = L _ funId})) <- findDeclContainingLoc (_start _range) hsmodDecls, - Just (TypeSig _ _ HsWC {hswc_body = HsIB {hsib_body}}) <- findSigOfDecl (== funId) hsmodDecls - = - [( "Add " <> implicitT <> " to the context of " <> T.pack (printRdrName funId) - , [appendConstraint (T.unpack implicitT) hsib_body])] - | otherwise = [] - -findTypeSignatureName :: T.Text -> Maybe T.Text -findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head - -findTypeSignatureLine :: T.Text -> T.Text -> Int -findTypeSignatureLine contents typeSignatureName = - T.splitOn (typeSignatureName <> " :: ") contents & head & T.lines & length - --- | Suggests a constraint for a type signature with any number of existing constraints. -suggestFunctionConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] - -suggestFunctionConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint --- • No instance for (Eq a) arising from a use of ‘==’ --- Possible fix: --- add (Eq a) to the context of --- the type signature for: --- eq :: forall a. a -> a -> Bool --- • In the expression: x == y --- In an equation for ‘eq’: eq x y = x == y - --- • Could not deduce (Eq b) arising from a use of ‘==’ --- from the context: Eq a --- bound by the type signature for: --- eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool --- at Main.hs:5:1-42 --- Possible fix: --- add (Eq b) to the context of --- the type signature for: --- eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool --- • In the second argument of ‘(&&)’, namely ‘y == y'’ --- In the expression: x == x' && y == y' --- In an equation for ‘eq’: --- eq (Pair x y) (Pair x' y') = x == x' && y == y' - | Just typeSignatureName <- findTypeSignatureName _message - , Just (TypeSig _ _ HsWC{hswc_body = HsIB {hsib_body = sig}}) - <- findSigOfDecl ((T.unpack typeSignatureName ==) . showSDoc df . ppr) hsmodDecls - , title <- actionTitle missingConstraint typeSignatureName - = [(title, appendConstraint (T.unpack missingConstraint) sig)] - | otherwise - = [] - where - actionTitle :: T.Text -> T.Text -> T.Text - actionTitle constraint typeSignatureName = "Add `" <> constraint - <> "` to the context of the type signature for `" <> typeSignatureName <> "`" - --- | Suggests the removal of a redundant constraint for a type signature. -removeRedundantConstraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -removeRedundantConstraints mContents Diagnostic{..} --- • Redundant constraint: Eq a --- • In the type signature for: --- foo :: forall a. Eq a => a -> a --- • Redundant constraints: (Monoid a, Show a) --- • In the type signature for: --- foo :: forall a. (Num a, Monoid a, Eq a, Show a) => a -> Bool - | Just contents <- mContents - -- Account for both "Redundant constraint" and "Redundant constraints". - , True <- "Redundant constraint" `T.isInfixOf` _message - , Just typeSignatureName <- findTypeSignatureName _message - , Just redundantConstraintList <- findRedundantConstraints _message - , Just constraints <- findConstraints contents typeSignatureName - = let constraintList = parseConstraints constraints - newConstraints = buildNewConstraints constraintList redundantConstraintList - typeSignatureLine = findTypeSignatureLine contents typeSignatureName - typeSignatureFirstChar = T.length $ typeSignatureName <> " :: " - startOfConstraint = Position typeSignatureLine typeSignatureFirstChar - endOfConstraint = Position typeSignatureLine $ - typeSignatureFirstChar + T.length (constraints <> " => ") - range = Range startOfConstraint endOfConstraint - in [(actionTitle redundantConstraintList typeSignatureName, [TextEdit range newConstraints])] - | otherwise = [] - where - parseConstraints :: T.Text -> [T.Text] - parseConstraints t = t - & (T.strip >>> stripConstraintsParens >>> T.splitOn ",") - <&> T.strip - - stripConstraintsParens :: T.Text -> T.Text - stripConstraintsParens constraints = - if "(" `T.isPrefixOf` constraints - then constraints & T.drop 1 & T.dropEnd 1 & T.strip - else constraints - - findRedundantConstraints :: T.Text -> Maybe [T.Text] - findRedundantConstraints t = t - & T.lines - & head - & T.strip - & (`matchRegexUnifySpaces` "Redundant constraints?: (.+)") - <&> (head >>> parseConstraints) - - -- If the type signature is not formatted as expected (arbitrary number of spaces, - -- line feeds...), just fail. - findConstraints :: T.Text -> T.Text -> Maybe T.Text - findConstraints contents typeSignatureName = do - constraints <- contents - & T.splitOn (typeSignatureName <> " :: ") - & (`atMay` 1) - >>= (T.splitOn " => " >>> (`atMay` 0)) - guard $ not $ "\n" `T.isInfixOf` constraints || T.strip constraints /= constraints - return constraints - - formatConstraints :: [T.Text] -> T.Text - formatConstraints [] = "" - formatConstraints [constraint] = constraint - formatConstraints constraintList = constraintList - & T.intercalate ", " - & \cs -> "(" <> cs <> ")" - - formatConstraintsWithArrow :: [T.Text] -> T.Text - formatConstraintsWithArrow [] = "" - formatConstraintsWithArrow cs = cs & formatConstraints & (<> " => ") - - buildNewConstraints :: [T.Text] -> [T.Text] -> T.Text - buildNewConstraints constraintList redundantConstraintList = - formatConstraintsWithArrow $ constraintList \\ redundantConstraintList - - actionTitle :: [T.Text] -> T.Text -> T.Text - actionTitle constraintList typeSignatureName = - "Remove redundant constraint" <> (if length constraintList == 1 then "" else "s") <> " `" - <> formatConstraints constraintList - <> "` from the context of the type signature for `" <> typeSignatureName <> "`" - -------------------------------------------------------------------------------------------------- - -suggestNewImport :: ExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])] -suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule {..}} Diagnostic{_message} - | msg <- unifySpaces _message - , Just thingMissing <- extractNotInScopeName msg - , qual <- extractQualifiedModuleName msg - , Just insertLine <- case hsmodImports of - [] -> case srcSpanStart $ getLoc (head hsmodDecls) of - RealSrcLoc s -> Just $ srcLocLine s - 1 - _ -> Nothing - _ -> case srcSpanEnd $ getLoc (last hsmodImports) of - RealSrcLoc s -> Just $ srcLocLine s - _ -> Nothing - , insertPos <- Position insertLine 0 - , extendImportSuggestions <- matchRegexUnifySpaces msg - "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’" - = [(imp, [TextEdit (Range insertPos insertPos) (imp <> "\n")]) - | imp <- sort $ constructNewImportSuggestions packageExportsMap (qual, thingMissing) extendImportSuggestions - ] -suggestNewImport _ _ _ = [] - -constructNewImportSuggestions - :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> [T.Text] -constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules = nubOrd - [ suggestion - | Just name <- [T.stripPrefix (maybe "" (<> ".") qual) $ notInScope thingMissing] - , identInfo <- maybe [] Set.toList $ Map.lookup name (getExportsMap exportsMap) - , canUseIdent thingMissing identInfo - , moduleNameText identInfo `notElem` fromMaybe [] notTheseModules - , suggestion <- renderNewImport identInfo - ] - where - renderNewImport :: IdentInfo -> [T.Text] - renderNewImport identInfo - | Just q <- qual - , asQ <- if q == m then "" else " as " <> q - = ["import qualified " <> m <> asQ] - | otherwise - = ["import " <> m <> " (" <> renderImportStyle importStyle <> ")" - | importStyle <- NE.toList $ importStyles identInfo] ++ - ["import " <> m ] - where - m = moduleNameText identInfo - -canUseIdent :: NotInScope -> IdentInfo -> Bool -canUseIdent NotInScopeDataConstructor{} = isDatacon -canUseIdent _ = const True - -data NotInScope - = NotInScopeDataConstructor T.Text - | NotInScopeTypeConstructorOrClass T.Text - | NotInScopeThing T.Text - deriving Show - -notInScope :: NotInScope -> T.Text -notInScope (NotInScopeDataConstructor t) = t -notInScope (NotInScopeTypeConstructorOrClass t) = t -notInScope (NotInScopeThing t) = t - -extractNotInScopeName :: T.Text -> Maybe NotInScope -extractNotInScopeName x - | Just [name] <- matchRegexUnifySpaces x "Data constructor not in scope: ([^ ]+)" - = Just $ NotInScopeDataConstructor name - | Just [name] <- matchRegexUnifySpaces x "Not in scope: data constructor [^‘]*‘([^’]*)’" - = Just $ NotInScopeDataConstructor name - | Just [name] <- matchRegexUnifySpaces x "ot in scope: type constructor or class [^‘]*‘([^’]*)’" - = Just $ NotInScopeTypeConstructorOrClass name - | Just [name] <- matchRegexUnifySpaces x "ot in scope: \\(([^‘ ]+)\\)" - = Just $ NotInScopeThing name - | Just [name] <- matchRegexUnifySpaces x "ot in scope: ([^‘ ]+)" - = Just $ NotInScopeThing name - | Just [name] <- matchRegexUnifySpaces x "ot in scope:[^‘]*‘([^’]*)’" - = Just $ NotInScopeThing name - | otherwise - = Nothing - -extractQualifiedModuleName :: T.Text -> Maybe T.Text -extractQualifiedModuleName x - | Just [m] <- matchRegexUnifySpaces x "module named [^‘]*‘([^’]*)’" - = Just m - | otherwise - = Nothing - -------------------------------------------------------------------------------------------------- - - -mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit -mkRenameEdit contents range name = - if maybeIsInfixFunction == Just True - then TextEdit range ("`" <> name <> "`") - else TextEdit range name - where - maybeIsInfixFunction = do - curr <- textInRange range <$> contents - pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr - -extractWildCardTypeSignature :: T.Text -> T.Text -extractWildCardTypeSignature = - -- inferring when parens are actually needed around the type signature would - -- require understanding both the precedence of the context of the _ and of - -- the signature itself. Inserting them unconditionally is ugly but safe. - ("(" `T.append`) . (`T.append` ")") . - T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') . - snd . T.breakOnEnd "standing for " - -extractRenamableTerms :: T.Text -> [T.Text] -extractRenamableTerms msg - -- Account for both "Variable not in scope" and "Not in scope" - | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg - | otherwise = [] - where - extractSuggestions = map getEnclosed - . concatMap singleSuggestions - . filter isKnownSymbol - . T.lines - singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited - isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t - getEnclosed = T.dropWhile (== '‘') - . T.dropWhileEnd (== '’') - . T.dropAround (\c -> c /= '‘' && c /= '’') - --- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace --- between the end of the range and the next newline), extend the range to take up the whole line. -extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range -extendToWholeLineIfPossible contents range@Range{..} = - let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents - extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line - in if extend then Range _start (Position (_line _end + 1) 0) else range - -splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text) -splitTextAtPosition (Position row col) x - | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x - , (preCol, postCol) <- T.splitAt col mid - = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow) - | otherwise = (x, T.empty) - --- | Returns [start .. end[ -textInRange :: Range -> T.Text -> T.Text -textInRange (Range (Position startRow startCol) (Position endRow endCol)) text = - case compare startRow endRow of - LT -> - let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine - (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of - [] -> ("", []) - firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween) - maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines - in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine) - EQ -> - let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine) - in T.take (endCol - startCol) (T.drop startCol line) - GT -> "" - where - linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text) - --- | Returns the ranges for a binding in an import declaration -rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range] -rangesForBindingImport ImportDecl{ideclHiding = Just (False, L _ lies)} b = - concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies - where - b' = modifyBinding b -rangesForBindingImport _ _ = [] - -modifyBinding :: String -> String -modifyBinding = wrapOperatorInParens . unqualify - where - wrapOperatorInParens x = if isAlpha (head x) then x else "(" <> x <> ")" - unqualify x = snd $ breakOnEnd "." x - -smallerRangesForBindingExport :: [LIE GhcPs] -> String -> [Range] -smallerRangesForBindingExport lies b = - concatMap (mapMaybe srcSpanToRange . ranges') lies - where - b' = modifyBinding b - ranges' (L _ (IEThingWith _ thing _ inners labels)) - | showSDocUnsafe (ppr thing) == b' = [] - | otherwise = - [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b'] ++ - [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b'] - ranges' _ = [] - -rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan] -rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l] -rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l] -rangesForBinding' b (L l (IEThingAll _ x)) | showSDocUnsafe (ppr x) == b = [l] -rangesForBinding' b (L l (IEThingWith _ thing _ inners labels)) - | showSDocUnsafe (ppr thing) == b = [l] - | otherwise = - [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b] ++ - [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b] -rangesForBinding' _ _ = [] - --- | 'matchRegex' combined with 'unifySpaces' -matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text] -matchRegexUnifySpaces message = matchRegex (unifySpaces message) - --- | 'allMatchRegex' combined with 'unifySpaces' -allMatchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [[T.Text]] -allMatchRegexUnifySpaces message = - allMatchRegex (unifySpaces message) - --- | Returns Just (the submatches) for the first capture, or Nothing. -matchRegex :: T.Text -> T.Text -> Maybe [T.Text] -matchRegex message regex = case message =~~ regex of - Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings - Nothing -> Nothing - --- | Returns Just (all matches) for the first capture, or Nothing. -allMatchRegex :: T.Text -> T.Text -> Maybe [[T.Text]] -allMatchRegex message regex = message =~~ regex - - -unifySpaces :: T.Text -> T.Text -unifySpaces = T.unwords . T.words - --- functions to help parse multiple import suggestions - --- | Returns the first match if found -regexSingleMatch :: T.Text -> T.Text -> Maybe T.Text -regexSingleMatch msg regex = case matchRegexUnifySpaces msg regex of - Just (h:_) -> Just h - _ -> Nothing - --- | Parses tuples like (‘Data.Map’, (app/ModuleB.hs:2:1-18)) and --- | return (Data.Map, app/ModuleB.hs:2:1-18) -regExPair :: (T.Text, T.Text) -> Maybe (T.Text, T.Text) -regExPair (modname, srcpair) = do - x <- regexSingleMatch modname "‘([^’]*)’" - y <- regexSingleMatch srcpair "\\((.*)\\)" - return (x, y) - --- | Process a list of (module_name, filename:src_span) values --- | Eg. [(Data.Map, app/ModuleB.hs:2:1-18), (Data.HashMap.Strict, app/ModuleB.hs:3:1-29)] -regExImports :: T.Text -> Maybe [(T.Text, T.Text)] -regExImports msg = result - where - parts = T.words msg - isPrefix = not . T.isPrefixOf "(" - (mod, srcspan) = partition isPrefix parts - -- check we have matching pairs like (Data.Map, (app/src.hs:1:2-18)) - result = if length mod == length srcspan then - regExPair `traverse` zip mod srcspan - else Nothing - -matchRegExMultipleImports :: T.Text -> Maybe (T.Text, [(T.Text, T.Text)]) -matchRegExMultipleImports message = do - let pat = T.pack "Perhaps you want to add ‘([^’]*)’ to one of these import lists: *(‘.*\\))$" - (binding, imports) <- case matchRegexUnifySpaces message pat of - Just [x, xs] -> Just (x, xs) - _ -> Nothing - imps <- regExImports imports - return (binding, imps) - --- | Possible import styles for an 'IdentInfo'. --- --- The first 'Text' parameter corresponds to the 'rendered' field of the --- 'IdentInfo'. -data ImportStyle - = ImportTopLevel T.Text - -- ^ Import a top-level export from a module, e.g., a function, a type, a - -- class. - -- - -- > import M (?) - -- - -- Some exports that have a parent, like a type-class method or an - -- associated type/data family, can still be imported as a top-level - -- import. - -- - -- Note that this is not the case for constructors, they must always be - -- imported as part of their parent data type. - - | ImportViaParent T.Text T.Text - -- ^ Import an export (first parameter) through its parent (second - -- parameter). - -- - -- import M (P(?)) - -- - -- @P@ and @?@ can be a data type and a constructor, a class and a method, - -- a class and an associated type/data family, etc. - deriving Show - -importStyles :: IdentInfo -> NonEmpty ImportStyle -importStyles IdentInfo {parent, rendered, isDatacon} - | Just p <- parent - -- Constructors always have to be imported via their parent data type, but - -- methods and associated type/data families can also be imported as - -- top-level exports. - = ImportViaParent rendered p :| [ImportTopLevel rendered | not isDatacon] - | otherwise - = ImportTopLevel rendered :| [] - -renderImportStyle :: ImportStyle -> T.Text -renderImportStyle (ImportTopLevel x) = x -renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")" - +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +#include "ghc-api-version.h" + +-- | Go to the definition of a variable. + +module Development.IDE.Plugin.CodeAction + ( descriptor + + -- * For testing + , matchRegExMultipleImports + ) where + +import Bag (isEmptyBag) +import Control.Applicative ((<|>)) +import Control.Arrow (second, + (>>>)) +import Control.Concurrent.Extra (readVar) +import Control.Monad (guard, join) +import Control.Monad.IO.Class +import Data.Char +import qualified Data.DList as DL +import Data.Function +import Data.Functor +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set +import Data.List.Extra +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Rope.UTF16 as Rope +import qualified Data.Set as S +import qualified Data.Text as T +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Rules +import Development.IDE.Core.Service +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Error +import Development.IDE.GHC.ExactPrint +import Development.IDE.GHC.Util (prettyPrint, + printRdrName) +import Development.IDE.Plugin.CodeAction.Args +import Development.IDE.Plugin.CodeAction.ExactPrint +import Development.IDE.Plugin.CodeAction.PositionIndexed +import Development.IDE.Plugin.TypeLenses (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs), + suggestSignature) +import Development.IDE.Spans.Common +import Development.IDE.Types.Exports +import Development.IDE.Types.HscEnvEq +import Development.IDE.Types.Location +import Development.IDE.Types.Options +import qualified GHC.LanguageExtensions as Lang +import HscTypes (ImportedModsVal (..), + importedByUser) +import Ide.PluginUtils (subRange) +import Ide.Types +import qualified Language.LSP.Server as LSP +import Language.LSP.Types +import Language.LSP.VFS +import Module (moduleEnvElts) +import OccName +import Outputable (Outputable, + ppr, + showSDoc, + showSDocUnsafe) +import RdrName (GlobalRdrElt (..), + lookupGlobalRdrEnv) +import Safe (atMay) +import SrcLoc (realSrcSpanStart) +import TcRnTypes (ImportAvails (..), + TcGblEnv (..)) +import Text.Regex.TDFA (mrAfter, + (=~), (=~~)) + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = + (defaultPluginDescriptor plId) + { pluginRules = mempty, + pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction + } + +-- | Generate code actions. +codeAction + :: IdeState + -> PluginId + -> CodeActionParams + -> LSP.LspM c (Either ResponseError (List (Command |? CodeAction))) +codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs}) = do + contents <- LSP.getVirtualFile $ toNormalizedUri uri + liftIO $ do + let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents + mbFile = toNormalizedFilePath' <$> uriToFilePath uri + diag <- fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state + (ideOptions, join -> parsedModule, join -> env, join -> annotatedPS, join -> tcM, join -> har, join -> bindings, join -> gblSigs) <- runAction "CodeAction" state $ + (,,,,,,,) <$> getIdeOptions + <*> getParsedModule `traverse` mbFile + <*> use GhcSession `traverse` mbFile + <*> use GetAnnotatedParsedSource `traverse` mbFile + <*> use TypeCheck `traverse` mbFile + <*> use GetHieAst `traverse` mbFile + <*> use GetBindings `traverse` mbFile + <*> use GetGlobalBindingTypeSigs `traverse` mbFile + -- This is quite expensive 0.6-0.7s on GHC + pkgExports <- maybe mempty envPackageExports env + localExports <- readVar (exportsMap $ shakeExtras state) + let + exportsMap = localExports <> pkgExports + df = ms_hspp_opts . pm_mod_summary <$> parsedModule + actions = + [ mkCA title kind isPreferred [x] edit + | x <- xs, (title, kind, isPreferred, tedit) <- suggestAction $ CodeActionArgs exportsMap ideOptions parsedModule text df annotatedPS tcM har bindings gblSigs x + , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing + ] + actions' = caRemoveRedundantImports parsedModule text diag xs uri + <> actions + <> caRemoveInvalidExports parsedModule text diag xs uri + pure $ Right $ List actions' + +mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction) +mkCA title kind isPreferred diags edit = + InR $ CodeAction title kind (Just $ List diags) isPreferred Nothing (Just edit) Nothing + +suggestAction :: CodeActionArgs -> GhcideCodeActions +suggestAction caa = + concat -- Order these suggestions by priority + [ wrap $ suggestSignature True + , wrap suggestExtendImport + , wrap suggestImportDisambiguation + , wrap suggestNewOrExtendImportForClassMethod + , wrap suggestFillTypeWildcard + , wrap suggestFixConstructorImport + , wrap suggestModuleTypo + , wrap suggestReplaceIdentifier + , wrap removeRedundantConstraints + , wrap suggestAddTypeAnnotationToSatisfyContraints + , wrap suggestConstraint + , wrap suggestImplicitParameter + , wrap suggestHideShadow + , wrap suggestNewDefinition + , wrap suggestNewImport + , wrap suggestDeleteUnusedBinding + , wrap suggestExportUnusedTopBinding + , wrap suggestFillHole -- Lowest priority + ] + where + wrap :: ToCodeAction a => a -> GhcideCodeActions + wrap = toCodeAction caa + +findSigOfDecl :: (IdP p -> Bool) -> [LHsDecl p] -> Maybe (Sig p) +findSigOfDecl pred decls = + listToMaybe + [ sig + | L _ (SigD _ sig@(TypeSig _ idsSig _)) <- decls, + any (pred . unLoc) idsSig + ] + +findInstanceHead :: (Outputable (HsType p)) => DynFlags -> String -> [LHsDecl p] -> Maybe (LHsType p) +findInstanceHead df instanceHead decls = + listToMaybe + [ hsib_body + | L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = HsIB {hsib_body}})) <- decls, + showSDoc df (ppr hsib_body) == instanceHead + ] + +findDeclContainingLoc :: Position -> [Located a] -> Maybe (Located a) +findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` l) + +-- Single: +-- This binding for ‘mod’ shadows the existing binding +-- imported from ‘Prelude’ at haskell-language-server/ghcide/src/Development/IDE/Plugin/CodeAction.hs:10:8-40 +-- (and originally defined in ‘GHC.Real’)typecheck(-Wname-shadowing) +-- Multi: +--This binding for ‘pack’ shadows the existing bindings +-- imported from ‘Data.ByteString’ at B.hs:6:1-22 +-- imported from ‘Data.ByteString.Lazy’ at B.hs:8:1-27 +-- imported from ‘Data.Text’ at B.hs:7:1-16 +suggestHideShadow :: ParsedSource -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Rewrite])] +suggestHideShadow pm@(L _ HsModule {hsmodImports}) mTcM mHar Diagnostic {_message, _range} + | Just [identifier, modName, s] <- + matchRegexUnifySpaces + _message + "This binding for ‘([^`]+)’ shadows the existing binding imported from ‘([^`]+)’ at ([^ ]*)" = + suggests identifier modName s + | Just [identifier] <- + matchRegexUnifySpaces + _message + "This binding for ‘([^`]+)’ shadows the existing bindings", + Just matched <- allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’ at ([^ ]*)", + mods <- [(modName, s) | [_, modName, s] <- matched], + result <- nubOrdBy (compare `on` fst) $ mods >>= uncurry (suggests identifier), + hideAll <- ("Hide " <> identifier <> " from all occurence imports", concat $ snd <$> result) = + result <> [hideAll] + | otherwise = [] + where + suggests identifier modName s + | Just tcM <- mTcM, + Just har <- mHar, + [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack s], + isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (RealSrcSpan s'), + mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName, + title <- "Hide " <> identifier <> " from " <> modName = + if modName == "Prelude" && null mDecl + then [(title, maybeToList $ hideImplicitPreludeSymbol (T.unpack identifier) pm)] + else maybeToList $ (title,) . pure . hideSymbol (T.unpack identifier) <$> mDecl + | otherwise = [] + +findImportDeclByModuleName :: [LImportDecl GhcPs] -> String -> Maybe (LImportDecl GhcPs) +findImportDeclByModuleName decls modName = flip find decls $ \case + (L _ ImportDecl {..}) -> modName == moduleNameString (unLoc ideclName) + _ -> error "impossible" + +isTheSameLine :: SrcSpan -> SrcSpan -> Bool +isTheSameLine s1 s2 + | Just sl1 <- getStartLine s1, + Just sl2 <- getStartLine s2 = + sl1 == sl2 + | otherwise = False + where + getStartLine x = srcLocLine . realSrcSpanStart <$> realSpan x + +isUnusedImportedId :: TcModuleResult -> HieAstResult -> String -> String -> SrcSpan -> Bool +isUnusedImportedId + TcModuleResult {tmrTypechecked = TcGblEnv {tcg_imports = ImportAvails {imp_mods}}} + HAR {refMap} + identifier + modName + importSpan + | occ <- mkVarOcc identifier, + impModsVals <- importedByUser . concat $ moduleEnvElts imp_mods, + Just rdrEnv <- + listToMaybe + [ imv_all_exports + | ImportedModsVal {..} <- impModsVals, + imv_name == mkModuleName modName, + isTheSameLine imv_span importSpan + ], + [GRE {..}] <- lookupGlobalRdrEnv rdrEnv occ, + importedIdentifier <- Right gre_name, + refs <- M.lookup importedIdentifier refMap = + maybe True (not . any (\(_, IdentifierDetails {..}) -> identInfo == S.singleton Use)) refs + | otherwise = False + +suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..} +-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant + | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant" + , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == Just _range ) hsmodImports + , Just c <- contents + , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings) + , ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges) + , not (null ranges') + = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )] + +-- File.hs:16:1: warning: +-- The import of `Data.List' is redundant +-- except perhaps to import instances from `Data.List' +-- To import instances alone, use: import Data.List() + | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String) + = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])] + | otherwise = [] + +caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] +caRemoveRedundantImports m contents digs ctxDigs uri + | Just pm <- m, + r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) digs, + allEdits <- [ e | (_, (_, edits)) <- r, e <- edits], + caRemoveAll <- removeAll allEdits, + ctxEdits <- [ x | x@(d, _) <- r, d `elem` ctxDigs], + not $ null ctxEdits, + caRemoveCtx <- map (\(d, (title, tedit)) -> removeSingle title tedit d) ctxEdits + = caRemoveCtx ++ [caRemoveAll] + | otherwise = [] + where + removeSingle title tedit diagnostic = mkCA title (Just CodeActionQuickFix) Nothing [diagnostic] WorkspaceEdit{..} where + _changes = Just $ Map.singleton uri $ List tedit + _documentChanges = Nothing + removeAll tedit = InR $ CodeAction{..} where + _changes = Just $ Map.singleton uri $ List tedit + _title = "Remove all redundant imports" + _kind = Just CodeActionQuickFix + _diagnostics = Nothing + _documentChanges = Nothing + _edit = Just WorkspaceEdit{..} + _isPreferred = Nothing + _command = Nothing + _disabled = Nothing + +caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] +caRemoveInvalidExports m contents digs ctxDigs uri + | Just pm <- m, + Just txt <- contents, + txt' <- indexedByPosition $ T.unpack txt, + r <- mapMaybe (groupDiag pm) digs, + r' <- map (\(t,d,rs) -> (t,d,extend txt' rs)) r, + caRemoveCtx <- mapMaybe removeSingle r', + allRanges <- nubOrd $ [ range | (_,_,ranges) <- r, range <- ranges], + allRanges' <- extend txt' allRanges, + Just caRemoveAll <- removeAll allRanges', + ctxEdits <- [ x | x@(_, d, _) <- r, d `elem` ctxDigs], + not $ null ctxEdits + = caRemoveCtx ++ [caRemoveAll] + | otherwise = [] + where + extend txt ranges = extendAllToIncludeCommaIfPossible True txt ranges + + groupDiag pm dig + | Just (title, ranges) <- suggestRemoveRedundantExport pm dig + = Just (title, dig, ranges) + | otherwise = Nothing + + removeSingle (_, _, []) = Nothing + removeSingle (title, diagnostic, ranges) = Just $ InR $ CodeAction{..} where + tedit = concatMap (\r -> [TextEdit r ""]) $ nubOrd ranges + _changes = Just $ Map.singleton uri $ List tedit + _title = title + _kind = Just CodeActionQuickFix + _diagnostics = Just $ List [diagnostic] + _documentChanges = Nothing + _edit = Just WorkspaceEdit{..} + _command = Nothing + _isPreferred = Nothing + _disabled = Nothing + removeAll [] = Nothing + removeAll ranges = Just $ InR $ CodeAction{..} where + tedit = concatMap (\r -> [TextEdit r ""]) ranges + _changes = Just $ Map.singleton uri $ List tedit + _title = "Remove all redundant exports" + _kind = Just CodeActionQuickFix + _diagnostics = Nothing + _documentChanges = Nothing + _edit = Just WorkspaceEdit{..} + _command = Nothing + _isPreferred = Nothing + _disabled = Nothing + +suggestRemoveRedundantExport :: ParsedModule -> Diagnostic -> Maybe (T.Text, [Range]) +suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} + | msg <- unifySpaces _message + , Just export <- hsmodExports + , Just exportRange <- getLocatedRange export + , exports <- unLoc export + , Just (removeFromExport, !ranges) <- fmap (getRanges exports . notInScope) (extractNotInScopeName msg) + <|> (,[_range]) <$> matchExportItem msg + <|> (,[_range]) <$> matchDupExport msg + , subRange _range exportRange + = Just ("Remove ‘" <> removeFromExport <> "’ from export", ranges) + where + matchExportItem msg = regexSingleMatch msg "The export item ‘([^’]+)’" + matchDupExport msg = regexSingleMatch msg "Duplicate ‘([^’]+)’ in export list" + getRanges exports txt = case smallerRangesForBindingExport exports (T.unpack txt) of + [] -> (txt, [_range]) + ranges -> (txt, ranges) +suggestRemoveRedundantExport _ _ = Nothing + +suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestDeleteUnusedBinding + ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} + contents + Diagnostic{_range=_range,..} +-- Foo.hs:4:1: warning: [-Wunused-binds] Defined but not used: ‘f’ + | Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’" + , Just indexedContent <- indexedByPosition . T.unpack <$> contents + = let edits = flip TextEdit "" <$> relatedRanges indexedContent (T.unpack name) + in ([("Delete ‘" <> name <> "’", edits) | not (null edits)]) + | otherwise = [] + where + relatedRanges indexedContent name = + concatMap (findRelatedSpans indexedContent name) hsmodDecls + toRange = realSrcSpanToRange + extendForSpaces = extendToIncludePreviousNewlineIfPossible + + findRelatedSpans :: PositionIndexedString -> String -> Located (HsDecl GhcPs) -> [Range] + findRelatedSpans + indexedContent + name + (L (RealSrcSpan l) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) = + case lname of + (L nLoc _name) | isTheBinding nLoc -> + let findSig (L (RealSrcSpan l) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig + findSig _ = [] + in + extendForSpaces indexedContent (toRange l) : + concatMap findSig hsmodDecls + _ -> concatMap (findRelatedSpanForMatch indexedContent name) matches + findRelatedSpans _ _ _ = [] + + extractNameAndMatchesFromFunBind + :: HsBind GhcPs + -> Maybe (Located (IdP GhcPs), [LMatch GhcPs (LHsExpr GhcPs)]) + extractNameAndMatchesFromFunBind + FunBind + { fun_id=lname + , fun_matches=MG {mg_alts=L _ matches} + } = Just (lname, matches) + extractNameAndMatchesFromFunBind _ = Nothing + + findRelatedSigSpan :: PositionIndexedString -> String -> RealSrcSpan -> Sig GhcPs -> [Range] + findRelatedSigSpan indexedContent name l sig = + let maybeSpan = findRelatedSigSpan1 name sig + in case maybeSpan of + Just (_span, True) -> pure $ extendForSpaces indexedContent $ toRange l -- a :: Int + Just (RealSrcSpan span, False) -> pure $ toRange span -- a, b :: Int, a is unused + _ -> [] + + -- Second of the tuple means there is only one match + findRelatedSigSpan1 :: String -> Sig GhcPs -> Maybe (SrcSpan, Bool) + findRelatedSigSpan1 name (TypeSig _ lnames _) = + let maybeIdx = findIndex (\(L _ id) -> isSameName id name) lnames + in case maybeIdx of + Nothing -> Nothing + Just _ | length lnames == 1 -> Just (getLoc $ head lnames, True) + Just idx -> + let targetLname = getLoc $ lnames !! idx + startLoc = srcSpanStart targetLname + endLoc = srcSpanEnd targetLname + startLoc' = if idx == 0 + then startLoc + else srcSpanEnd . getLoc $ lnames !! (idx - 1) + endLoc' = if idx == 0 && idx < length lnames - 1 + then srcSpanStart . getLoc $ lnames !! (idx + 1) + else endLoc + in Just (mkSrcSpan startLoc' endLoc', False) + findRelatedSigSpan1 _ _ = Nothing + + -- for where clause + findRelatedSpanForMatch + :: PositionIndexedString + -> String + -> LMatch GhcPs (LHsExpr GhcPs) + -> [Range] + findRelatedSpanForMatch + indexedContent + name + (L _ Match{m_grhss=GRHSs{grhssLocalBinds}}) = do + case grhssLocalBinds of + (L _ (HsValBinds _ (ValBinds _ bag lsigs))) -> + if isEmptyBag bag + then [] + else concatMap (findRelatedSpanForHsBind indexedContent name lsigs) bag + _ -> [] + findRelatedSpanForMatch _ _ _ = [] + + findRelatedSpanForHsBind + :: PositionIndexedString + -> String + -> [LSig GhcPs] + -> LHsBind GhcPs + -> [Range] + findRelatedSpanForHsBind + indexedContent + name + lsigs + (L (RealSrcSpan l) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) = + if isTheBinding (getLoc lname) + then + let findSig (L (RealSrcSpan l) sig) = findRelatedSigSpan indexedContent name l sig + findSig _ = [] + in extendForSpaces indexedContent (toRange l) : concatMap findSig lsigs + else concatMap (findRelatedSpanForMatch indexedContent name) matches + findRelatedSpanForHsBind _ _ _ _ = [] + + isTheBinding :: SrcSpan -> Bool + isTheBinding span = srcSpanToRange span == Just _range + + isSameName :: IdP GhcPs -> String -> Bool + isSameName x name = showSDocUnsafe (ppr x) == name + +data ExportsAs = ExportName | ExportPattern | ExportAll + deriving (Eq) + +getLocatedRange :: Located a -> Maybe Range +getLocatedRange = srcSpanToRange . getLoc + +suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> Diagnostic -> [(T.Text, TextEdit)] +suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} +-- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’ +-- Foo.hs:5:1: warning: [-Wunused-top-binds] Defined but not used: type constructor or class ‘F’ +-- Foo.hs:6:1: warning: [-Wunused-top-binds] Defined but not used: data constructor ‘Bar’ + | Just source <- srcOpt + , Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’" + <|> matchRegexUnifySpaces _message ".*Defined but not used: type constructor or class ‘([^ ]+)’" + <|> matchRegexUnifySpaces _message ".*Defined but not used: data constructor ‘([^ ]+)’" + , Just (exportType, _) <- find (matchWithDiagnostic _range . snd) + . mapMaybe + (\(L l b) -> if maybe False isTopLevel $ srcSpanToRange l + then exportsAs b else Nothing) + $ hsmodDecls + , Just pos <- fmap _end . getLocatedRange =<< hsmodExports + , Just needComma <- needsComma source <$> hsmodExports + , let exportName = (if needComma then "," else "") <> printExport exportType name + insertPos = pos {_character = pred $ _character pos} + = [("Export ‘" <> name <> "’", TextEdit (Range insertPos insertPos) exportName)] + | otherwise = [] + where + -- we get the last export and the closing bracket and check for comma in that range + needsComma :: T.Text -> Located [LIE GhcPs] -> Bool + needsComma _ (L _ []) = False + needsComma source (L (RealSrcSpan l) exports) = + let closeParan = _end $ realSrcSpanToRange l + lastExport = fmap _end . getLocatedRange $ last exports + in case lastExport of + Just lastExport -> not $ T.isInfixOf "," $ textInRange (Range lastExport closeParan) source + _ -> False + needsComma _ _ = False + + opLetter :: String + opLetter = ":!#$%&*+./<=>?@\\^|-~" + + parenthesizeIfNeeds :: Bool -> T.Text -> T.Text + parenthesizeIfNeeds needsTypeKeyword x + | T.head x `elem` opLetter = (if needsTypeKeyword then "type " else "") <> "(" <> x <>")" + | otherwise = x + + matchWithDiagnostic :: Range -> Located (IdP GhcPs) -> Bool + matchWithDiagnostic Range{_start=l,_end=r} x = + let loc = fmap _start . getLocatedRange $ x + in loc >= Just l && loc <= Just r + + printExport :: ExportsAs -> T.Text -> T.Text + printExport ExportName x = parenthesizeIfNeeds False x + printExport ExportPattern x = "pattern " <> x + printExport ExportAll x = parenthesizeIfNeeds True x <> "(..)" + + isTopLevel :: Range -> Bool + isTopLevel l = (_character . _start) l == 0 + + exportsAs :: HsDecl p -> Maybe (ExportsAs, Located (IdP p)) + exportsAs (ValD _ FunBind {fun_id}) = Just (ExportName, fun_id) + exportsAs (ValD _ (PatSynBind _ PSB {psb_id})) = Just (ExportPattern, psb_id) + exportsAs (TyClD _ SynDecl{tcdLName}) = Just (ExportName, tcdLName) + exportsAs (TyClD _ DataDecl{tcdLName}) = Just (ExportAll, tcdLName) + exportsAs (TyClD _ ClassDecl{tcdLName}) = Just (ExportAll, tcdLName) + exportsAs (TyClD _ FamDecl{tcdFam}) = Just (ExportAll, fdLName tcdFam) + exportsAs _ = Nothing + +suggestAddTypeAnnotationToSatisfyContraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestAddTypeAnnotationToSatisfyContraints sourceOpt Diagnostic{_range=_range,..} +-- File.hs:52:41: warning: +-- * Defaulting the following constraint to type ‘Integer’ +-- Num p0 arising from the literal ‘1’ +-- * In the expression: 1 +-- In an equation for ‘f’: f = 1 +-- File.hs:52:41: warning: +-- * Defaulting the following constraints to type ‘[Char]’ +-- (Show a0) +-- arising from a use of ‘traceShow’ +-- at A.hs:228:7-25 +-- (IsString a0) +-- arising from the literal ‘"debug"’ +-- at A.hs:228:17-23 +-- * In the expression: traceShow "debug" a +-- In an equation for ‘f’: f a = traceShow "debug" a +-- File.hs:52:41: warning: +-- * Defaulting the following constraints to type ‘[Char]’ +-- (Show a0) +-- arising from a use of ‘traceShow’ +-- at A.hs:255:28-43 +-- (IsString a0) +-- arising from the literal ‘"test"’ +-- at /Users/serhiip/workspace/ghcide/src/Development/IDE/Plugin/CodeAction.hs:255:38-43 +-- * In the fourth argument of ‘seq’, namely ‘(traceShow "test")’ +-- In the expression: seq "test" seq "test" (traceShow "test") +-- In an equation for ‘f’: +-- f = seq "test" seq "test" (traceShow "test") + | Just [ty, lit] <- matchRegexUnifySpaces _message (pat False False True False) + <|> matchRegexUnifySpaces _message (pat False False False True) + <|> matchRegexUnifySpaces _message (pat False False False False) + = codeEdit ty lit (makeAnnotatedLit ty lit) + | Just source <- sourceOpt + , Just [ty, lit] <- matchRegexUnifySpaces _message (pat True True False False) + = let lit' = makeAnnotatedLit ty lit; + tir = textInRange _range source + in codeEdit ty lit (T.replace lit lit' tir) + | otherwise = [] + where + makeAnnotatedLit ty lit = "(" <> lit <> " :: " <> ty <> ")" + pat multiple at inArg inExpr = T.concat [ ".*Defaulting the following constraint" + , if multiple then "s" else "" + , " to type ‘([^ ]+)’ " + , ".*arising from the literal ‘(.+)’" + , if inArg then ".+In the.+argument" else "" + , if at then ".+at" else "" + , if inExpr then ".+In the expression" else "" + , ".+In the expression" + ] + codeEdit ty lit replacement = + let title = "Add type annotation ‘" <> ty <> "’ to ‘" <> lit <> "’" + edits = [TextEdit _range replacement] + in [( title, edits )] + + +suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestReplaceIdentifier contents Diagnostic{_range=_range,..} +-- File.hs:52:41: error: +-- * Variable not in scope: +-- suggestAcion :: Maybe T.Text -> Range -> Range +-- * Perhaps you meant ‘suggestAction’ (line 83) +-- File.hs:94:37: error: +-- Not in scope: ‘T.isPrfixOf’ +-- Perhaps you meant one of these: +-- ‘T.isPrefixOf’ (imported from Data.Text), +-- ‘T.isInfixOf’ (imported from Data.Text), +-- ‘T.isSuffixOf’ (imported from Data.Text) +-- Module ‘Data.Text’ does not export ‘isPrfixOf’. + | renameSuggestions@(_:_) <- extractRenamableTerms _message + = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ] + | otherwise = [] + +suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestNewDefinition ideOptions parsedModule contents Diagnostic{_message, _range} +-- * Variable not in scope: +-- suggestAcion :: Maybe T.Text -> Range -> Range + | Just [name, typ] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)" + = newDefinitionAction ideOptions parsedModule _range name typ + | Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps" + , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ + = [(label, mkRenameEdit contents _range name : newDefinitionEdits)] + | otherwise = [] + where + message = unifySpaces _message + +newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text -> [(T.Text, [TextEdit])] +newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ + | Range _ lastLineP : _ <- + [ realSrcSpanToRange sp + | (L l@(RealSrcSpan sp) _) <- hsmodDecls + , _start `isInsideSrcSpan` l] + , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0} + = [ ("Define " <> sig + , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = error \"not implemented\""])] + )] + | otherwise = [] + where + colon = if optNewColonConvention then " : " else " :: " + sig = name <> colon <> T.dropWhileEnd isSpace typ + ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule + + +suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)] +suggestFillTypeWildcard Diagnostic{_range=_range,..} +-- Foo.hs:3:8: error: +-- * Found type wildcard `_' standing for `p -> p1 -> p' + + | "Found type wildcard" `T.isInfixOf` _message + , " standing for " `T.isInfixOf` _message + , typeSignature <- extractWildCardTypeSignature _message + = [("Use type signature: ‘" <> typeSignature <> "’", TextEdit _range typeSignature)] + | otherwise = [] + +suggestModuleTypo :: Diagnostic -> [(T.Text, TextEdit)] +suggestModuleTypo Diagnostic{_range=_range,..} +-- src/Development/IDE/Core/Compile.hs:58:1: error: +-- Could not find module ‘Data.Cha’ +-- Perhaps you meant Data.Char (from base-4.12.0.0) + | "Could not find module" `T.isInfixOf` _message + , "Perhaps you meant" `T.isInfixOf` _message = let + findSuggestedModules = map (head . T.words) . drop 2 . T.lines + proposeModule mod = ("replace with " <> mod, TextEdit _range mod) + in map proposeModule $ nubOrd $ findSuggestedModules _message + | otherwise = [] + +suggestFillHole :: Diagnostic -> [(T.Text, TextEdit)] +suggestFillHole Diagnostic{_range=_range,..} + | Just holeName <- extractHoleName _message + , (holeFits, refFits) <- processHoleSuggestions (T.lines _message) + = map (proposeHoleFit holeName False) holeFits + ++ map (proposeHoleFit holeName True) refFits + | otherwise = [] + where + extractHoleName = fmap head . flip matchRegexUnifySpaces "Found hole: ([^ ]*)" + proposeHoleFit holeName parenthise name = + ( "replace " <> holeName <> " with " <> name + , TextEdit _range $ if parenthise then parens name else name) + parens x = "(" <> x <> ")" + +processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text]) +processHoleSuggestions mm = (holeSuggestions, refSuggestions) +{- + • Found hole: _ :: LSP.Handlers + + Valid hole fits include def + Valid refinement hole fits include + fromMaybe (_ :: LSP.Handlers) (_ :: Maybe LSP.Handlers) + fromJust (_ :: Maybe LSP.Handlers) + haskell-lsp-types-0.22.0.0:Language.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams + LSP.Handlers) + T.foldl (_ :: LSP.Handlers -> Char -> LSP.Handlers) + (_ :: LSP.Handlers) + (_ :: T.Text) + T.foldl' (_ :: LSP.Handlers -> Char -> LSP.Handlers) + (_ :: LSP.Handlers) + (_ :: T.Text) +-} + where + t = id @T.Text + holeSuggestions = do + -- get the text indented under Valid hole fits + validHolesSection <- + getIndentedGroupsBy (=~ t " *Valid (hole fits|substitutions) include") mm + -- the Valid hole fits line can contain a hole fit + holeFitLine <- + mapHead + (mrAfter . (=~ t " *Valid (hole fits|substitutions) include")) + validHolesSection + let holeFit = T.strip $ T.takeWhile (/= ':') holeFitLine + guard (not $ T.null holeFit) + return holeFit + refSuggestions = do -- @[] + -- get the text indented under Valid refinement hole fits + refinementSection <- + getIndentedGroupsBy (=~ t " *Valid refinement hole fits include") mm + -- get the text for each hole fit + holeFitLines <- getIndentedGroups (tail refinementSection) + let holeFit = T.strip $ T.unwords holeFitLines + guard $ not $ holeFit =~ t "Some refinement hole fits suppressed" + return holeFit + + mapHead f (a:aa) = f a : aa + mapHead _ [] = [] + +-- > getIndentedGroups [" H1", " l1", " l2", " H2", " l3"] = [[" H1,", " l1", " l2"], [" H2", " l3"]] +getIndentedGroups :: [T.Text] -> [[T.Text]] +getIndentedGroups [] = [] +getIndentedGroups ll@(l:_) = getIndentedGroupsBy ((== indentation l) . indentation) ll +-- | +-- > getIndentedGroupsBy (" H" `isPrefixOf`) [" H1", " l1", " l2", " H2", " l3"] = [[" H1", " l1", " l2"], [" H2", " l3"]] +getIndentedGroupsBy :: (T.Text -> Bool) -> [T.Text] -> [[T.Text]] +getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of + (l:ll) -> case span (\l' -> indentation l < indentation l') ll of + (indented, rest) -> (l:indented) : getIndentedGroupsBy pred rest + _ -> [] + +indentation :: T.Text -> Int +indentation = T.length . T.takeWhile isSpace + +suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)] +suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_range,..} + | Just [binding, mod, srcspan] <- + matchRegexUnifySpaces _message + "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$" + = suggestions hsmodImports binding mod srcspan + | Just (binding, mod_srcspan) <- + matchRegExMultipleImports _message + = mod_srcspan >>= uncurry (suggestions hsmodImports binding) + | otherwise = [] + where + suggestions decls binding mod srcspan + | range <- case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of + [s] -> let x = realSrcSpanToRange s + in x{_end = (_end x){_character = succ (_character (_end x))}} + _ -> error "bug in srcspan parser", + Just decl <- findImportDeclByRange decls range, + Just ident <- lookupExportMap binding mod + = [ ( "Add " <> renderImportStyle importStyle <> " to the import list of " <> mod + , uncurry extendImport (unImportStyle importStyle) decl + ) + | importStyle <- NE.toList $ importStyles ident + ] + | otherwise = [] + lookupExportMap binding mod + | Just match <- Map.lookup binding (getExportsMap exportsMap) + , [ident] <- filter (\ident -> moduleNameText ident == mod) (Set.toList match) + = Just ident + + -- fallback to using GHC suggestion even though it is not always correct + | otherwise + = Just IdentInfo + { name = binding + , rendered = binding + , parent = Nothing + , isDatacon = False + , moduleNameText = mod} + +data HidingMode + = HideOthers [ModuleTarget] + | ToQualified + Bool + -- ^ Parenthesised? + ModuleName + deriving (Show) + +data ModuleTarget + = ExistingImp (NonEmpty (LImportDecl GhcPs)) + | ImplicitPrelude [LImportDecl GhcPs] + deriving (Show) + +targetImports :: ModuleTarget -> [LImportDecl GhcPs] +targetImports (ExistingImp ne) = NE.toList ne +targetImports (ImplicitPrelude xs) = xs + +oneAndOthers :: [a] -> [(a, [a])] +oneAndOthers = go + where + go [] = [] + go (x : xs) = (x, xs) : map (second (x :)) (go xs) + +isPreludeImplicit :: DynFlags -> Bool +isPreludeImplicit = xopt Lang.ImplicitPrelude + +-- | Suggests disambiguation for ambiguous symbols. +suggestImportDisambiguation :: + DynFlags -> + Maybe T.Text -> + ParsedSource -> + Diagnostic -> + [(T.Text, [Rewrite])] +suggestImportDisambiguation df (Just txt) ps@(L _ HsModule {hsmodImports}) diag@Diagnostic {..} + | Just [ambiguous] <- + matchRegexUnifySpaces + _message + "Ambiguous occurrence ‘([^’]+)’" + , Just modules <- + map last + <$> allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’" = + suggestions ambiguous modules + | otherwise = [] + where + locDic = + fmap (NE.fromList . DL.toList) $ + Map.fromListWith (<>) $ + map + ( \i@(L _ idecl) -> + ( T.pack $ moduleNameString $ unLoc $ ideclName idecl + , DL.singleton i + ) + ) + hsmodImports + toModuleTarget "Prelude" + | isPreludeImplicit df + = Just $ ImplicitPrelude $ + maybe [] NE.toList (Map.lookup "Prelude" locDic) + toModuleTarget mName = ExistingImp <$> Map.lookup mName locDic + parensed = + "(" `T.isPrefixOf` T.strip (textInRange _range txt) + suggestions symbol mods + | Just targets <- mapM toModuleTarget mods = + sortOn fst + [ ( renderUniquify mode modNameText symbol + , disambiguateSymbol ps diag symbol mode + ) + | (modTarget, restImports) <- oneAndOthers targets + , let modName = targetModuleName modTarget + modNameText = T.pack $ moduleNameString modName + , mode <- + HideOthers restImports : + [ ToQualified parensed qual + | ExistingImp imps <- [modTarget] + , L _ qual <- nubOrd $ mapMaybe (ideclAs . unLoc) + $ NE.toList imps + ] + ++ [ToQualified parensed modName + | any (occursUnqualified symbol . unLoc) + (targetImports modTarget) + || case modTarget of + ImplicitPrelude{} -> True + _ -> False + ] + ] + | otherwise = [] + renderUniquify HideOthers {} modName symbol = + "Use " <> modName <> " for " <> symbol <> ", hiding other imports" + renderUniquify (ToQualified _ qual) _ symbol = + "Replace with qualified: " + <> T.pack (moduleNameString qual) + <> "." + <> symbol +suggestImportDisambiguation _ _ _ _ = [] + +occursUnqualified :: T.Text -> ImportDecl GhcPs -> Bool +occursUnqualified symbol ImportDecl{..} + | isNothing ideclAs = Just False /= + -- I don't find this particularly comprehensible, + -- but HLint suggested me to do so... + (ideclHiding <&> \(isHiding, L _ ents) -> + let occurs = any ((symbol `symbolOccursIn`) . unLoc) ents + in isHiding && not occurs || not isHiding && occurs + ) +occursUnqualified _ _ = False + +symbolOccursIn :: T.Text -> IE GhcPs -> Bool +symbolOccursIn symb = any ((== symb). showNameWithoutUniques) . ieNames + +targetModuleName :: ModuleTarget -> ModuleName +targetModuleName ImplicitPrelude{} = mkModuleName "Prelude" +targetModuleName (ExistingImp (L _ ImportDecl{..} :| _)) = + unLoc ideclName +targetModuleName (ExistingImp _) = + error "Cannot happen!" + +disambiguateSymbol :: + ParsedSource -> + Diagnostic -> + T.Text -> + HidingMode -> + [Rewrite] +disambiguateSymbol pm Diagnostic {..} (T.unpack -> symbol) = \case + (HideOthers hiddens0) -> + [ hideSymbol symbol idecl + | ExistingImp idecls <- hiddens0 + , idecl <- NE.toList idecls + ] + ++ mconcat + [ if null imps + then maybeToList $ hideImplicitPreludeSymbol symbol pm + else hideSymbol symbol <$> imps + | ImplicitPrelude imps <- hiddens0 + ] + (ToQualified parensed qualMod) -> + let occSym = mkVarOcc symbol + rdr = Qual qualMod occSym + in [ if parensed + then Rewrite (rangeToSrcSpan "" _range) $ \df -> + liftParseAST @(HsExpr GhcPs) df $ + prettyPrint $ + HsVar @GhcPs noExtField $ + L (UnhelpfulSpan "") rdr + else Rewrite (rangeToSrcSpan "" _range) $ \df -> + liftParseAST @RdrName df $ + prettyPrint $ L (UnhelpfulSpan "") rdr + ] + +findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs) +findImportDeclByRange xs range = find (\(L l _)-> srcSpanToRange l == Just range) xs + +suggestFixConstructorImport :: Diagnostic -> [(T.Text, TextEdit)] +suggestFixConstructorImport Diagnostic{_range=_range,..} + -- ‘Success’ is a data constructor of ‘Result’ + -- To import it use + -- import Data.Aeson.Types( Result( Success ) ) + -- or + -- import Data.Aeson.Types( Result(..) ) (lsp-ui) + | Just [constructor, typ] <- + matchRegexUnifySpaces _message + "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use" + = let fixedImport = typ <> "(" <> constructor <> ")" + in [("Fix import of " <> fixedImport, TextEdit _range fixedImport)] + | otherwise = [] +-- | Suggests a constraint for a declaration for which a constraint is missing. +suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)] +suggestConstraint df parsedModule diag@Diagnostic {..} + | Just missingConstraint <- findMissingConstraint _message + = let codeAction = if _message =~ ("the type signature for:" :: String) + then suggestFunctionConstraint df parsedModule + else suggestInstanceConstraint df parsedModule + in codeAction diag missingConstraint + | otherwise = [] + where + findMissingConstraint :: T.Text -> Maybe T.Text + findMissingConstraint t = + let regex = "(No instance for|Could not deduce) \\((.+)\\) arising from" -- a use of / a do statement + regexImplicitParams = "Could not deduce: (\\?.+) arising from a use of" + match = matchRegexUnifySpaces t regex + matchImplicitParams = matchRegexUnifySpaces t regexImplicitParams + in match <|> matchImplicitParams <&> last + +-- | Suggests a constraint for an instance declaration for which a constraint is missing. +suggestInstanceConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] + +suggestInstanceConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint + | Just instHead <- instanceHead + = [(actionTitle missingConstraint , appendConstraint (T.unpack missingConstraint) instHead)] + | otherwise = [] + where + instanceHead + -- Suggests a constraint for an instance declaration with no existing constraints. + -- • No instance for (Eq a) arising from a use of ‘==’ + -- Possible fix: add (Eq a) to the context of the instance declaration + -- • In the expression: x == y + -- In an equation for ‘==’: (Wrap x) == (Wrap y) = x == y + -- In the instance declaration for ‘Eq (Wrap a)’ + | Just [instanceDeclaration] <- matchRegexUnifySpaces _message "In the instance declaration for ‘([^`]*)’" + , Just instHead <- findInstanceHead df (T.unpack instanceDeclaration) hsmodDecls + = Just instHead + -- Suggests a constraint for an instance declaration with one or more existing constraints. + -- • Could not deduce (Eq b) arising from a use of ‘==’ + -- from the context: Eq a + -- bound by the instance declaration at /path/to/Main.hs:7:10-32 + -- Possible fix: add (Eq b) to the context of the instance declaration + -- • In the second argument of ‘(&&)’, namely ‘x' == y'’ + -- In the expression: x == y && x' == y' + -- In an equation for ‘==’: + -- (Pair x x') == (Pair y y') = x == y && x' == y' + | Just [instanceLineStr, constraintFirstCharStr] + <- matchRegexUnifySpaces _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)" + , Just (L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = HsIB{hsib_body}}))) + <- findDeclContainingLoc (Position (readPositionNumber instanceLineStr) (readPositionNumber constraintFirstCharStr)) hsmodDecls + = Just hsib_body + | otherwise + = Nothing + + readPositionNumber :: T.Text -> Int + readPositionNumber = T.unpack >>> read + + actionTitle :: T.Text -> T.Text + actionTitle constraint = "Add `" <> constraint + <> "` to the context of the instance declaration" + +suggestImplicitParameter :: + ParsedSource -> + Diagnostic -> + [(T.Text, Rewrite)] +suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _range} + | Just [implicitT] <- matchRegexUnifySpaces _message "Unbound implicit parameter \\(([^:]+::.+)\\) arising", + Just (L _ (ValD _ FunBind {fun_id = L _ funId})) <- findDeclContainingLoc (_start _range) hsmodDecls, + Just (TypeSig _ _ HsWC {hswc_body = HsIB {hsib_body}}) <- findSigOfDecl (== funId) hsmodDecls + = + [( "Add " <> implicitT <> " to the context of " <> T.pack (printRdrName funId) + , appendConstraint (T.unpack implicitT) hsib_body)] + | otherwise = [] + +findTypeSignatureName :: T.Text -> Maybe T.Text +findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head + +findTypeSignatureLine :: T.Text -> T.Text -> Int +findTypeSignatureLine contents typeSignatureName = + T.splitOn (typeSignatureName <> " :: ") contents & head & T.lines & length + +-- | Suggests a constraint for a type signature with any number of existing constraints. +suggestFunctionConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] + +suggestFunctionConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint +-- • No instance for (Eq a) arising from a use of ‘==’ +-- Possible fix: +-- add (Eq a) to the context of +-- the type signature for: +-- eq :: forall a. a -> a -> Bool +-- • In the expression: x == y +-- In an equation for ‘eq’: eq x y = x == y + +-- • Could not deduce (Eq b) arising from a use of ‘==’ +-- from the context: Eq a +-- bound by the type signature for: +-- eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool +-- at Main.hs:5:1-42 +-- Possible fix: +-- add (Eq b) to the context of +-- the type signature for: +-- eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool +-- • In the second argument of ‘(&&)’, namely ‘y == y'’ +-- In the expression: x == x' && y == y' +-- In an equation for ‘eq’: +-- eq (Pair x y) (Pair x' y') = x == x' && y == y' + | Just typeSignatureName <- findTypeSignatureName _message + , Just (TypeSig _ _ HsWC{hswc_body = HsIB {hsib_body = sig}}) + <- findSigOfDecl ((T.unpack typeSignatureName ==) . showSDoc df . ppr) hsmodDecls + , title <- actionTitle missingConstraint typeSignatureName + = [(title, appendConstraint (T.unpack missingConstraint) sig)] + | otherwise + = [] + where + actionTitle :: T.Text -> T.Text -> T.Text + actionTitle constraint typeSignatureName = "Add `" <> constraint + <> "` to the context of the type signature for `" <> typeSignatureName <> "`" + +-- | Suggests the removal of a redundant constraint for a type signature. +removeRedundantConstraints :: Maybe T.Text -> Diagnostic -> [(T.Text, TextEdit)] +removeRedundantConstraints mContents Diagnostic{..} +-- • Redundant constraint: Eq a +-- • In the type signature for: +-- foo :: forall a. Eq a => a -> a +-- • Redundant constraints: (Monoid a, Show a) +-- • In the type signature for: +-- foo :: forall a. (Num a, Monoid a, Eq a, Show a) => a -> Bool + | Just contents <- mContents + -- Account for both "Redundant constraint" and "Redundant constraints". + , True <- "Redundant constraint" `T.isInfixOf` _message + , Just typeSignatureName <- findTypeSignatureName _message + , Just redundantConstraintList <- findRedundantConstraints _message + , Just constraints <- findConstraints contents typeSignatureName + = let constraintList = parseConstraints constraints + newConstraints = buildNewConstraints constraintList redundantConstraintList + typeSignatureLine = findTypeSignatureLine contents typeSignatureName + typeSignatureFirstChar = T.length $ typeSignatureName <> " :: " + startOfConstraint = Position typeSignatureLine typeSignatureFirstChar + endOfConstraint = Position typeSignatureLine $ + typeSignatureFirstChar + T.length (constraints <> " => ") + range = Range startOfConstraint endOfConstraint + in [(actionTitle redundantConstraintList typeSignatureName, TextEdit range newConstraints)] + | otherwise = [] + where + parseConstraints :: T.Text -> [T.Text] + parseConstraints t = t + & (T.strip >>> stripConstraintsParens >>> T.splitOn ",") + <&> T.strip + + stripConstraintsParens :: T.Text -> T.Text + stripConstraintsParens constraints = + if "(" `T.isPrefixOf` constraints + then constraints & T.drop 1 & T.dropEnd 1 & T.strip + else constraints + + findRedundantConstraints :: T.Text -> Maybe [T.Text] + findRedundantConstraints t = t + & T.lines + & head + & T.strip + & (`matchRegexUnifySpaces` "Redundant constraints?: (.+)") + <&> (head >>> parseConstraints) + + -- If the type signature is not formatted as expected (arbitrary number of spaces, + -- line feeds...), just fail. + findConstraints :: T.Text -> T.Text -> Maybe T.Text + findConstraints contents typeSignatureName = do + constraints <- contents + & T.splitOn (typeSignatureName <> " :: ") + & (`atMay` 1) + >>= (T.splitOn " => " >>> (`atMay` 0)) + guard $ not $ "\n" `T.isInfixOf` constraints || T.strip constraints /= constraints + return constraints + + formatConstraints :: [T.Text] -> T.Text + formatConstraints [] = "" + formatConstraints [constraint] = constraint + formatConstraints constraintList = constraintList + & T.intercalate ", " + & \cs -> "(" <> cs <> ")" + + formatConstraintsWithArrow :: [T.Text] -> T.Text + formatConstraintsWithArrow [] = "" + formatConstraintsWithArrow cs = cs & formatConstraints & (<> " => ") + + buildNewConstraints :: [T.Text] -> [T.Text] -> T.Text + buildNewConstraints constraintList redundantConstraintList = + formatConstraintsWithArrow $ constraintList \\ redundantConstraintList + + actionTitle :: [T.Text] -> T.Text -> T.Text + actionTitle constraintList typeSignatureName = + "Remove redundant constraint" <> (if length constraintList == 1 then "" else "s") <> " `" + <> formatConstraints constraintList + <> "` from the context of the type signature for `" <> typeSignatureName <> "`" + +------------------------------------------------------------------------------------------------- + +suggestNewOrExtendImportForClassMethod :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, [Rewrite])] +suggestNewOrExtendImportForClassMethod packageExportsMap ps Diagnostic {_message} + | Just [methodName, className] <- + matchRegexUnifySpaces + _message + "‘([^’]*)’ is not a \\(visible\\) method of class ‘([^’]*)’", + idents <- + maybe [] (Set.toList . Set.filter (\x -> parent x == Just className)) $ + Map.lookup methodName $ getExportsMap packageExportsMap = + mconcat $ suggest <$> idents + | otherwise = [] + where + suggest identInfo@IdentInfo {moduleNameText} + | importStyle <- NE.toList $ importStyles identInfo, + mImportDecl <- findImportDeclByModuleName (hsmodImports $ unLoc ps) (T.unpack moduleNameText) = + case mImportDecl of + -- extend + Just decl -> + [ ( "Add " <> renderImportStyle style <> " to the import list of " <> moduleNameText, + [uncurry extendImport (unImportStyle style) decl] + ) + | style <- importStyle + ] + -- new + _ -> + [ ( "Import " <> moduleNameText <> " with " <> rendered, + maybeToList $ newUnqualImport (T.unpack moduleNameText) (T.unpack rendered) False ps + ) + | style <- importStyle, + let rendered = renderImportStyle style + ] + <> maybeToList (("Import " <> moduleNameText,) <$> fmap pure (newImportAll (T.unpack moduleNameText) ps)) + +suggestNewImport :: ExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, TextEdit)] +suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule {..}} Diagnostic{_message} + | msg <- unifySpaces _message + , Just thingMissing <- extractNotInScopeName msg + , qual <- extractQualifiedModuleName msg + , qual' <- + extractDoesNotExportModuleName msg + >>= (findImportDeclByModuleName hsmodImports . T.unpack) + >>= ideclAs . unLoc + <&> T.pack . moduleNameString . unLoc + , Just insertLine <- case hsmodImports of + [] -> case srcSpanStart $ getLoc (head hsmodDecls) of + RealSrcLoc s -> Just $ srcLocLine s - 1 + _ -> Nothing + _ -> case srcSpanEnd $ getLoc (last hsmodImports) of + RealSrcLoc s -> Just $ srcLocLine s + _ -> Nothing + , insertPos <- Position insertLine 0 + , extendImportSuggestions <- matchRegexUnifySpaces msg + "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’" + = [(imp, TextEdit (Range insertPos insertPos) (imp <> "\n")) + | imp <- sort $ constructNewImportSuggestions packageExportsMap (qual <|> qual', thingMissing) extendImportSuggestions + ] +suggestNewImport _ _ _ = [] + +constructNewImportSuggestions + :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> [T.Text] +constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules = nubOrd + [ suggestion + | Just name <- [T.stripPrefix (maybe "" (<> ".") qual) $ notInScope thingMissing] + , identInfo <- maybe [] Set.toList $ Map.lookup name (getExportsMap exportsMap) + , canUseIdent thingMissing identInfo + , moduleNameText identInfo `notElem` fromMaybe [] notTheseModules + , suggestion <- renderNewImport identInfo + ] + where + renderNewImport :: IdentInfo -> [T.Text] + renderNewImport identInfo + | Just q <- qual + , asQ <- if q == m then "" else " as " <> q + = ["import qualified " <> m <> asQ] + | otherwise + = ["import " <> m <> " (" <> renderImportStyle importStyle <> ")" + | importStyle <- NE.toList $ importStyles identInfo] ++ + ["import " <> m ] + where + m = moduleNameText identInfo + +canUseIdent :: NotInScope -> IdentInfo -> Bool +canUseIdent NotInScopeDataConstructor{} = isDatacon +canUseIdent _ = const True + +data NotInScope + = NotInScopeDataConstructor T.Text + | NotInScopeTypeConstructorOrClass T.Text + | NotInScopeThing T.Text + deriving Show + +notInScope :: NotInScope -> T.Text +notInScope (NotInScopeDataConstructor t) = t +notInScope (NotInScopeTypeConstructorOrClass t) = t +notInScope (NotInScopeThing t) = t + +extractNotInScopeName :: T.Text -> Maybe NotInScope +extractNotInScopeName x + | Just [name] <- matchRegexUnifySpaces x "Data constructor not in scope: ([^ ]+)" + = Just $ NotInScopeDataConstructor name + | Just [name] <- matchRegexUnifySpaces x "Not in scope: data constructor [^‘]*‘([^’]*)’" + = Just $ NotInScopeDataConstructor name + | Just [name] <- matchRegexUnifySpaces x "ot in scope: type constructor or class [^‘]*‘([^’]*)’" + = Just $ NotInScopeTypeConstructorOrClass name + | Just [name] <- matchRegexUnifySpaces x "ot in scope: \\(([^‘ ]+)\\)" + = Just $ NotInScopeThing name + | Just [name] <- matchRegexUnifySpaces x "ot in scope: ([^‘ ]+)" + = Just $ NotInScopeThing name + | Just [name] <- matchRegexUnifySpaces x "ot in scope:[^‘]*‘([^’]*)’" + = Just $ NotInScopeThing name + | otherwise + = Nothing + +extractQualifiedModuleName :: T.Text -> Maybe T.Text +extractQualifiedModuleName x + | Just [m] <- matchRegexUnifySpaces x "module named [^‘]*‘([^’]*)’" + = Just m + | otherwise + = Nothing + +-- | If a module has been imported qualified, and we want to ues the same qualifier for other modules +-- which haven't been imported, 'extractQualifiedModuleName' won't work. Thus we need extract the qualifier +-- from the imported one. +-- +-- For example, we write f = T.putStrLn, where putStrLn comes from Data.Text.IO, with the following import(s): +-- 1. +-- import qualified Data.Text as T +-- +-- Module ‘Data.Text’ does not export ‘putStrLn’. +-- +-- 2. +-- import qualified Data.Text as T +-- import qualified Data.Functor as T +-- +-- Neither ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’. +-- +-- 3. +-- import qualified Data.Text as T +-- import qualified Data.Functor as T +-- import qualified Data.Function as T +-- +-- Neither ‘Data.Function’, +-- ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’. +extractDoesNotExportModuleName :: T.Text -> Maybe T.Text +extractDoesNotExportModuleName x + | Just [m] <- + matchRegexUnifySpaces x "Module ‘([^’]*)’ does not export" + <|> matchRegexUnifySpaces x "nor ‘([^’]*)’ exports" + = Just m + | otherwise + = Nothing +------------------------------------------------------------------------------------------------- + + +mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit +mkRenameEdit contents range name = + if maybeIsInfixFunction == Just True + then TextEdit range ("`" <> name <> "`") + else TextEdit range name + where + maybeIsInfixFunction = do + curr <- textInRange range <$> contents + pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr + +extractWildCardTypeSignature :: T.Text -> T.Text +extractWildCardTypeSignature = + -- inferring when parens are actually needed around the type signature would + -- require understanding both the precedence of the context of the _ and of + -- the signature itself. Inserting them unconditionally is ugly but safe. + ("(" `T.append`) . (`T.append` ")") . + T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') . + snd . T.breakOnEnd "standing for " + +extractRenamableTerms :: T.Text -> [T.Text] +extractRenamableTerms msg + -- Account for both "Variable not in scope" and "Not in scope" + | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg + | otherwise = [] + where + extractSuggestions = map getEnclosed + . concatMap singleSuggestions + . filter isKnownSymbol + . T.lines + singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited + isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t + getEnclosed = T.dropWhile (== '‘') + . T.dropWhileEnd (== '’') + . T.dropAround (\c -> c /= '‘' && c /= '’') + +-- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace +-- between the end of the range and the next newline), extend the range to take up the whole line. +extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range +extendToWholeLineIfPossible contents range@Range{..} = + let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents + extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line + in if extend then Range _start (Position (_line _end + 1) 0) else range + +splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text) +splitTextAtPosition (Position row col) x + | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x + , (preCol, postCol) <- T.splitAt col mid + = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow) + | otherwise = (x, T.empty) + +-- | Returns [start .. end[ +textInRange :: Range -> T.Text -> T.Text +textInRange (Range (Position startRow startCol) (Position endRow endCol)) text = + case compare startRow endRow of + LT -> + let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine + (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of + [] -> ("", []) + firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween) + maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines + in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine) + EQ -> + let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine) + in T.take (endCol - startCol) (T.drop startCol line) + GT -> "" + where + linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text) + +-- | Returns the ranges for a binding in an import declaration +rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range] +rangesForBindingImport ImportDecl{ideclHiding = Just (False, L _ lies)} b = + concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies + where + b' = modifyBinding b +rangesForBindingImport _ _ = [] + +modifyBinding :: String -> String +modifyBinding = wrapOperatorInParens . unqualify + where + wrapOperatorInParens x = if isAlpha (head x) then x else "(" <> x <> ")" + unqualify x = snd $ breakOnEnd "." x + +smallerRangesForBindingExport :: [LIE GhcPs] -> String -> [Range] +smallerRangesForBindingExport lies b = + concatMap (mapMaybe srcSpanToRange . ranges') lies + where + b' = modifyBinding b + ranges' (L _ (IEThingWith _ thing _ inners labels)) + | showSDocUnsafe (ppr thing) == b' = [] + | otherwise = + [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b'] ++ + [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b'] + ranges' _ = [] + +rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan] +rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l] +rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l] +rangesForBinding' b (L l (IEThingAll _ x)) | showSDocUnsafe (ppr x) == b = [l] +rangesForBinding' b (L l (IEThingWith _ thing _ inners labels)) + | showSDocUnsafe (ppr thing) == b = [l] + | otherwise = + [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b] ++ + [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b] +rangesForBinding' _ _ = [] + +-- | 'matchRegex' combined with 'unifySpaces' +matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text] +matchRegexUnifySpaces message = matchRegex (unifySpaces message) + +-- | 'allMatchRegex' combined with 'unifySpaces' +allMatchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [[T.Text]] +allMatchRegexUnifySpaces message = + allMatchRegex (unifySpaces message) + +-- | Returns Just (the submatches) for the first capture, or Nothing. +matchRegex :: T.Text -> T.Text -> Maybe [T.Text] +matchRegex message regex = case message =~~ regex of + Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings + Nothing -> Nothing + +-- | Returns Just (all matches) for the first capture, or Nothing. +allMatchRegex :: T.Text -> T.Text -> Maybe [[T.Text]] +allMatchRegex message regex = message =~~ regex + + +unifySpaces :: T.Text -> T.Text +unifySpaces = T.unwords . T.words + +-- functions to help parse multiple import suggestions + +-- | Returns the first match if found +regexSingleMatch :: T.Text -> T.Text -> Maybe T.Text +regexSingleMatch msg regex = case matchRegexUnifySpaces msg regex of + Just (h:_) -> Just h + _ -> Nothing + +-- | Parses tuples like (‘Data.Map’, (app/ModuleB.hs:2:1-18)) and +-- | return (Data.Map, app/ModuleB.hs:2:1-18) +regExPair :: (T.Text, T.Text) -> Maybe (T.Text, T.Text) +regExPair (modname, srcpair) = do + x <- regexSingleMatch modname "‘([^’]*)’" + y <- regexSingleMatch srcpair "\\((.*)\\)" + return (x, y) + +-- | Process a list of (module_name, filename:src_span) values +-- | Eg. [(Data.Map, app/ModuleB.hs:2:1-18), (Data.HashMap.Strict, app/ModuleB.hs:3:1-29)] +regExImports :: T.Text -> Maybe [(T.Text, T.Text)] +regExImports msg = result + where + parts = T.words msg + isPrefix = not . T.isPrefixOf "(" + (mod, srcspan) = partition isPrefix parts + -- check we have matching pairs like (Data.Map, (app/src.hs:1:2-18)) + result = if length mod == length srcspan then + regExPair `traverse` zip mod srcspan + else Nothing + +matchRegExMultipleImports :: T.Text -> Maybe (T.Text, [(T.Text, T.Text)]) +matchRegExMultipleImports message = do + let pat = T.pack "Perhaps you want to add ‘([^’]*)’ to one of these import lists: *(‘.*\\))$" + (binding, imports) <- case matchRegexUnifySpaces message pat of + Just [x, xs] -> Just (x, xs) + _ -> Nothing + imps <- regExImports imports + return (binding, imps) + +-- | Possible import styles for an 'IdentInfo'. +-- +-- The first 'Text' parameter corresponds to the 'rendered' field of the +-- 'IdentInfo'. +data ImportStyle + = ImportTopLevel T.Text + -- ^ Import a top-level export from a module, e.g., a function, a type, a + -- class. + -- + -- > import M (?) + -- + -- Some exports that have a parent, like a type-class method or an + -- associated type/data family, can still be imported as a top-level + -- import. + -- + -- Note that this is not the case for constructors, they must always be + -- imported as part of their parent data type. + + | ImportViaParent T.Text T.Text + -- ^ Import an export (first parameter) through its parent (second + -- parameter). + -- + -- import M (P(?)) + -- + -- @P@ and @?@ can be a data type and a constructor, a class and a method, + -- a class and an associated type/data family, etc. + deriving Show + +importStyles :: IdentInfo -> NonEmpty ImportStyle +importStyles IdentInfo {parent, rendered, isDatacon} + | Just p <- parent + -- Constructors always have to be imported via their parent data type, but + -- methods and associated type/data families can also be imported as + -- top-level exports. + = ImportViaParent rendered p :| [ImportTopLevel rendered | not isDatacon] + | otherwise + = ImportTopLevel rendered :| [] + +renderImportStyle :: ImportStyle -> T.Text +renderImportStyle (ImportTopLevel x) = x +renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")" + +unImportStyle :: ImportStyle -> (Maybe String, String) +unImportStyle (ImportTopLevel x) = (Nothing, T.unpack x) +unImportStyle (ImportViaParent x y) = (Just $ T.unpack y, T.unpack x) diff --git a/src/Development/IDE/Plugin/CodeAction/Args.hs b/src/Development/IDE/Plugin/CodeAction/Args.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Development.IDE.Plugin.CodeAction.Args + ( module Development.IDE.Plugin.CodeAction.Args, + ) +where + +import Control.Lens (alaf) +import Data.Monoid (Ap (..)) +import qualified Data.Text as T +import Development.IDE (Diagnostic, + HieAstResult, + TcModuleResult) +import Development.IDE.GHC.Compat (DynFlags, + ParsedModule, + ParsedSource) +import Development.IDE.Plugin.CodeAction.ExactPrint (Rewrite, + rewriteToEdit) +import Development.IDE.Plugin.TypeLenses (GlobalBindingTypeSigsResult) +import Development.IDE.Spans.LocalBindings (Bindings) +import Development.IDE.Types.Exports (ExportsMap) +import Development.IDE.Types.Options (IdeOptions) +import Language.LSP.Types (CodeActionKind (CodeActionQuickFix), + TextEdit) +import Retrie (Annotated (astA)) +import Retrie.ExactPrint (annsA) + +-- | A compact representation of 'Language.LSP.Types.CodeAction's +type GhcideCodeActions = [(T.Text, Maybe CodeActionKind, Maybe Bool, [TextEdit])] + +class ToTextEdit a where + toTextEdit :: CodeActionArgs -> a -> [TextEdit] + +instance ToTextEdit TextEdit where + toTextEdit _ = pure + +instance ToTextEdit Rewrite where + toTextEdit CodeActionArgs {..} rw + | Just df <- caaDf, + Just ps <- caaAnnSource, + Right x <- rewriteToEdit df (annsA ps) rw = + x + | otherwise = [] + +instance ToTextEdit a => ToTextEdit [a] where + toTextEdit caa = foldMap (toTextEdit caa) + +instance ToTextEdit a => ToTextEdit (Maybe a) where + toTextEdit caa = maybe [] (toTextEdit caa) + +instance (ToTextEdit a, ToTextEdit b) => ToTextEdit (Either a b) where + toTextEdit caa = either (toTextEdit caa) (toTextEdit caa) + +data CodeActionArgs = CodeActionArgs + { caaExportsMap :: ExportsMap, + caaIdeOptions :: IdeOptions, + caaParsedModule :: Maybe ParsedModule, + caaContents :: Maybe T.Text, + caaDf :: Maybe DynFlags, + caaAnnSource :: Maybe (Annotated ParsedSource), + caaTmr :: Maybe TcModuleResult, + caaHar :: Maybe HieAstResult, + caaBindings :: Maybe Bindings, + caaGblSigs :: Maybe GlobalBindingTypeSigsResult, + caaDiagnostics :: Diagnostic + } + +rewrite :: + Maybe DynFlags -> + Maybe (Annotated ParsedSource) -> + [(T.Text, [Rewrite])] -> + [(T.Text, [TextEdit])] +rewrite (Just df) (Just ps) r + | Right edit <- + (traverse . traverse) + (alaf Ap foldMap (rewriteToEdit df (annsA ps))) + r = + edit +rewrite _ _ _ = [] + +------------------------------------------------------------------------------------------------- + +-- | Given 'CodeActionArgs', @a@ can be converted into the representation of code actions. +-- This class is designed to package functions that produce code actions in "Development.IDE.Plugin.CodeAction". +-- +-- For each field @fld@ of 'CodeActionArgs', we make +-- +-- @@ +-- instance ToCodeAction r => ToCodeAction (fld -> r) +-- @@ +-- +-- where we take the value of @fld@ from 'CodeActionArgs' and then feed it into @(fld -> r)@. +-- If @fld@ is @Maybe a@, we make +-- +-- @@ +-- instance ToCodeAction r => ToCodeAction (Maybe a -> r) +-- instance ToCodeAction r => ToCodeAction (a -> r) +-- @@ +class ToCodeAction a where + toCodeAction :: CodeActionArgs -> a -> GhcideCodeActions + +instance ToCodeAction a => ToCodeAction [a] where + toCodeAction caa = foldMap (toCodeAction caa) + +instance ToCodeAction a => ToCodeAction (Maybe a) where + toCodeAction caa = maybe [] (toCodeAction caa) + +instance ToTextEdit a => ToCodeAction (T.Text, a) where + toCodeAction caa (title, te) = [(title, Just CodeActionQuickFix, Nothing, toTextEdit caa te)] + +instance ToTextEdit a => ToCodeAction (T.Text, CodeActionKind, a) where + toCodeAction caa (title, kind, te) = [(title, Just kind, Nothing, toTextEdit caa te)] + +instance ToTextEdit a => ToCodeAction (T.Text, Bool, a) where + toCodeAction caa (title, isPreferred, te) = [(title, Nothing, Just isPreferred, toTextEdit caa te)] + +instance ToTextEdit a => ToCodeAction (T.Text, CodeActionKind, Bool, a) where + toCodeAction caa (title, kind, isPreferred, te) = [(title, Just kind, Just isPreferred, toTextEdit caa te)] + +------------------------------------------------------------------------------------------------- + +-- | Complement: we can obtain 'ParsedSource' from 'caaAnnSource' +instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where + toCodeAction caa@CodeActionArgs {caaAnnSource = Just ps} f = toCodeAction caa $ f $ astA ps + toCodeAction _ _ = [] + +-- The following boilerplate code can be generated by 'mkInstances'. +-- Now it was commented out with generated code spliced out, +-- because fields of 'CodeActionArgs' don't change frequently. +-- +-- mkInstances :: Name -> DecsQ +-- mkInstances tyConName = +-- reify tyConName >>= \case +-- (TyConI (DataD _ _ _ _ [RecC dataConName tys] _)) -> concat <$> mapM (genForVar dataConName) tys +-- _ -> error "unsupported" +-- where +-- clsType = conT $ mkName "ToCodeAction" +-- methodName = mkName "toCodeAction" +-- tempType = varT $ mkName "r" +-- commonFun dataConName fieldName = +-- funD +-- methodName +-- [ clause +-- [ mkName "caa" +-- `asP` recP +-- dataConName +-- [fieldPat fieldName $ varP (mkName "x")] +-- , varP (mkName "f") +-- ] +-- (normalB [|$(varE methodName) caa $ f x|]) +-- [] +-- ] +-- genForVar dataConName (fieldName, _, ty@(AppT (ConT _maybe) ty')) +-- | _maybe == ''Maybe = +-- do +-- withMaybe <- +-- instanceD +-- (cxt [clsType `appT` tempType]) +-- (clsType `appT` ((arrowT `appT` pure ty) `appT` tempType)) +-- [commonFun dataConName fieldName] +-- withoutMaybe <- +-- instanceD +-- (cxt [clsType `appT` tempType]) +-- (clsType `appT` ((arrowT `appT` pure ty') `appT` tempType)) +-- [ funD +-- methodName +-- [ clause +-- [ mkName "caa" +-- `asP` recP +-- dataConName +-- [fieldPat fieldName $ conP 'Just [varP (mkName "x")]] +-- , varP (mkName "f") +-- ] +-- (normalB [|$(varE methodName) caa $ f x|]) +-- [] +-- , clause [wildP, wildP] (normalB [|[]|]) [] +-- ] +-- ] +-- pure [withMaybe, withoutMaybe] +-- genForVar dataConName (fieldName, _, ty) = +-- pure +-- <$> instanceD +-- (cxt [clsType `appT` tempType]) +-- (clsType `appT` ((arrowT `appT` pure ty) `appT` tempType)) +-- [commonFun dataConName fieldName] + +instance ToCodeAction r => ToCodeAction (ExportsMap -> r) where + toCodeAction caa@CodeActionArgs {caaExportsMap = x} f = + toCodeAction caa $ f x + +instance ToCodeAction r => ToCodeAction (IdeOptions -> r) where + toCodeAction caa@CodeActionArgs {caaIdeOptions = x} f = + toCodeAction caa $ f x + +instance + ToCodeAction r => + ToCodeAction (Maybe ParsedModule -> r) + where + toCodeAction caa@CodeActionArgs {caaParsedModule = x} f = + toCodeAction caa $ f x + +instance ToCodeAction r => ToCodeAction (ParsedModule -> r) where + toCodeAction caa@CodeActionArgs {caaParsedModule = Just x} f = + toCodeAction caa $ f x + toCodeAction _ _ = [] + +instance ToCodeAction r => ToCodeAction (Maybe T.Text -> r) where + toCodeAction caa@CodeActionArgs {caaContents = x} f = + toCodeAction caa $ f x + +instance ToCodeAction r => ToCodeAction (T.Text -> r) where + toCodeAction caa@CodeActionArgs {caaContents = Just x} f = + toCodeAction caa $ f x + toCodeAction _ _ = [] + +instance ToCodeAction r => ToCodeAction (Maybe DynFlags -> r) where + toCodeAction caa@CodeActionArgs {caaDf = x} f = + toCodeAction caa $ f x + +instance ToCodeAction r => ToCodeAction (DynFlags -> r) where + toCodeAction caa@CodeActionArgs {caaDf = Just x} f = + toCodeAction caa $ f x + toCodeAction _ _ = [] + +instance + ToCodeAction r => + ToCodeAction (Maybe (Annotated ParsedSource) -> r) + where + toCodeAction caa@CodeActionArgs {caaAnnSource = x} f = + toCodeAction caa $ f x + +instance + ToCodeAction r => + ToCodeAction (Annotated ParsedSource -> r) + where + toCodeAction caa@CodeActionArgs {caaAnnSource = Just x} f = + toCodeAction caa $ f x + toCodeAction _ _ = [] + +instance + ToCodeAction r => + ToCodeAction (Maybe TcModuleResult -> r) + where + toCodeAction caa@CodeActionArgs {caaTmr = x} f = + toCodeAction caa $ f x + +instance ToCodeAction r => ToCodeAction (TcModuleResult -> r) where + toCodeAction caa@CodeActionArgs {caaTmr = Just x} f = + toCodeAction caa $ f x + toCodeAction _ _ = [] + +instance + ToCodeAction r => + ToCodeAction (Maybe HieAstResult -> r) + where + toCodeAction caa@CodeActionArgs {caaHar = x} f = + toCodeAction caa $ f x + +instance ToCodeAction r => ToCodeAction (HieAstResult -> r) where + toCodeAction caa@CodeActionArgs {caaHar = Just x} f = + toCodeAction caa $ f x + toCodeAction _ _ = [] + +instance ToCodeAction r => ToCodeAction (Maybe Bindings -> r) where + toCodeAction caa@CodeActionArgs {caaBindings = x} f = + toCodeAction caa $ f x + +instance ToCodeAction r => ToCodeAction (Bindings -> r) where + toCodeAction caa@CodeActionArgs {caaBindings = Just x} f = + toCodeAction caa $ f x + toCodeAction _ _ = [] + +instance + ToCodeAction r => + ToCodeAction (Maybe GlobalBindingTypeSigsResult -> r) + where + toCodeAction caa@CodeActionArgs {caaGblSigs = x} f = + toCodeAction caa $ f x + +instance + ToCodeAction r => + ToCodeAction (GlobalBindingTypeSigsResult -> r) + where + toCodeAction caa@CodeActionArgs {caaGblSigs = Just x} f = + toCodeAction caa $ f x + toCodeAction _ _ = [] + +instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where + toCodeAction caa@CodeActionArgs {caaDiagnostics = x} f = + toCodeAction caa $ f x + +------------------------------------------------------------------------------------------------- diff --git a/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs --- a/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -1,435 +1,500 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} - -module Development.IDE.Plugin.CodeAction.ExactPrint - ( Rewrite (..), - rewriteToEdit, - rewriteToWEdit, - transferAnn, - - -- * Utilities - appendConstraint, - extendImport, - hideImplicitPreludeSymbol, - hideSymbol, - liftParseAST, - ) -where - -import Control.Applicative -import Control.Monad -import Control.Monad.Trans -import Data.Char (isAlphaNum) -import Data.Data (Data) -import Data.Functor -import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust, isNothing, mapMaybe) -import qualified Data.Text as T -import Development.IDE.GHC.Compat hiding (parseExpr) -import Development.IDE.GHC.ExactPrint - ( Annotate, ASTElement(parseAST) ) -import FieldLabel (flLabel) -import GhcPlugins (sigPrec, mkRealSrcLoc) -import Language.Haskell.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP), KeywordId (G), mkAnnKey) -import Language.LSP.Types -import OccName -import Outputable (ppr, showSDocUnsafe, showSDoc) -import Retrie.GHC (rdrNameOcc, unpackFS, mkRealSrcSpan, realSrcSpanEnd) -import Development.IDE.Spans.Common -import Development.IDE.GHC.Error -import Data.Generics (listify) -import GHC.Exts (IsList (fromList)) -import Control.Monad.Extra (whenJust) - ------------------------------------------------------------------------------- - --- | Construct a 'Rewrite', replacing the node at the given 'SrcSpan' with the --- given 'ast'. -data Rewrite where - Rewrite :: - Annotate ast => - -- | The 'SrcSpan' that we want to rewrite - SrcSpan -> - -- | The ast that we want to graft - (DynFlags -> TransformT (Either String) (Located ast)) -> - Rewrite - ------------------------------------------------------------------------------- - --- | Convert a 'Rewrite' into a list of '[TextEdit]'. -rewriteToEdit :: - DynFlags -> - Anns -> - Rewrite -> - Either String [TextEdit] -rewriteToEdit dflags anns (Rewrite dst f) = do - (ast, (anns, _), _) <- runTransformT anns $ do - ast <- f dflags - ast <$ setEntryDPT ast (DP (0,0)) - let editMap = [ TextEdit (fromJust $ srcSpanToRange dst) $ - T.pack $ exactPrint ast anns - ] - pure editMap - --- | Convert a 'Rewrite' into a 'WorkspaceEdit' -rewriteToWEdit :: DynFlags -> Uri -> Anns -> Rewrite -> Either String WorkspaceEdit -rewriteToWEdit dflags uri anns r = do - edits <- rewriteToEdit dflags anns r - return $ - WorkspaceEdit - { _changes = Just (fromList [(uri, List edits)]) - , _documentChanges = Nothing - } - ------------------------------------------------------------------------------- - --- | Fix the parentheses around a type context -fixParens :: - (Monad m, Data (HsType pass)) => - Maybe DeltaPos -> - Maybe DeltaPos -> - LHsContext pass -> - TransformT m [LHsType pass] -fixParens openDP closeDP ctxt@(L _ elems) = do - -- Paren annotation for type contexts are usually quite screwed up - -- we remove duplicates and fix negative DPs - modifyAnnsT $ - Map.adjust - ( \x -> - let annsMap = Map.fromList (annsDP x) - in x - { annsDP = - Map.toList $ - Map.alter (\_ -> openDP <|> Just dp00) (G AnnOpenP) $ - Map.alter (\_ -> closeDP <|> Just dp00) (G AnnCloseP) $ - annsMap <> parens - } - ) - (mkAnnKey ctxt) - return $ map dropHsParTy elems - where - parens = Map.fromList [(G AnnOpenP, dp00), (G AnnCloseP, dp00)] - - dropHsParTy :: LHsType pass -> LHsType pass - dropHsParTy (L _ (HsParTy _ ty)) = ty - dropHsParTy other = other - --- | Append a constraint at the end of a type context. --- If no context is present, a new one will be created. -appendConstraint :: - -- | The new constraint to append - String -> - -- | The type signature where the constraint is to be inserted, also assuming annotated - LHsType GhcPs -> - Rewrite -appendConstraint constraintT = go - where - go (L l it@HsQualTy {hst_ctxt = L l' ctxt}) = Rewrite l $ \df -> do - constraint <- liftParseAST df constraintT - setEntryDPT constraint (DP (0, 1)) - - -- Paren annotations are usually attached to the first and last constraints, - -- rather than to the constraint list itself, so to preserve them we need to reposition them - closeParenDP <- lookupAnn (G AnnCloseP) `mapM` lastMaybe ctxt - openParenDP <- lookupAnn (G AnnOpenP) `mapM` headMaybe ctxt - ctxt' <- fixParens (join openParenDP) (join closeParenDP) (L l' ctxt) - - addTrailingCommaT (last ctxt') - - return $ L l $ it {hst_ctxt = L l' $ ctxt' ++ [constraint]} - go (L _ HsForAllTy {hst_body}) = go hst_body - go (L _ (HsParTy _ ty)) = go ty - go (L l other) = Rewrite l $ \df -> do - -- there isn't a context, so we must create one - constraint <- liftParseAST df constraintT - lContext <- uniqueSrcSpanT - lTop <- uniqueSrcSpanT - let context = L lContext [constraint] - addSimpleAnnT context (DP (0, 0)) $ - (G AnnDarrow, DP (0, 1)) - : concat - [ [ (G AnnOpenP, dp00), - (G AnnCloseP, dp00) - ] - | hsTypeNeedsParens sigPrec $ unLoc constraint - ] - return $ L lTop $ HsQualTy noExtField context (L l other) - -liftParseAST :: ASTElement ast => DynFlags -> String -> TransformT (Either String) (Located ast) -liftParseAST df s = case parseAST df "" s of - Right (anns, x) -> modifyAnnsT (anns <>) $> x - Left _ -> lift $ Left $ "No parse: " <> s - -lookupAnn :: (Data a, Monad m) => KeywordId -> Located a -> TransformT m (Maybe DeltaPos) -lookupAnn comment la = do - anns <- getAnnsT - return $ Map.lookup (mkAnnKey la) anns >>= lookup comment . annsDP - -dp00 :: DeltaPos -dp00 = DP (0, 0) - -headMaybe :: [a] -> Maybe a -headMaybe [] = Nothing -headMaybe (a : _) = Just a - -lastMaybe :: [a] -> Maybe a -lastMaybe [] = Nothing -lastMaybe other = Just $ last other - -liftMaybe :: String -> Maybe a -> TransformT (Either String) a -liftMaybe _ (Just x) = return x -liftMaybe s _ = lift $ Left s - --- | Copy anns attached to a into b with modification, then delete anns of a -transferAnn :: (Data a, Data b) => Located a -> Located b -> (Annotation -> Annotation) -> TransformT (Either String) () -transferAnn la lb f = do - anns <- getAnnsT - let oldKey = mkAnnKey la - newKey = mkAnnKey lb - oldValue <- liftMaybe "Unable to find ann" $ Map.lookup oldKey anns - putAnnsT $ Map.delete oldKey $ Map.insert newKey (f oldValue) anns - ------------------------------------------------------------------------------- -extendImport :: Maybe String -> String -> LImportDecl GhcPs -> Rewrite -extendImport mparent identifier lDecl@(L l _) = - Rewrite l $ \df -> do - case mparent of - Just parent -> extendImportViaParent df parent identifier lDecl - _ -> extendImportTopLevel df identifier lDecl - --- | Add an identifier to import list --- --- extendImportTopLevel "foo" AST: --- --- import A --> Error --- import A (foo) --> Error --- import A (bar) --> import A (bar, foo) -extendImportTopLevel :: DynFlags -> String -> LImportDecl GhcPs -> TransformT (Either String) (LImportDecl GhcPs) -extendImportTopLevel df idnetifier (L l it@ImportDecl {..}) - | Just (hide, L l' lies) <- ideclHiding, - hasSibling <- not $ null lies = do - src <- uniqueSrcSpanT - top <- uniqueSrcSpanT - rdr <- liftParseAST df idnetifier - - let alreadyImported = - showNameWithoutUniques (occName (unLoc rdr)) `elem` - map (showNameWithoutUniques @OccName) (listify (const True) lies) - when alreadyImported $ - lift (Left $ idnetifier <> " already imported") - - let lie = L src $ IEName rdr - x = L top $ IEVar noExtField lie - if x `elem` lies then lift (Left $ idnetifier <> " already imported") else do - when hasSibling $ - addTrailingCommaT (last lies) - addSimpleAnnT x (DP (0, if hasSibling then 1 else 0)) [] - addSimpleAnnT rdr dp00 $ unqalDP $ hasParen idnetifier - -- Parens are attachted to `lies`, so if `lies` was empty previously, - -- we need change the ann key from `[]` to `:` to keep parens and other anns. - unless hasSibling $ - transferAnn (L l' lies) (L l' [x]) id - return $ L l it {ideclHiding = Just (hide, L l' $ lies ++ [x])} -extendImportTopLevel _ _ _ = lift $ Left "Unable to extend the import list" - --- | Add an identifier with its parent to import list --- --- extendImportViaParent "Bar" "Cons" AST: --- --- import A --> Error --- import A (Bar(..)) --> Error --- import A (Bar(Cons)) --> Error --- import A () --> import A (Bar(Cons)) --- import A (Foo, Bar) --> import A (Foo, Bar(Cons)) --- import A (Foo, Bar()) --> import A (Foo, Bar(Cons)) -extendImportViaParent :: DynFlags -> String -> String -> LImportDecl GhcPs -> TransformT (Either String) (LImportDecl GhcPs) -extendImportViaParent df parent child (L l it@ImportDecl {..}) - | Just (hide, L l' lies) <- ideclHiding = go hide l' [] lies - where - go :: Bool -> SrcSpan -> [LIE GhcPs] -> [LIE GhcPs] -> TransformT (Either String) (LImportDecl GhcPs) - go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie))) : _xs) - | parent == unIEWrappedName ie = lift . Left $ child <> " already included in " <> parent <> " imports" - go hide l' pre (lAbs@(L ll' (IEThingAbs _ absIE@(L _ ie))) : xs) - -- ThingAbs ie => ThingWith ie child - | parent == unIEWrappedName ie = do - srcChild <- uniqueSrcSpanT - childRdr <- liftParseAST df child - let childLIE = L srcChild $ IEName childRdr - x :: LIE GhcPs = L ll' $ IEThingWith noExtField absIE NoIEWildcard [childLIE] [] - -- take anns from ThingAbs, and attatch parens to it - transferAnn lAbs x $ \old -> old {annsDP = annsDP old ++ [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, dp00)]} - addSimpleAnnT childRdr dp00 [(G AnnVal, dp00)] - return $ L l it {ideclHiding = Just (hide, L l' $ reverse pre ++ [x] ++ xs)} - go hide l' pre ((L l'' (IEThingWith _ twIE@(L _ ie) _ lies' _)) : xs) - -- ThingWith ie lies' => ThingWith ie (lies' ++ [child]) - | parent == unIEWrappedName ie, - hasSibling <- not $ null lies' = - do - srcChild <- uniqueSrcSpanT - childRdr <- liftParseAST df child - - let alreadyImported = - showNameWithoutUniques(occName (unLoc childRdr)) `elem` - map (showNameWithoutUniques @OccName) (listify (const True) lies') - when alreadyImported $ - lift (Left $ child <> " already included in " <> parent <> " imports") - - when hasSibling $ - addTrailingCommaT (last lies') - let childLIE = L srcChild $ IEName childRdr - addSimpleAnnT childRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP $ hasParen child - return $ L l it {ideclHiding = Just (hide, L l' $ reverse pre ++ [L l'' (IEThingWith noExtField twIE NoIEWildcard (lies' ++ [childLIE]) [])] ++ xs)} - go hide l' pre (x : xs) = go hide l' (x : pre) xs - go hide l' pre [] - | hasSibling <- not $ null pre = do - -- [] => ThingWith parent [child] - l'' <- uniqueSrcSpanT - srcParent <- uniqueSrcSpanT - srcChild <- uniqueSrcSpanT - parentRdr <- liftParseAST df parent - childRdr <- liftParseAST df child - when hasSibling $ - addTrailingCommaT (head pre) - let parentLIE = L srcParent $ IEName parentRdr - childLIE = L srcChild $ IEName childRdr - x :: LIE GhcPs = L l'' $ IEThingWith noExtField parentLIE NoIEWildcard [childLIE] [] - addSimpleAnnT parentRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP $ hasParen parent - addSimpleAnnT childRdr (DP (0, 0)) $ unqalDP $ hasParen child - addSimpleAnnT x (DP (0, 0)) [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, DP (0, 0))] - -- Parens are attachted to `pre`, so if `pre` was empty previously, - -- we need change the ann key from `[]` to `:` to keep parens and other anns. - unless hasSibling $ - transferAnn (L l' $ reverse pre) (L l' [x]) id - return $ L l it {ideclHiding = Just (hide, L l' $ reverse pre ++ [x])} -extendImportViaParent _ _ _ _ = lift $ Left "Unable to extend the import list via parent" - -unIEWrappedName :: IEWrappedName (IdP GhcPs) -> String -unIEWrappedName (occName -> occ) = showSDocUnsafe $ parenSymOcc occ (ppr occ) - -hasParen :: String -> Bool -hasParen ('(' : _) = True -hasParen _ = False - -unqalDP :: Bool -> [(KeywordId, DeltaPos)] -unqalDP paren = - ( if paren - then \x -> (G AnnOpenP, dp00) : x : [(G AnnCloseP, dp00)] - else pure - ) - (G AnnVal, dp00) - ------------------------------------------------------------------------------- --- | Hide a symbol from import declaration -hideSymbol :: - String -> LImportDecl GhcPs -> Rewrite -hideSymbol symbol lidecl@(L loc ImportDecl {..}) = - case ideclHiding of - Nothing -> Rewrite loc $ extendHiding symbol lidecl Nothing - Just (True, hides) -> Rewrite loc $ extendHiding symbol lidecl (Just hides) - Just (False, imports) -> Rewrite loc $ deleteFromImport symbol lidecl imports -hideSymbol _ (L _ (XImportDecl _)) = - error "cannot happen" - -extendHiding :: - String -> - LImportDecl GhcPs -> - Maybe (Located [LIE GhcPs]) -> - DynFlags -> - TransformT (Either String) (LImportDecl GhcPs) -extendHiding symbol (L l idecls) mlies df = do - L l' lies <- case mlies of - Nothing -> flip L [] <$> uniqueSrcSpanT - Just pr -> pure pr - let hasSibling = not $ null lies - src <- uniqueSrcSpanT - top <- uniqueSrcSpanT - rdr <- liftParseAST df symbol - let lie = L src $ IEName rdr - x = L top $ IEVar noExtField lie - singleHide = L l' [x] - when (isNothing mlies) $ do - addSimpleAnnT - singleHide - dp00 - [ (G AnnHiding, DP (0, 1)) - , (G AnnOpenP, DP (0, 1)) - , (G AnnCloseP, DP (0, 0)) - ] - addSimpleAnnT x (DP (0, 0)) [] - addSimpleAnnT rdr dp00 $ unqalDP $ isOperator $ unLoc rdr - if hasSibling - then when hasSibling $ do - addTrailingCommaT x - addSimpleAnnT (head lies) (DP (0, 1)) [] - unless (null $ tail lies) $ - addTrailingCommaT (head lies) -- Why we need this? - else forM_ mlies $ \lies0 -> do - transferAnn lies0 singleHide id - return $ L l idecls {ideclHiding = Just (True, L l' $ x : lies)} - where - isOperator = not . all isAlphaNum . occNameString . rdrNameOcc - -deleteFromImport :: - String -> - LImportDecl GhcPs -> - Located [LIE GhcPs] -> - DynFlags -> - TransformT (Either String) (LImportDecl GhcPs) -deleteFromImport (T.pack -> symbol) (L l idecl) llies@(L lieLoc lies) _ =do - let edited = L lieLoc deletedLies - lidecl' = L l $ idecl - { ideclHiding = Just (False, edited) - } - -- avoid import A (foo,) - whenJust (lastMaybe deletedLies) removeTrailingCommaT - when (not (null lies) && null deletedLies) $ do - transferAnn llies edited id - addSimpleAnnT edited dp00 - [(G AnnOpenP, DP (0, 1)) - ,(G AnnCloseP, DP (0,0)) - ] - pure lidecl' - where - deletedLies = - mapMaybe killLie lies - killLie :: LIE GhcPs -> Maybe (LIE GhcPs) - killLie v@(L _ (IEVar _ (L _ (unqualIEWrapName -> nam)))) - | nam == symbol = Nothing - | otherwise = Just v - killLie v@(L _ (IEThingAbs _ (L _ (unqualIEWrapName -> nam)))) - | nam == symbol = Nothing - | otherwise = Just v - - killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons flds)) - | nam == symbol = Nothing - | otherwise = Just $ - L lieL $ IEThingWith xt ty wild - (filter ((/= symbol) . unqualIEWrapName . unLoc) cons) - (filter ((/= symbol) . T.pack . unpackFS . flLabel . unLoc) flds) - killLie v = Just v - --- | Insert a import declaration hiding a symbole from Prelude -hideImplicitPreludeSymbol - :: String -> ParsedSource -> Maybe Rewrite -hideImplicitPreludeSymbol symbol (L _ HsModule{..}) = do - let predLine old = mkRealSrcLoc (srcLocFile old) (srcLocLine old - 1) (srcLocCol old) - existingImpSpan = (fmap (id,) . realSpan . getLoc) =<< lastMaybe hsmodImports - existingDeclSpan = (fmap (predLine, ) . realSpan . getLoc) =<< headMaybe hsmodDecls - (f, s) <- existingImpSpan <|> existingDeclSpan - let beg = f $ realSrcSpanEnd s - indentation = srcSpanStartCol s - ran = RealSrcSpan $ mkRealSrcSpan beg beg - pure $ Rewrite ran $ \df -> do - let symOcc = mkVarOcc symbol - symImp = T.pack $ showSDoc df $ parenSymOcc symOcc $ ppr symOcc - impStmt = "import Prelude hiding (" <> symImp <> ")" - - -- Re-labeling is needed to reflect annotations correctly - L _ idecl0 <- liftParseAST @(ImportDecl GhcPs) df $ T.unpack impStmt - let idecl = L ran idecl0 - addSimpleAnnT idecl (DP (1, indentation - 1)) - [(G AnnImport, DP (1, indentation - 1))] - pure idecl +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Development.IDE.Plugin.CodeAction.ExactPrint ( + Rewrite (..), + rewriteToEdit, + rewriteToWEdit, + transferAnn, + + -- * Utilities + appendConstraint, + extendImport, + hideImplicitPreludeSymbol, + hideSymbol, + liftParseAST, + newImport, + newUnqualImport, + newImportAll, +) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Extra (whenJust) +import Control.Monad.Trans +import Data.Char (isAlphaNum) +import Data.Data (Data) +import Data.Functor +import Data.Generics (listify) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust, isNothing, + mapMaybe) +import qualified Data.Text as T +import Development.IDE.GHC.Compat hiding (parseExpr) +import Development.IDE.GHC.Error +import Development.IDE.GHC.ExactPrint (ASTElement (parseAST), + Annotate) +import Development.IDE.Spans.Common +import FieldLabel (flLabel) +import GHC.Exts (IsList (fromList)) +import GhcPlugins (mkRealSrcLoc, + realSrcSpanStart, + sigPrec) +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP), + KeywordId (G), mkAnnKey) +import Language.LSP.Types +import OccName +import Outputable (ppr, showSDoc, + showSDocUnsafe) +import Retrie.GHC (mkRealSrcSpan, + rdrNameOcc, + realSrcSpanEnd, + unpackFS) + +------------------------------------------------------------------------------ + +-- | Construct a 'Rewrite', replacing the node at the given 'SrcSpan' with the +-- given 'ast'. +data Rewrite where + Rewrite :: + Annotate ast => + -- | The 'SrcSpan' that we want to rewrite + SrcSpan -> + -- | The ast that we want to graft + (DynFlags -> TransformT (Either String) (Located ast)) -> + Rewrite + +------------------------------------------------------------------------------ + +-- | Convert a 'Rewrite' into a list of '[TextEdit]'. +rewriteToEdit :: + DynFlags -> + Anns -> + Rewrite -> + Either String [TextEdit] +rewriteToEdit dflags anns (Rewrite dst f) = do + (ast, (anns, _), _) <- runTransformT anns $ do + ast <- f dflags + ast <$ setEntryDPT ast (DP (0, 0)) + let editMap = + [ TextEdit (fromJust $ srcSpanToRange dst) $ + T.pack $ exactPrint ast anns + ] + pure editMap + +-- | Convert a 'Rewrite' into a 'WorkspaceEdit' +rewriteToWEdit :: DynFlags -> Uri -> Anns -> Rewrite -> Either String WorkspaceEdit +rewriteToWEdit dflags uri anns r = do + edits <- rewriteToEdit dflags anns r + return $ + WorkspaceEdit + { _changes = Just (fromList [(uri, List edits)]) + , _documentChanges = Nothing + } + +------------------------------------------------------------------------------ + +-- | Fix the parentheses around a type context +fixParens :: + (Monad m, Data (HsType pass)) => + Maybe DeltaPos -> + Maybe DeltaPos -> + LHsContext pass -> + TransformT m [LHsType pass] +fixParens openDP closeDP ctxt@(L _ elems) = do + -- Paren annotation for type contexts are usually quite screwed up + -- we remove duplicates and fix negative DPs + modifyAnnsT $ + Map.adjust + ( \x -> + let annsMap = Map.fromList (annsDP x) + in x + { annsDP = + Map.toList $ + Map.alter (\_ -> openDP <|> Just dp00) (G AnnOpenP) $ + Map.alter (\_ -> closeDP <|> Just dp00) (G AnnCloseP) $ + annsMap <> parens + } + ) + (mkAnnKey ctxt) + return $ map dropHsParTy elems + where + parens = Map.fromList [(G AnnOpenP, dp00), (G AnnCloseP, dp00)] + + dropHsParTy :: LHsType pass -> LHsType pass + dropHsParTy (L _ (HsParTy _ ty)) = ty + dropHsParTy other = other + +-- | Append a constraint at the end of a type context. +-- If no context is present, a new one will be created. +appendConstraint :: + -- | The new constraint to append + String -> + -- | The type signature where the constraint is to be inserted, also assuming annotated + LHsType GhcPs -> + Rewrite +appendConstraint constraintT = go + where + go (L l it@HsQualTy{hst_ctxt = L l' ctxt}) = Rewrite l $ \df -> do + constraint <- liftParseAST df constraintT + setEntryDPT constraint (DP (0, 1)) + + -- Paren annotations are usually attached to the first and last constraints, + -- rather than to the constraint list itself, so to preserve them we need to reposition them + closeParenDP <- lookupAnn (G AnnCloseP) `mapM` lastMaybe ctxt + openParenDP <- lookupAnn (G AnnOpenP) `mapM` headMaybe ctxt + ctxt' <- fixParens (join openParenDP) (join closeParenDP) (L l' ctxt) + + addTrailingCommaT (last ctxt') + + return $ L l $ it{hst_ctxt = L l' $ ctxt' ++ [constraint]} + go (L _ HsForAllTy{hst_body}) = go hst_body + go (L _ (HsParTy _ ty)) = go ty + go (L l other) = Rewrite l $ \df -> do + -- there isn't a context, so we must create one + constraint <- liftParseAST df constraintT + lContext <- uniqueSrcSpanT + lTop <- uniqueSrcSpanT + let context = L lContext [constraint] + addSimpleAnnT context (DP (0, 0)) $ + (G AnnDarrow, DP (0, 1)) : + concat + [ [ (G AnnOpenP, dp00) + , (G AnnCloseP, dp00) + ] + | hsTypeNeedsParens sigPrec $ unLoc constraint + ] + return $ L lTop $ HsQualTy noExtField context (L l other) + +liftParseAST :: ASTElement ast => DynFlags -> String -> TransformT (Either String) (Located ast) +liftParseAST df s = case parseAST df "" s of + Right (anns, x) -> modifyAnnsT (anns <>) $> x + Left _ -> lift $ Left $ "No parse: " <> s + +lookupAnn :: (Data a, Monad m) => KeywordId -> Located a -> TransformT m (Maybe DeltaPos) +lookupAnn comment la = do + anns <- getAnnsT + return $ Map.lookup (mkAnnKey la) anns >>= lookup comment . annsDP + +dp00 :: DeltaPos +dp00 = DP (0, 0) + +headMaybe :: [a] -> Maybe a +headMaybe [] = Nothing +headMaybe (a : _) = Just a + +lastMaybe :: [a] -> Maybe a +lastMaybe [] = Nothing +lastMaybe other = Just $ last other + +liftMaybe :: String -> Maybe a -> TransformT (Either String) a +liftMaybe _ (Just x) = return x +liftMaybe s _ = lift $ Left s + +-- | Copy anns attached to a into b with modification, then delete anns of a +transferAnn :: (Data a, Data b) => Located a -> Located b -> (Annotation -> Annotation) -> TransformT (Either String) () +transferAnn la lb f = do + anns <- getAnnsT + let oldKey = mkAnnKey la + newKey = mkAnnKey lb + oldValue <- liftMaybe "Unable to find ann" $ Map.lookup oldKey anns + putAnnsT $ Map.delete oldKey $ Map.insert newKey (f oldValue) anns + +------------------------------------------------------------------------------ +extendImport :: Maybe String -> String -> LImportDecl GhcPs -> Rewrite +extendImport mparent identifier lDecl@(L l _) = + Rewrite l $ \df -> do + case mparent of + Just parent -> extendImportViaParent df parent identifier lDecl + _ -> extendImportTopLevel df identifier lDecl + +-- | Add an identifier to import list +-- +-- extendImportTopLevel "foo" AST: +-- +-- import A --> Error +-- import A (foo) --> Error +-- import A (bar) --> import A (bar, foo) +extendImportTopLevel :: DynFlags -> String -> LImportDecl GhcPs -> TransformT (Either String) (LImportDecl GhcPs) +extendImportTopLevel df idnetifier (L l it@ImportDecl{..}) + | Just (hide, L l' lies) <- ideclHiding + , hasSibling <- not $ null lies = do + src <- uniqueSrcSpanT + top <- uniqueSrcSpanT + rdr <- liftParseAST df idnetifier + + let alreadyImported = + showNameWithoutUniques (occName (unLoc rdr)) + `elem` map (showNameWithoutUniques @OccName) (listify (const True) lies) + when alreadyImported $ + lift (Left $ idnetifier <> " already imported") + + let lie = L src $ IEName rdr + x = L top $ IEVar noExtField lie + if x `elem` lies + then lift (Left $ idnetifier <> " already imported") + else do + when hasSibling $ + addTrailingCommaT (last lies) + addSimpleAnnT x (DP (0, if hasSibling then 1 else 0)) [] + addSimpleAnnT rdr dp00 $ unqalDP $ hasParen idnetifier + -- Parens are attachted to `lies`, so if `lies` was empty previously, + -- we need change the ann key from `[]` to `:` to keep parens and other anns. + unless hasSibling $ + transferAnn (L l' lies) (L l' [x]) id + return $ L l it{ideclHiding = Just (hide, L l' $ lies ++ [x])} +extendImportTopLevel _ _ _ = lift $ Left "Unable to extend the import list" + +-- | Add an identifier with its parent to import list +-- +-- extendImportViaParent "Bar" "Cons" AST: +-- +-- import A --> Error +-- import A (Bar(..)) --> Error +-- import A (Bar(Cons)) --> Error +-- import A () --> import A (Bar(Cons)) +-- import A (Foo, Bar) --> import A (Foo, Bar(Cons)) +-- import A (Foo, Bar()) --> import A (Foo, Bar(Cons)) +extendImportViaParent :: DynFlags -> String -> String -> LImportDecl GhcPs -> TransformT (Either String) (LImportDecl GhcPs) +extendImportViaParent df parent child (L l it@ImportDecl{..}) + | Just (hide, L l' lies) <- ideclHiding = go hide l' [] lies + where + go :: Bool -> SrcSpan -> [LIE GhcPs] -> [LIE GhcPs] -> TransformT (Either String) (LImportDecl GhcPs) + go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie))) : _xs) + | parent == unIEWrappedName ie = lift . Left $ child <> " already included in " <> parent <> " imports" + go hide l' pre (lAbs@(L ll' (IEThingAbs _ absIE@(L _ ie))) : xs) + -- ThingAbs ie => ThingWith ie child + | parent == unIEWrappedName ie = do + srcChild <- uniqueSrcSpanT + childRdr <- liftParseAST df child + let childLIE = L srcChild $ IEName childRdr + x :: LIE GhcPs = L ll' $ IEThingWith noExtField absIE NoIEWildcard [childLIE] [] + -- take anns from ThingAbs, and attatch parens to it + transferAnn lAbs x $ \old -> old{annsDP = annsDP old ++ [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, dp00)]} + addSimpleAnnT childRdr dp00 [(G AnnVal, dp00)] + return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [x] ++ xs)} + go hide l' pre ((L l'' (IEThingWith _ twIE@(L _ ie) _ lies' _)) : xs) + -- ThingWith ie lies' => ThingWith ie (lies' ++ [child]) + | parent == unIEWrappedName ie + , hasSibling <- not $ null lies' = + do + srcChild <- uniqueSrcSpanT + childRdr <- liftParseAST df child + + let alreadyImported = + showNameWithoutUniques (occName (unLoc childRdr)) + `elem` map (showNameWithoutUniques @OccName) (listify (const True) lies') + when alreadyImported $ + lift (Left $ child <> " already included in " <> parent <> " imports") + + when hasSibling $ + addTrailingCommaT (last lies') + let childLIE = L srcChild $ IEName childRdr + addSimpleAnnT childRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP $ hasParen child + return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [L l'' (IEThingWith noExtField twIE NoIEWildcard (lies' ++ [childLIE]) [])] ++ xs)} + go hide l' pre (x : xs) = go hide l' (x : pre) xs + go hide l' pre [] + | hasSibling <- not $ null pre = do + -- [] => ThingWith parent [child] + l'' <- uniqueSrcSpanT + srcParent <- uniqueSrcSpanT + srcChild <- uniqueSrcSpanT + parentRdr <- liftParseAST df parent + childRdr <- liftParseAST df child + when hasSibling $ + addTrailingCommaT (head pre) + let parentLIE = L srcParent $ IEName parentRdr + childLIE = L srcChild $ IEName childRdr + x :: LIE GhcPs = L l'' $ IEThingWith noExtField parentLIE NoIEWildcard [childLIE] [] + addSimpleAnnT parentRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP $ hasParen parent + addSimpleAnnT childRdr (DP (0, 0)) $ unqalDP $ hasParen child + addSimpleAnnT x (DP (0, 0)) [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, DP (0, 0))] + -- Parens are attachted to `pre`, so if `pre` was empty previously, + -- we need change the ann key from `[]` to `:` to keep parens and other anns. + unless hasSibling $ + transferAnn (L l' $ reverse pre) (L l' [x]) id + return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [x])} +extendImportViaParent _ _ _ _ = lift $ Left "Unable to extend the import list via parent" + +unIEWrappedName :: IEWrappedName (IdP GhcPs) -> String +unIEWrappedName (occName -> occ) = showSDocUnsafe $ parenSymOcc occ (ppr occ) + +hasParen :: String -> Bool +hasParen ('(' : _) = True +hasParen _ = False + +unqalDP :: Bool -> [(KeywordId, DeltaPos)] +unqalDP paren = + ( if paren + then \x -> (G AnnOpenP, dp00) : x : [(G AnnCloseP, dp00)] + else pure + ) + (G AnnVal, dp00) + +------------------------------------------------------------------------------ + +-- | Hide a symbol from import declaration +hideSymbol :: + String -> LImportDecl GhcPs -> Rewrite +hideSymbol symbol lidecl@(L loc ImportDecl{..}) = + case ideclHiding of + Nothing -> Rewrite loc $ extendHiding symbol lidecl Nothing + Just (True, hides) -> Rewrite loc $ extendHiding symbol lidecl (Just hides) + Just (False, imports) -> Rewrite loc $ deleteFromImport symbol lidecl imports +hideSymbol _ (L _ (XImportDecl _)) = + error "cannot happen" + +extendHiding :: + String -> + LImportDecl GhcPs -> + Maybe (Located [LIE GhcPs]) -> + DynFlags -> + TransformT (Either String) (LImportDecl GhcPs) +extendHiding symbol (L l idecls) mlies df = do + L l' lies <- case mlies of + Nothing -> flip L [] <$> uniqueSrcSpanT + Just pr -> pure pr + let hasSibling = not $ null lies + src <- uniqueSrcSpanT + top <- uniqueSrcSpanT + rdr <- liftParseAST df symbol + let lie = L src $ IEName rdr + x = L top $ IEVar noExtField lie + singleHide = L l' [x] + when (isNothing mlies) $ do + addSimpleAnnT + singleHide + dp00 + [ (G AnnHiding, DP (0, 1)) + , (G AnnOpenP, DP (0, 1)) + , (G AnnCloseP, DP (0, 0)) + ] + addSimpleAnnT x (DP (0, 0)) [] + addSimpleAnnT rdr dp00 $ unqalDP $ isOperator $ unLoc rdr + if hasSibling + then when hasSibling $ do + addTrailingCommaT x + addSimpleAnnT (head lies) (DP (0, 1)) [] + unless (null $ tail lies) $ + addTrailingCommaT (head lies) -- Why we need this? + else forM_ mlies $ \lies0 -> do + transferAnn lies0 singleHide id + return $ L l idecls{ideclHiding = Just (True, L l' $ x : lies)} + where + isOperator = not . all isAlphaNum . occNameString . rdrNameOcc + +deleteFromImport :: + String -> + LImportDecl GhcPs -> + Located [LIE GhcPs] -> + DynFlags -> + TransformT (Either String) (LImportDecl GhcPs) +deleteFromImport (T.pack -> symbol) (L l idecl) llies@(L lieLoc lies) _ = do + let edited = L lieLoc deletedLies + lidecl' = + L l $ + idecl + { ideclHiding = Just (False, edited) + } + -- avoid import A (foo,) + whenJust (lastMaybe deletedLies) removeTrailingCommaT + when (not (null lies) && null deletedLies) $ do + transferAnn llies edited id + addSimpleAnnT + edited + dp00 + [ (G AnnOpenP, DP (0, 1)) + , (G AnnCloseP, DP (0, 0)) + ] + pure lidecl' + where + deletedLies = + mapMaybe killLie lies + killLie :: LIE GhcPs -> Maybe (LIE GhcPs) + killLie v@(L _ (IEVar _ (L _ (unqualIEWrapName -> nam)))) + | nam == symbol = Nothing + | otherwise = Just v + killLie v@(L _ (IEThingAbs _ (L _ (unqualIEWrapName -> nam)))) + | nam == symbol = Nothing + | otherwise = Just v + killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons flds)) + | nam == symbol = Nothing + | otherwise = + Just $ + L lieL $ + IEThingWith + xt + ty + wild + (filter ((/= symbol) . unqualIEWrapName . unLoc) cons) + (filter ((/= symbol) . T.pack . unpackFS . flLabel . unLoc) flds) + killLie v = Just v + +-- | Insert a import declaration with at most one symbol + +-- newImport "A" (Just "Bar(Cons)") Nothing False --> import A (Bar(Cons)) +-- newImport "A" (Just "foo") Nothing True --> import A hiding (foo) +-- newImport "A" Nothing (Just "Q") False --> import qualified A as Q +-- +-- Wrong combinations will result in parse error +-- Returns Nothing if there is no imports and declarations +newImport :: + -- | module name + String -> + -- | the symbol + Maybe String -> + -- | whether to be qualified + Maybe String -> + -- | the symbol is to be imported or hidden + Bool -> + ParsedSource -> + Maybe Rewrite +newImport modName mSymbol mQual hiding (L _ HsModule{..}) = do + -- TODO (berberman): if the previous line is module name and there is no other imports, + -- 'AnnWhere' will be crowded out to the next line, which is a bug + let predLine old = + mkRealSrcLoc + (srcLocFile old) + (srcLocLine old - 1) + (srcLocCol old) + existingImpSpan = (fmap (realSrcSpanEnd,) . realSpan . getLoc) =<< lastMaybe hsmodImports + existingDeclSpan = (fmap (predLine . realSrcSpanStart,) . realSpan . getLoc) =<< headMaybe hsmodDecls + (f, s) <- existingImpSpan <|> existingDeclSpan + let beg = f s + indentation = srcSpanStartCol s + ran = RealSrcSpan $ mkRealSrcSpan beg beg + pure $ + Rewrite ran $ \df -> do + let symImp + | Just symbol <- mSymbol + , symOcc <- mkVarOcc symbol = + "(" <> showSDoc df (parenSymOcc symOcc $ ppr symOcc) <> ")" + | otherwise = "" + impStmt = + "import " + <> maybe "" (const "qualified ") mQual + <> modName + <> (if hiding then " hiding " else " ") + <> symImp + <> maybe "" (" as " <>) mQual + -- Re-labeling is needed to reflect annotations correctly + L _ idecl0 <- liftParseAST @(ImportDecl GhcPs) df impStmt + let idecl = L ran idecl0 + addSimpleAnnT + idecl + (DP (1, indentation - 1)) + [(G AnnImport, DP (1, indentation - 1))] + pure idecl + +newUnqualImport :: String -> String -> Bool -> ParsedSource -> Maybe Rewrite +newUnqualImport modName symbol = newImport modName (Just symbol) Nothing + +newImportAll :: String -> ParsedSource -> Maybe Rewrite +newImportAll modName = newImport modName Nothing Nothing False + +-- | Insert "import Prelude hiding (symbol)" +hideImplicitPreludeSymbol :: String -> ParsedSource -> Maybe Rewrite +hideImplicitPreludeSymbol symbol = newUnqualImport "Prelude" symbol True diff --git a/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs b/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs --- a/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs +++ b/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs @@ -1,140 +1,140 @@ --- | Position indexed streams of characters -module Development.IDE.Plugin.CodeAction.PositionIndexed - ( PositionIndexed - , PositionIndexedString - , indexedByPosition - , indexedByPositionStartingFrom - , extendAllToIncludeCommaIfPossible - , extendToIncludePreviousNewlineIfPossible - , mergeRanges - ) -where - -import Data.Char -import Data.List -import Language.LSP.Types - -type PositionIndexed a = [(Position, a)] - -type PositionIndexedString = PositionIndexed Char - --- | Add position indexing to a String. --- --- > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡ --- > [ ((0,0),'h') --- > , ((0,1),'e') --- > , ((0,2),'y') --- > , ((0,3),'\n') --- > , ((1,0),' ') --- > , ((1,1),'h') --- > , ((1,2),'o') --- > ] -indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString -indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where - f (_, []) = Nothing - f (p@(Position l _), '\n' : rest) = - Just ((p, '\n'), (Position (l + 1) 0, rest)) - f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest)) - --- | Add position indexing to a String. --- --- > indexedByPosition = indexedByPositionStartingFrom (Position 0 0) -indexedByPosition :: String -> PositionIndexedString -indexedByPosition = indexedByPositionStartingFrom (Position 0 0) - --- | Returns a tuple (before, contents, after) if the range is present. --- The range is present only if both its start and end positions are present -unconsRange - :: Range - -> PositionIndexed a - -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a) -unconsRange Range {..} indexedString - | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString - , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest - = Just (before, mid, after) - | otherwise - = Nothing - --- | Strips out all the positions included in the range. --- Returns 'Nothing' if the start or end of the range are not included in the input. -stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a) -stripRange r s = case unconsRange r s of - Just (b, _, a) -> Just (b ++ a) - Nothing -> Nothing - --- | Returns the smallest possible set of disjoint ranges that is equivalent to the input. --- Assumes input ranges are sorted on the start positions. -mergeRanges :: [Range] -> [Range] -mergeRanges (r : r' : rest) - | - -- r' is contained in r - _end r > _end r' = mergeRanges (r : rest) - | - -- r and r' are overlapping - _end r > _start r' = mergeRanges (r { _end = _end r' } : rest) - - | otherwise = r : mergeRanges (r' : rest) -mergeRanges other = other - --- | Returns a sorted list of ranges with extended selections including preceding or trailing commas --- --- @ --- a, |b|, c ===> a|, b|, c --- a, b, |c| ===> a, b|, c| --- a, |b|, |c| ===> a|, b||, c| --- @ --- --- If 'acceptNoComma' is enabled, additional ranges are returned --- --- @ --- |a| ===> |a| --- |a|, |b| ===> |a,| |b| --- @ -extendAllToIncludeCommaIfPossible :: Bool -> PositionIndexedString -> [Range] -> [Range] -extendAllToIncludeCommaIfPossible acceptNoComma indexedString = - mergeRanges . go indexedString . sortOn _start - where - go _ [] = [] - go input (r : rr) - | r' : _ <- extendToIncludeCommaIfPossible acceptNoComma input r - , Just input' <- stripRange r' input - = r' : go input' rr - | otherwise - = go input rr - -extendToIncludeCommaIfPossible :: Bool -> PositionIndexedString -> Range -> [Range] -extendToIncludeCommaIfPossible acceptNoComma indexedString range - | Just (before, _, after) <- unconsRange range indexedString - , after' <- dropWhile (isSpace . snd) after - , before' <- dropWhile (isSpace . snd) (reverse before) - = - -- a, |b|, c ===> a|, b|, c - [ range { _start = start' } | (start', ',') : _ <- [before'] ] - ++ - -- a, |b|, c ===> a, |b, |c - [ range { _end = end' } - | (_, ',') : rest <- [after'] - , (end', _) : _ <- pure $ dropWhile (isSpace . snd) rest - ] - ++ - ([range | acceptNoComma]) - | otherwise - = [range] - -extendToIncludePreviousNewlineIfPossible :: PositionIndexedString -> Range -> Range -extendToIncludePreviousNewlineIfPossible indexedString range - | Just (before, _, _) <- unconsRange range indexedString - , maybeFirstSpacePos <- lastSpacePos $ reverse before - = case maybeFirstSpacePos of - Nothing -> range - Just pos -> range { _start = pos } - | otherwise = range - where - lastSpacePos :: PositionIndexedString -> Maybe Position - lastSpacePos [] = Nothing - lastSpacePos ((pos, c):xs) = - if not $ isSpace c - then Nothing -- didn't find any space - else case xs of - (y:ys) | isSpace $ snd y -> lastSpacePos (y:ys) - _ -> Just pos +-- | Position indexed streams of characters +module Development.IDE.Plugin.CodeAction.PositionIndexed + ( PositionIndexed + , PositionIndexedString + , indexedByPosition + , indexedByPositionStartingFrom + , extendAllToIncludeCommaIfPossible + , extendToIncludePreviousNewlineIfPossible + , mergeRanges + ) +where + +import Data.Char +import Data.List +import Language.LSP.Types + +type PositionIndexed a = [(Position, a)] + +type PositionIndexedString = PositionIndexed Char + +-- | Add position indexing to a String. +-- +-- > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡ +-- > [ ((0,0),'h') +-- > , ((0,1),'e') +-- > , ((0,2),'y') +-- > , ((0,3),'\n') +-- > , ((1,0),' ') +-- > , ((1,1),'h') +-- > , ((1,2),'o') +-- > ] +indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString +indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where + f (_, []) = Nothing + f (p@(Position l _), '\n' : rest) = + Just ((p, '\n'), (Position (l + 1) 0, rest)) + f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest)) + +-- | Add position indexing to a String. +-- +-- > indexedByPosition = indexedByPositionStartingFrom (Position 0 0) +indexedByPosition :: String -> PositionIndexedString +indexedByPosition = indexedByPositionStartingFrom (Position 0 0) + +-- | Returns a tuple (before, contents, after) if the range is present. +-- The range is present only if both its start and end positions are present +unconsRange + :: Range + -> PositionIndexed a + -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a) +unconsRange Range {..} indexedString + | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString + , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest + = Just (before, mid, after) + | otherwise + = Nothing + +-- | Strips out all the positions included in the range. +-- Returns 'Nothing' if the start or end of the range are not included in the input. +stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a) +stripRange r s = case unconsRange r s of + Just (b, _, a) -> Just (b ++ a) + Nothing -> Nothing + +-- | Returns the smallest possible set of disjoint ranges that is equivalent to the input. +-- Assumes input ranges are sorted on the start positions. +mergeRanges :: [Range] -> [Range] +mergeRanges (r : r' : rest) + | + -- r' is contained in r + _end r > _end r' = mergeRanges (r : rest) + | + -- r and r' are overlapping + _end r > _start r' = mergeRanges (r { _end = _end r' } : rest) + + | otherwise = r : mergeRanges (r' : rest) +mergeRanges other = other + +-- | Returns a sorted list of ranges with extended selections including preceding or trailing commas +-- +-- @ +-- a, |b|, c ===> a|, b|, c +-- a, b, |c| ===> a, b|, c| +-- a, |b|, |c| ===> a|, b||, c| +-- @ +-- +-- If 'acceptNoComma' is enabled, additional ranges are returned +-- +-- @ +-- |a| ===> |a| +-- |a|, |b| ===> |a,| |b| +-- @ +extendAllToIncludeCommaIfPossible :: Bool -> PositionIndexedString -> [Range] -> [Range] +extendAllToIncludeCommaIfPossible acceptNoComma indexedString = + mergeRanges . go indexedString . sortOn _start + where + go _ [] = [] + go input (r : rr) + | r' : _ <- extendToIncludeCommaIfPossible acceptNoComma input r + , Just input' <- stripRange r' input + = r' : go input' rr + | otherwise + = go input rr + +extendToIncludeCommaIfPossible :: Bool -> PositionIndexedString -> Range -> [Range] +extendToIncludeCommaIfPossible acceptNoComma indexedString range + | Just (before, _, after) <- unconsRange range indexedString + , after' <- dropWhile (isSpace . snd) after + , before' <- dropWhile (isSpace . snd) (reverse before) + = + -- a, |b|, c ===> a|, b|, c + [ range { _start = start' } | (start', ',') : _ <- [before'] ] + ++ + -- a, |b|, c ===> a, |b, |c + [ range { _end = end' } + | (_, ',') : rest <- [after'] + , (end', _) : _ <- pure $ dropWhile (isSpace . snd) rest + ] + ++ + ([range | acceptNoComma]) + | otherwise + = [range] + +extendToIncludePreviousNewlineIfPossible :: PositionIndexedString -> Range -> Range +extendToIncludePreviousNewlineIfPossible indexedString range + | Just (before, _, _) <- unconsRange range indexedString + , maybeFirstSpacePos <- lastSpacePos $ reverse before + = case maybeFirstSpacePos of + Nothing -> range + Just pos -> range { _start = pos } + | otherwise = range + where + lastSpacePos :: PositionIndexedString -> Maybe Position + lastSpacePos [] = Nothing + lastSpacePos ((pos, c):xs) = + if not $ isSpace c + then Nothing -- didn't find any space + else case xs of + (y:ys) | isSpace $ snd y -> lastSpacePos (y:ys) + _ -> Just pos diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs --- a/src/Development/IDE/Plugin/Completions.hs +++ b/src/Development/IDE/Plugin/Completions.hs @@ -1,204 +1,204 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -#include "ghc-api-version.h" - -module Development.IDE.Plugin.Completions - ( descriptor - , LocalCompletions(..) - , NonLocalCompletions(..) - ) where - -import Control.Concurrent.Async (concurrently) -import Control.Monad -import Control.Monad.Extra -import Control.Monad.Trans.Maybe -import Data.Aeson -import Data.List (find) -import Data.Maybe -import qualified Data.Text as T -import Development.IDE.Core.PositionMapping -import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Service -import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat -import Development.IDE.GHC.Error (rangeToSrcSpan) -import Development.IDE.GHC.ExactPrint (Annotated (annsA), - GetAnnotatedParsedSource (GetAnnotatedParsedSource)) -import Development.IDE.GHC.Util (prettyPrint) -import Development.IDE.Plugin.CodeAction.ExactPrint -import Development.IDE.Plugin.Completions.Logic -import Development.IDE.Plugin.Completions.Types -import Development.IDE.Types.HscEnvEq (hscEnv) -import Development.IDE.Types.Location -import Development.Shake -import Development.Shake.Classes -import GHC.Exts (toList) -import GHC.Generics -import Ide.Plugin.Config (Config (completionSnippetsOn)) -import Ide.Types -import qualified Language.LSP.Server as LSP -import Language.LSP.Types -import qualified Language.LSP.VFS as VFS -import TcRnDriver (tcRnImportDecls) - -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) - { pluginRules = produceCompletions - , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP - , pluginCommands = [extendImportCommand] - } - -produceCompletions :: Rules () -produceCompletions = do - define $ \LocalCompletions file -> do - let uri = fromNormalizedUri $ normalizedFilePathToUri file - pm <- useWithStale GetParsedModule file - case pm of - Just (pm, _) -> do - let cdata = localCompletionsForParsedModule uri pm - return ([], Just cdata) - _ -> return ([], Nothing) - define $ \NonLocalCompletions file -> do - -- For non local completions we avoid depending on the parsed module, - -- synthetizing a fake module with an empty body from the buffer - -- in the ModSummary, which preserves all the imports - ms <- fmap fst <$> useWithStale GetModSummaryWithoutTimestamps file - sess <- fmap fst <$> useWithStale GhcSessionDeps file - - case (ms, sess) of - (Just (ms,imps), Just sess) -> do - let env = hscEnv sess - -- We do this to be able to provide completions of items that are not restricted to the explicit list - (global, inScope) <- liftIO $ tcRnImportDecls env (dropListFromImportDecl <$> imps) `concurrently` tcRnImportDecls env imps - case (global, inScope) of - ((_, Just globalEnv), (_, Just inScopeEnv)) -> do - let uri = fromNormalizedUri $ normalizedFilePathToUri file - cdata <- liftIO $ cacheDataProducer uri sess (ms_mod ms) globalEnv inScopeEnv imps - return ([], Just cdata) - (_diag, _) -> - return ([], Nothing) - _ -> return ([], Nothing) - --- Drop any explicit imports in ImportDecl if not hidden -dropListFromImportDecl :: GenLocated SrcSpan (ImportDecl GhcPs) -> GenLocated SrcSpan (ImportDecl GhcPs) -dropListFromImportDecl iDecl = let - f d@ImportDecl {ideclHiding} = case ideclHiding of - Just (False, _) -> d {ideclHiding=Nothing} - -- if hiding or Nothing just return d - _ -> d - f x = x - in f <$> iDecl - --- | Produce completions info for a file -type instance RuleResult LocalCompletions = CachedCompletions -type instance RuleResult NonLocalCompletions = CachedCompletions - -data LocalCompletions = LocalCompletions - deriving (Eq, Show, Typeable, Generic) -instance Hashable LocalCompletions -instance NFData LocalCompletions -instance Binary LocalCompletions - -data NonLocalCompletions = NonLocalCompletions - deriving (Eq, Show, Typeable, Generic) -instance Hashable NonLocalCompletions -instance NFData NonLocalCompletions -instance Binary NonLocalCompletions - --- | Generate code actions. -getCompletionsLSP - :: IdeState - -> PluginId - -> CompletionParams - -> LSP.LspM Config (Either ResponseError (ResponseResult TextDocumentCompletion)) -getCompletionsLSP ide plId - CompletionParams{_textDocument=TextDocumentIdentifier uri - ,_position=position - ,_context=completionContext} = do - contents <- LSP.getVirtualFile $ toNormalizedUri uri - fmap Right $ case (contents, uriToFilePath' uri) of - (Just cnts, Just path) -> do - let npath = toNormalizedFilePath' path - (ideOpts, compls) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do - opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide - localCompls <- useWithStaleFast LocalCompletions npath - nonLocalCompls <- useWithStaleFast NonLocalCompletions npath - pm <- useWithStaleFast GetParsedModule npath - binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath - pure (opts, fmap (,pm,binds) ((fst <$> localCompls) <> (fst <$> nonLocalCompls))) - case compls of - Just (cci', parsedMod, bindMap) -> do - pfix <- VFS.getCompletionPrefix position cnts - case (pfix, completionContext) of - (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."}) - -> return (InL $ List []) - (Just pfix', _) -> do - let clientCaps = clientCapabilities $ shakeExtras ide - config <- getClientConfig $ shakeExtras ide - let snippets = WithSnippets . completionSnippetsOn $ config - allCompletions <- liftIO $ getCompletions plId ideOpts cci' parsedMod bindMap pfix' clientCaps snippets - pure $ InL (List allCompletions) - _ -> return (InL $ List []) - _ -> return (InL $ List []) - _ -> return (InL $ List []) - ----------------------------------------------------------------------------------------------------- - -extendImportCommand :: PluginCommand IdeState -extendImportCommand = - PluginCommand (CommandId extendImportCommandId) "additional edits for a completion" extendImportHandler - -extendImportHandler :: CommandFunction IdeState ExtendImport -extendImportHandler ideState edit@ExtendImport {..} = do - res <- liftIO $ runMaybeT $ extendImportHandler' ideState edit - whenJust res $ \(nfp, wedit@WorkspaceEdit {_changes}) -> do - let (_, List (head -> TextEdit {_range})) = fromJust $ _changes >>= listToMaybe . toList - srcSpan = rangeToSrcSpan nfp _range - LSP.sendNotification SWindowShowMessage $ - ShowMessageParams MtInfo $ - "Import " - <> maybe ("‘" <> newThing) (\x -> "‘" <> x <> " (" <> newThing <> ")") thingParent - <> "’ from " - <> importName - <> " (at " - <> T.pack (prettyPrint srcSpan) - <> ")" - void $ LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - return $ Right Null - -extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit) -extendImportHandler' ideState ExtendImport {..} - | Just fp <- uriToFilePath doc, - nfp <- toNormalizedFilePath' fp = - do - (ms, ps, imps) <- MaybeT $ liftIO $ - runAction "extend import" ideState $ - runMaybeT $ do - -- We want accurate edits, so do not use stale data here - (ms, imps) <- MaybeT $ use GetModSummaryWithoutTimestamps nfp - ps <- MaybeT $ use GetAnnotatedParsedSource nfp - return (ms, ps, imps) - let df = ms_hspp_opts ms - wantedModule = mkModuleName (T.unpack importName) - wantedQual = mkModuleName . T.unpack <$> importQual - imp <- liftMaybe $ find (isWantedModule wantedModule wantedQual) imps - fmap (nfp,) $ liftEither $ - rewriteToWEdit df doc (annsA ps) $ - extendImport (T.unpack <$> thingParent) (T.unpack newThing) imp - | otherwise = - mzero - -isWantedModule :: ModuleName -> Maybe ModuleName -> GenLocated l (ImportDecl pass) -> Bool -isWantedModule wantedModule Nothing (L _ it@ImportDecl{ideclName, ideclHiding = Just (False, _)}) = - not (isQualifiedImport it) && unLoc ideclName == wantedModule -isWantedModule wantedModule (Just qual) (L _ ImportDecl{ideclAs, ideclName, ideclHiding = Just (False, _)}) = - unLoc ideclName == wantedModule && (wantedModule == qual || (unLoc <$> ideclAs) == Just qual) -isWantedModule _ _ _ = False - -liftMaybe :: Monad m => Maybe a -> MaybeT m a -liftMaybe a = MaybeT $ pure a - -liftEither :: Monad m => Either e a -> MaybeT m a -liftEither (Left _) = mzero -liftEither (Right x) = return x +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +#include "ghc-api-version.h" + +module Development.IDE.Plugin.Completions + ( descriptor + , LocalCompletions(..) + , NonLocalCompletions(..) + ) where + +import Control.Concurrent.Async (concurrently) +import Control.Monad +import Control.Monad.Extra +import Control.Monad.Trans.Maybe +import Data.Aeson +import Data.List (find) +import Data.Maybe +import qualified Data.Text as T +import Development.IDE.Core.PositionMapping +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Service +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Error (rangeToSrcSpan) +import Development.IDE.GHC.ExactPrint (Annotated (annsA), + GetAnnotatedParsedSource (GetAnnotatedParsedSource)) +import Development.IDE.GHC.Util (prettyPrint) +import Development.IDE.Plugin.CodeAction.ExactPrint +import Development.IDE.Plugin.Completions.Logic +import Development.IDE.Plugin.Completions.Types +import Development.IDE.Types.HscEnvEq (hscEnv) +import Development.IDE.Types.Location +import Development.Shake +import Development.Shake.Classes +import GHC.Exts (toList) +import GHC.Generics +import Ide.Plugin.Config (Config (completionSnippetsOn)) +import Ide.Types +import qualified Language.LSP.Server as LSP +import Language.LSP.Types +import qualified Language.LSP.VFS as VFS +import TcRnDriver (tcRnImportDecls) + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) + { pluginRules = produceCompletions + , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP + , pluginCommands = [extendImportCommand] + } + +produceCompletions :: Rules () +produceCompletions = do + define $ \LocalCompletions file -> do + let uri = fromNormalizedUri $ normalizedFilePathToUri file + pm <- useWithStale GetParsedModule file + case pm of + Just (pm, _) -> do + let cdata = localCompletionsForParsedModule uri pm + return ([], Just cdata) + _ -> return ([], Nothing) + define $ \NonLocalCompletions file -> do + -- For non local completions we avoid depending on the parsed module, + -- synthetizing a fake module with an empty body from the buffer + -- in the ModSummary, which preserves all the imports + ms <- fmap fst <$> useWithStale GetModSummaryWithoutTimestamps file + sess <- fmap fst <$> useWithStale GhcSessionDeps file + + case (ms, sess) of + (Just ModSummaryResult{..}, Just sess) -> do + let env = hscEnv sess + -- We do this to be able to provide completions of items that are not restricted to the explicit list + (global, inScope) <- liftIO $ tcRnImportDecls env (dropListFromImportDecl <$> msrImports) `concurrently` tcRnImportDecls env msrImports + case (global, inScope) of + ((_, Just globalEnv), (_, Just inScopeEnv)) -> do + let uri = fromNormalizedUri $ normalizedFilePathToUri file + cdata <- liftIO $ cacheDataProducer uri sess (ms_mod msrModSummary) globalEnv inScopeEnv msrImports + return ([], Just cdata) + (_diag, _) -> + return ([], Nothing) + _ -> return ([], Nothing) + +-- Drop any explicit imports in ImportDecl if not hidden +dropListFromImportDecl :: GenLocated SrcSpan (ImportDecl GhcPs) -> GenLocated SrcSpan (ImportDecl GhcPs) +dropListFromImportDecl iDecl = let + f d@ImportDecl {ideclHiding} = case ideclHiding of + Just (False, _) -> d {ideclHiding=Nothing} + -- if hiding or Nothing just return d + _ -> d + f x = x + in f <$> iDecl + +-- | Produce completions info for a file +type instance RuleResult LocalCompletions = CachedCompletions +type instance RuleResult NonLocalCompletions = CachedCompletions + +data LocalCompletions = LocalCompletions + deriving (Eq, Show, Typeable, Generic) +instance Hashable LocalCompletions +instance NFData LocalCompletions +instance Binary LocalCompletions + +data NonLocalCompletions = NonLocalCompletions + deriving (Eq, Show, Typeable, Generic) +instance Hashable NonLocalCompletions +instance NFData NonLocalCompletions +instance Binary NonLocalCompletions + +-- | Generate code actions. +getCompletionsLSP + :: IdeState + -> PluginId + -> CompletionParams + -> LSP.LspM Config (Either ResponseError (ResponseResult TextDocumentCompletion)) +getCompletionsLSP ide plId + CompletionParams{_textDocument=TextDocumentIdentifier uri + ,_position=position + ,_context=completionContext} = do + contents <- LSP.getVirtualFile $ toNormalizedUri uri + fmap Right $ case (contents, uriToFilePath' uri) of + (Just cnts, Just path) -> do + let npath = toNormalizedFilePath' path + (ideOpts, compls) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do + opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide + localCompls <- useWithStaleFast LocalCompletions npath + nonLocalCompls <- useWithStaleFast NonLocalCompletions npath + pm <- useWithStaleFast GetParsedModule npath + binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath + pure (opts, fmap (,pm,binds) ((fst <$> localCompls) <> (fst <$> nonLocalCompls))) + case compls of + Just (cci', parsedMod, bindMap) -> do + pfix <- VFS.getCompletionPrefix position cnts + case (pfix, completionContext) of + (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."}) + -> return (InL $ List []) + (Just pfix', _) -> do + let clientCaps = clientCapabilities $ shakeExtras ide + config <- getClientConfig $ shakeExtras ide + let snippets = WithSnippets . completionSnippetsOn $ config + allCompletions <- liftIO $ getCompletions plId ideOpts cci' parsedMod bindMap pfix' clientCaps snippets + pure $ InL (List allCompletions) + _ -> return (InL $ List []) + _ -> return (InL $ List []) + _ -> return (InL $ List []) + +---------------------------------------------------------------------------------------------------- + +extendImportCommand :: PluginCommand IdeState +extendImportCommand = + PluginCommand (CommandId extendImportCommandId) "additional edits for a completion" extendImportHandler + +extendImportHandler :: CommandFunction IdeState ExtendImport +extendImportHandler ideState edit@ExtendImport {..} = do + res <- liftIO $ runMaybeT $ extendImportHandler' ideState edit + whenJust res $ \(nfp, wedit@WorkspaceEdit {_changes}) -> do + let (_, List (head -> TextEdit {_range})) = fromJust $ _changes >>= listToMaybe . toList + srcSpan = rangeToSrcSpan nfp _range + LSP.sendNotification SWindowShowMessage $ + ShowMessageParams MtInfo $ + "Import " + <> maybe ("‘" <> newThing) (\x -> "‘" <> x <> " (" <> newThing <> ")") thingParent + <> "’ from " + <> importName + <> " (at " + <> T.pack (prettyPrint srcSpan) + <> ")" + void $ LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + return $ Right Null + +extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit) +extendImportHandler' ideState ExtendImport {..} + | Just fp <- uriToFilePath doc, + nfp <- toNormalizedFilePath' fp = + do + (ModSummaryResult {..}, ps) <- MaybeT $ liftIO $ + runAction "extend import" ideState $ + runMaybeT $ do + -- We want accurate edits, so do not use stale data here + msr <- MaybeT $ use GetModSummaryWithoutTimestamps nfp + ps <- MaybeT $ use GetAnnotatedParsedSource nfp + return (msr, ps) + let df = ms_hspp_opts msrModSummary + wantedModule = mkModuleName (T.unpack importName) + wantedQual = mkModuleName . T.unpack <$> importQual + imp <- liftMaybe $ find (isWantedModule wantedModule wantedQual) msrImports + fmap (nfp,) $ liftEither $ + rewriteToWEdit df doc (annsA ps) $ + extendImport (T.unpack <$> thingParent) (T.unpack newThing) imp + | otherwise = + mzero + +isWantedModule :: ModuleName -> Maybe ModuleName -> GenLocated l (ImportDecl pass) -> Bool +isWantedModule wantedModule Nothing (L _ it@ImportDecl{ideclName, ideclHiding = Just (False, _)}) = + not (isQualifiedImport it) && unLoc ideclName == wantedModule +isWantedModule wantedModule (Just qual) (L _ ImportDecl{ideclAs, ideclName, ideclHiding = Just (False, _)}) = + unLoc ideclName == wantedModule && (wantedModule == qual || (unLoc <$> ideclAs) == Just qual) +isWantedModule _ _ _ = False + +liftMaybe :: Monad m => Maybe a -> MaybeT m a +liftMaybe a = MaybeT $ pure a + +liftEither :: Monad m => Either e a -> MaybeT m a +liftEither (Left _) = mzero +liftEither (Right x) = return x diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -1,758 +1,761 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs#-} - -#include "ghc-api-version.h" - --- Mostly taken from "haskell-ide-engine" -module Development.IDE.Plugin.Completions.Logic ( - CachedCompletions -, cacheDataProducer -, localCompletionsForParsedModule -, WithSnippets(..) -, getCompletions -) where - -import Control.Applicative -import Data.Char (isUpper) -import Data.Generics -import Data.List.Extra as List hiding (stripPrefix) -import qualified Data.Map as Map - -import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe) -import qualified Data.Text as T -import qualified Text.Fuzzy as Fuzzy - -import HscTypes -import Name -import RdrName -import Type -#if MIN_GHC_API_VERSION(8,10,0) -import Predicate (isDictTy) -import Pair -import Coercion -#endif - -import Language.LSP.Types -import Language.LSP.Types.Capabilities -import qualified Language.LSP.VFS as VFS -import Development.IDE.Core.Compile -import Development.IDE.Core.PositionMapping -import Development.IDE.Plugin.Completions.Types -import Development.IDE.Spans.Documentation -import Development.IDE.Spans.LocalBindings -import Development.IDE.GHC.Compat as GHC -import Development.IDE.GHC.Error -import Development.IDE.Types.Options -import Development.IDE.Spans.Common -import Development.IDE.GHC.Util -import Outputable (Outputable) -import qualified Data.Set as Set -import ConLike -import GhcPlugins ( - flLabel, - unpackFS) -import Data.Either (fromRight) -import Data.Aeson (ToJSON (toJSON)) -import Data.Functor -import Ide.PluginUtils (mkLspCommand) -import Ide.Types (CommandId (..), PluginId, WithSnippets (..)) -import Control.Monad -import Development.IDE.Types.HscEnvEq - --- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs - --- | A context of a declaration in the program --- e.g. is the declaration a type declaration or a value declaration --- Used for determining which code completions to show --- TODO: expand this with more contexts like classes or instances for --- smarter code completion -data Context = TypeContext - | ValueContext - | ModuleContext String -- ^ module context with module name - | ImportContext String -- ^ import context with module name - | ImportListContext String -- ^ import list context with module name - | ImportHidingContext String -- ^ import hiding context with module name - | ExportContext -- ^ List of exported identifiers from the current module - deriving (Show, Eq) - --- | Generates a map of where the context is a type and where the context is a value --- i.e. where are the value decls and the type decls -getCContext :: Position -> ParsedModule -> Maybe Context -getCContext pos pm - | Just (L r modName) <- moduleHeader - , pos `isInsideSrcSpan` r - = Just (ModuleContext (moduleNameString modName)) - - | Just (L r _) <- exportList - , pos `isInsideSrcSpan` r - = Just ExportContext - - | Just ctx <- something (Nothing `mkQ` go `extQ` goInline) decl - = Just ctx - - | Just ctx <- something (Nothing `mkQ` importGo) imports - = Just ctx - - | otherwise - = Nothing - - where decl = hsmodDecls $ unLoc $ pm_parsed_source pm - moduleHeader = hsmodName $ unLoc $ pm_parsed_source pm - exportList = hsmodExports $ unLoc $ pm_parsed_source pm - imports = hsmodImports $ unLoc $ pm_parsed_source pm - - go :: LHsDecl GhcPs -> Maybe Context - go (L r SigD {}) - | pos `isInsideSrcSpan` r = Just TypeContext - | otherwise = Nothing - go (L r GHC.ValD {}) - | pos `isInsideSrcSpan` r = Just ValueContext - | otherwise = Nothing - go _ = Nothing - - goInline :: GHC.LHsType GhcPs -> Maybe Context - goInline (GHC.L r _) - | pos `isInsideSrcSpan` r = Just TypeContext - goInline _ = Nothing - - importGo :: GHC.LImportDecl GhcPs -> Maybe Context - importGo (L r impDecl) - | pos `isInsideSrcSpan` r - = importInline importModuleName (ideclHiding impDecl) - <|> Just (ImportContext importModuleName) - - | otherwise = Nothing - where importModuleName = moduleNameString $ unLoc $ ideclName impDecl - - importInline :: String -> Maybe (Bool, GHC.Located [LIE GhcPs]) -> Maybe Context - importInline modName (Just (True, L r _)) - | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName - | otherwise = Nothing - importInline modName (Just (False, L r _)) - | pos `isInsideSrcSpan` r = Just $ ImportListContext modName - | otherwise = Nothing - importInline _ _ = Nothing - -occNameToComKind :: Maybe T.Text -> OccName -> CompletionItemKind -occNameToComKind ty oc - | isVarOcc oc = case occNameString oc of - i:_ | isUpper i -> CiConstructor - _ -> CiFunction - | isTcOcc oc = case ty of - Just t - | "Constraint" `T.isSuffixOf` t - -> CiClass - _ -> CiStruct - | isDataOcc oc = CiConstructor - | otherwise = CiVariable - - -showModName :: ModuleName -> T.Text -showModName = T.pack . moduleNameString - --- mkCompl :: IdeOptions -> CompItem -> CompletionItem --- mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs} = --- CompletionItem label kind (List []) ((colon <>) <$> typeText) --- (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs') --- Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet) --- Nothing Nothing Nothing Nothing Nothing - -mkCompl :: PluginId -> IdeOptions -> CompItem -> IO CompletionItem -mkCompl - pId - IdeOptions {..} - CI - { compKind, - isInfix, - insertText, - importedFrom, - typeText, - label, - docs, - additionalTextEdits - } = do - mbCommand <- mkAdditionalEditsCommand pId `traverse` additionalTextEdits - let ci = CompletionItem - {_label = label, - _kind = kind, - _tags = Nothing, - _detail = (colon <>) <$> typeText, - _documentation = documentation, - _deprecated = Nothing, - _preselect = Nothing, - _sortText = Nothing, - _filterText = Nothing, - _insertText = Just insertText, - _insertTextFormat = Just Snippet, - _textEdit = Nothing, - _additionalTextEdits = Nothing, - _commitCharacters = Nothing, - _command = mbCommand, - _xdata = Nothing} - return $ removeSnippetsWhen (isJust isInfix) ci - - where kind = Just compKind - docs' = imported : spanDocToMarkdown docs - imported = case importedFrom of - Left pos -> "*Defined at '" <> ppr pos <> "'*\n'" - Right mod -> "*Defined in '" <> mod <> "'*\n" - colon = if optNewColonConvention then ": " else ":: " - documentation = Just $ CompletionDocMarkup $ - MarkupContent MkMarkdown $ - T.intercalate sectionSeparator docs' - -mkAdditionalEditsCommand :: PluginId -> ExtendImport -> IO Command -mkAdditionalEditsCommand pId edits = pure $ - mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits]) - -mkNameCompItem :: Uri -> Maybe T.Text -> OccName -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem -mkNameCompItem doc thingParent origName origMod thingType isInfix docs !imp = CI {..} - where - compKind = occNameToComKind typeText origName - importedFrom = Right $ showModName origMod - isTypeCompl = isTcOcc origName - label = stripPrefix $ showGhc origName - insertText = case isInfix of - Nothing -> case getArgText <$> thingType of - Nothing -> label - Just argText -> label <> " " <> argText - Just LeftSide -> label <> "`" - - Just Surrounded -> label - typeText - | Just t <- thingType = Just . stripForall $ showGhc t - | otherwise = Nothing - additionalTextEdits = - imp <&> \x -> - ExtendImport - { doc, - thingParent, - importName = showModName $ unLoc $ ideclName $ unLoc x, - importQual = getImportQual x, - newThing = showNameWithoutUniques origName - } - - stripForall :: T.Text -> T.Text - stripForall t - | T.isPrefixOf "forall" t = - -- We drop 2 to remove the '.' and the space after it - T.drop 2 (T.dropWhile (/= '.') t) - | otherwise = t - - getArgText :: Type -> T.Text - getArgText typ = argText - where - argTypes = getArgs typ - argText :: T.Text - argText = mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes - snippet :: Int -> Type -> T.Text - snippet i t = "${" <> T.pack (show i) <> ":" <> showGhc t <> "}" - getArgs :: Type -> [Type] - getArgs t - | isPredTy t = [] - | isDictTy t = [] - | isForAllTy t = getArgs $ snd (splitForAllTys t) - | isFunTy t = - let (args, ret) = splitFunTys t - in if isForAllTy ret - then getArgs ret - else Prelude.filter (not . isDictTy) args - | isPiTy t = getArgs $ snd (splitPiTys t) -#if MIN_GHC_API_VERSION(8,10,0) - | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t - = getArgs t -#else - | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t) -#endif - | otherwise = [] - -mkModCompl :: T.Text -> CompletionItem -mkModCompl label = - CompletionItem label (Just CiModule) Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing - -mkImportCompl :: T.Text -> T.Text -> CompletionItem -mkImportCompl enteredQual label = - CompletionItem m (Just CiModule) Nothing (Just label) - Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing - where - m = fromMaybe "" (T.stripPrefix enteredQual label) - -mkExtCompl :: T.Text -> CompletionItem -mkExtCompl label = - CompletionItem label (Just CiKeyword) Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing - -mkPragmaCompl :: T.Text -> T.Text -> CompletionItem -mkPragmaCompl label insertText = - CompletionItem label (Just CiKeyword) Nothing Nothing - Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet) - Nothing Nothing Nothing Nothing Nothing - - -cacheDataProducer :: Uri -> HscEnvEq -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> IO CachedCompletions -cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do - let - packageState = hscEnv env - curModName = moduleName curMod - - importMap = Map.fromList [ (getLoc imp, imp) | imp <- limports ] - - iDeclToModName :: ImportDecl name -> ModuleName - iDeclToModName = unLoc . ideclName - - asNamespace :: ImportDecl name -> ModuleName - asNamespace imp = maybe (iDeclToModName imp) GHC.unLoc (ideclAs imp) - -- Full canonical names of imported modules - importDeclerations = map unLoc limports - - - -- The given namespaces for the imported modules (ie. full name, or alias if used) - allModNamesAsNS = map (showModName . asNamespace) importDeclerations - - rdrElts = globalRdrEnvElts globalEnv - - foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b - foldMapM f xs = foldr step return xs mempty where - step x r z = f x >>= \y -> r $! z `mappend` y - - getCompls :: [GlobalRdrElt] -> IO ([CompItem],QualCompls) - getCompls = foldMapM getComplsForOne - - getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls) - getComplsForOne (GRE n par True _) = - (, mempty) <$> toCompItem par curMod curModName n Nothing - getComplsForOne (GRE n par False prov) = - flip foldMapM (map is_decl prov) $ \spec -> do - -- we don't want to extend import if it's already in scope - let originalImportDecl = if null $ lookupGRE_Name inScopeEnv n then Map.lookup (is_dloc spec) importMap else Nothing - compItem <- toCompItem par curMod (is_mod spec) n originalImportDecl - let unqual - | is_qual spec = [] - | otherwise = compItem - qual - | is_qual spec = Map.singleton asMod compItem - | otherwise = Map.fromList [(asMod,compItem),(origMod,compItem)] - asMod = showModName (is_as spec) - origMod = showModName (is_mod spec) - return (unqual,QualCompls qual) - - toCompItem :: Parent -> Module -> ModuleName -> Name -> Maybe (LImportDecl GhcPs) -> IO [CompItem] - toCompItem par m mn n imp' = do - docs <- getDocumentationTryGhc packageState curMod n - let (mbParent, originName) = case par of - NoParent -> (Nothing, nameOccName n) - ParentIs n' -> (Just $ showNameWithoutUniques n', nameOccName n) - FldParent n' lbl -> (Just $ showNameWithoutUniques n', maybe (nameOccName n) mkVarOccFS lbl) - tys <- catchSrcErrors (hsc_dflags packageState) "completion" $ do - name' <- lookupName packageState m n - return ( name' >>= safeTyThingType - , guard (isJust mbParent) >> name' >>= safeTyThingForRecord - ) - let (ty, record_ty) = fromRight (Nothing, Nothing) tys - - let recordCompls = case record_ty of - Just (ctxStr, flds) | not (null flds) -> - [mkRecordSnippetCompItem uri mbParent ctxStr flds (ppr mn) docs imp'] - _ -> [] - - return $ mkNameCompItem uri mbParent originName mn ty Nothing docs imp' - : recordCompls - - (unquals,quals) <- getCompls rdrElts - - -- The list of all importable Modules from all packages - moduleNames <- maybe [] (map showModName) <$> envVisibleModuleNames env - - return $ CC - { allModNamesAsNS = allModNamesAsNS - , unqualCompls = unquals - , qualCompls = quals - , importableModules = moduleNames - } - --- | Produces completions from the top level declarations of a module. -localCompletionsForParsedModule :: Uri -> ParsedModule -> CachedCompletions -localCompletionsForParsedModule uri pm@ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls, hsmodName}} = - CC { allModNamesAsNS = mempty - , unqualCompls = compls - , qualCompls = mempty - , importableModules = mempty - } - where - typeSigIds = Set.fromList - [ id - | L _ (SigD _ (TypeSig _ ids _)) <- hsmodDecls - , L _ id <- ids - ] - hasTypeSig = (`Set.member` typeSigIds) . unLoc - - compls = concat - [ case decl of - SigD _ (TypeSig _ ids typ) -> - [mkComp id CiFunction (Just $ ppr typ) | id <- ids] - ValD _ FunBind{fun_id} -> - [ mkComp fun_id CiFunction Nothing - | not (hasTypeSig fun_id) - ] - ValD _ PatBind{pat_lhs} -> - [mkComp id CiVariable Nothing - | VarPat _ id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs] - TyClD _ ClassDecl{tcdLName, tcdSigs} -> - mkComp tcdLName CiClass Nothing : - [ mkComp id CiFunction (Just $ ppr typ) - | L _ (TypeSig _ ids typ) <- tcdSigs - , id <- ids] - TyClD _ x -> - let generalCompls = [mkComp id cl Nothing - | id <- listify (\(_ :: Located(IdP GhcPs)) -> True) x - , let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)] - -- here we only have to look at the outermost type - recordCompls = findRecordCompl uri pm thisModName x - in - -- the constructors and snippets will be duplicated here giving the user 2 choices. - generalCompls ++ recordCompls - ForD _ ForeignImport{fd_name,fd_sig_ty} -> - [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)] - ForD _ ForeignExport{fd_name,fd_sig_ty} -> - [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)] - _ -> [] - | L _ decl <- hsmodDecls - ] - - mkComp n ctyp ty = - CI ctyp pn (Right thisModName) ty pn Nothing doc (ctyp `elem` [CiStruct, CiClass]) Nothing - where - pn = ppr n - doc = SpanDocText (getDocumentation [pm] n) (SpanDocUris Nothing Nothing) - - thisModName = ppr hsmodName - -findRecordCompl :: Uri -> ParsedModule -> T.Text -> TyClDecl GhcPs -> [CompItem] -findRecordCompl uri pmod mn DataDecl {tcdLName, tcdDataDefn} = result - where - result = [mkRecordSnippetCompItem uri (Just $ showNameWithoutUniques $ unLoc tcdLName) - (showGhc . unLoc $ con_name) field_labels mn doc Nothing - | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn - , Just con_details <- [getFlds con_args] - , let field_names = mapMaybe extract con_details - , let field_labels = showGhc . unLoc <$> field_names - , (not . List.null) field_labels - ] - doc = SpanDocText (getDocumentation [pmod] tcdLName) (SpanDocUris Nothing Nothing) - - getFlds :: HsConDetails arg (Located [LConDeclField GhcPs]) -> Maybe [ConDeclField GhcPs] - getFlds conArg = case conArg of - RecCon rec -> Just $ unLoc <$> unLoc rec - PrefixCon _ -> Just [] - _ -> Nothing - - extract ConDeclField{..} - -- TODO: Why is cd_fld_names a list? - | Just fld_name <- rdrNameFieldOcc . unLoc <$> listToMaybe cd_fld_names = Just fld_name - | otherwise = Nothing - -- XConDeclField - extract _ = Nothing -findRecordCompl _ _ _ _ = [] - -ppr :: Outputable a => a -> T.Text -ppr = T.pack . prettyPrint - -toggleSnippets :: ClientCapabilities -> WithSnippets -> CompletionItem -> CompletionItem -toggleSnippets ClientCapabilities {_textDocument} (WithSnippets with) = - removeSnippetsWhen (not $ with && supported) - where - supported = - Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport) - -removeSnippetsWhen :: Bool -> CompletionItem -> CompletionItem -removeSnippetsWhen condition x = - if condition - then - x - { _insertTextFormat = Just PlainText, - _insertText = Nothing - } - else x - --- | Returns the cached completions for the given module and position. -getCompletions - :: PluginId - -> IdeOptions - -> CachedCompletions - -> Maybe (ParsedModule, PositionMapping) - -> (Bindings, PositionMapping) - -> VFS.PosPrefixInfo - -> ClientCapabilities - -> WithSnippets - -> IO [CompletionItem] -getCompletions plId ideOpts CC {allModNamesAsNS, unqualCompls, qualCompls, importableModules} - maybe_parsed (localBindings, bmapping) prefixInfo caps withSnippets = do - let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo - enteredQual = if T.null prefixModule then "" else prefixModule <> "." - fullPrefix = enteredQual <> prefixText - - {- correct the position by moving 'foo :: Int -> String -> ' - ^ - to 'foo :: Int -> String -> ' - ^ - -} - pos = VFS.cursorPos prefixInfo - - filtModNameCompls = - map mkModCompl - $ mapMaybe (T.stripPrefix enteredQual) - $ Fuzzy.simpleFilter fullPrefix allModNamesAsNS - - filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False - where - - mcc = case maybe_parsed of - Nothing -> Nothing - Just (pm, pmapping) -> - let PositionMapping pDelta = pmapping - position' = fromDelta pDelta pos - lpos = lowerRange position' - hpos = upperRange position' - in getCContext lpos pm <|> getCContext hpos pm - - -- completions specific to the current context - ctxCompls' = case mcc of - Nothing -> compls - Just TypeContext -> filter isTypeCompl compls - Just ValueContext -> filter (not . isTypeCompl) compls - Just _ -> filter (not . isTypeCompl) compls - -- Add whether the text to insert has backticks - ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls' - - infixCompls :: Maybe Backtick - infixCompls = isUsedAsInfix fullLine prefixModule prefixText pos - - PositionMapping bDelta = bmapping - oldPos = fromDelta bDelta $ VFS.cursorPos prefixInfo - startLoc = lowerRange oldPos - endLoc = upperRange oldPos - localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc - localBindsToCompItem :: Name -> Maybe Type -> CompItem - localBindsToCompItem name typ = CI ctyp pn thisModName ty pn Nothing emptySpanDoc (not $ isValOcc occ) Nothing - where - occ = nameOccName name - ctyp = occNameToComKind Nothing occ - pn = ppr name - ty = ppr <$> typ - thisModName = case nameModule_maybe name of - Nothing -> Left $ nameSrcSpan name - Just m -> Right $ ppr m - - compls = if T.null prefixModule - then localCompls ++ unqualCompls - else Map.findWithDefault [] prefixModule $ getQualCompls qualCompls - - filtListWith f list = - [ f label - | label <- Fuzzy.simpleFilter fullPrefix list - , enteredQual `T.isPrefixOf` label - ] - - filtListWithSnippet f list suffix = - [ toggleSnippets caps withSnippets (f label (snippet <> suffix)) - | (snippet, label) <- list - , Fuzzy.test fullPrefix label - ] - - filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules - filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas - filtOptsCompls = filtListWith mkExtCompl - filtKeywordCompls - | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts) - | otherwise = [] - - stripLeading :: Char -> String -> String - stripLeading _ [] = [] - stripLeading c (s:ss) - | s == c = ss - | otherwise = s:ss - - if - | "import " `T.isPrefixOf` fullLine - -> return filtImportCompls - -- we leave this condition here to avoid duplications and return empty list - -- since HLS implements this completion (#haskell-language-server/pull/662) - | "{-# language" `T.isPrefixOf` T.toLower fullLine - -> return [] - | "{-# options_ghc" `T.isPrefixOf` T.toLower fullLine - -> return $ filtOptsCompls (map (T.pack . stripLeading '-') $ flagsForCompletion False) - | "{-# " `T.isPrefixOf` fullLine - -> return $ filtPragmaCompls (pragmaSuffix fullLine) - | otherwise -> do - let uniqueFiltCompls = nubOrdOn insertText filtCompls - compls <- mapM (mkCompl plId ideOpts) uniqueFiltCompls - return $ filtModNameCompls - ++ filtKeywordCompls - ++ map ( toggleSnippets caps withSnippets) compls - - --- --------------------------------------------------------------------- --- helper functions for pragmas --- --------------------------------------------------------------------- - -validPragmas :: [(T.Text, T.Text)] -validPragmas = - [ ("LANGUAGE ${1:extension}" , "LANGUAGE") - , ("OPTIONS_GHC -${1:option}" , "OPTIONS_GHC") - , ("INLINE ${1:function}" , "INLINE") - , ("NOINLINE ${1:function}" , "NOINLINE") - , ("INLINABLE ${1:function}" , "INLINABLE") - , ("WARNING ${1:message}" , "WARNING") - , ("DEPRECATED ${1:message}" , "DEPRECATED") - , ("ANN ${1:annotation}" , "ANN") - , ("RULES" , "RULES") - , ("SPECIALIZE ${1:function}" , "SPECIALIZE") - , ("SPECIALIZE INLINE ${1:function}", "SPECIALIZE INLINE") - ] - -pragmaSuffix :: T.Text -> T.Text -pragmaSuffix fullLine - | "}" `T.isSuffixOf` fullLine = mempty - | otherwise = " #-}" - --- --------------------------------------------------------------------- --- helper functions for infix backticks --- --------------------------------------------------------------------- - -hasTrailingBacktick :: T.Text -> Position -> Bool -hasTrailingBacktick line Position { _character } - | T.length line > _character = (line `T.index` _character) == '`' - | otherwise = False - -isUsedAsInfix :: T.Text -> T.Text -> T.Text -> Position -> Maybe Backtick -isUsedAsInfix line prefixMod prefixText pos - | hasClosingBacktick && hasOpeningBacktick = Just Surrounded - | hasOpeningBacktick = Just LeftSide - | otherwise = Nothing - where - hasOpeningBacktick = openingBacktick line prefixMod prefixText pos - hasClosingBacktick = hasTrailingBacktick line pos - -openingBacktick :: T.Text -> T.Text -> T.Text -> Position -> Bool -openingBacktick line prefixModule prefixText Position { _character } - | backtickIndex < 0 || backtickIndex > T.length line = False - | otherwise = (line `T.index` backtickIndex) == '`' - where - backtickIndex :: Int - backtickIndex = - let - prefixLength = T.length prefixText - moduleLength = if prefixModule == "" - then 0 - else T.length prefixModule + 1 {- Because of "." -} - in - -- Points to the first letter of either the module or prefix text - _character - (prefixLength + moduleLength) - 1 - - --- --------------------------------------------------------------------- - --- | Under certain circumstance GHC generates some extra stuff that we --- don't want in the autocompleted symbols - {- When e.g. DuplicateRecordFields is enabled, compiler generates - names like "$sel:accessor:One" and "$sel:accessor:Two" to disambiguate record selectors - https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation - -} --- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace. -stripPrefix :: T.Text -> T.Text -stripPrefix name = T.takeWhile (/=':') $ go prefixes - where - go [] = name - go (p:ps) - | T.isPrefixOf p name = T.drop (T.length p) name - | otherwise = go ps - --- | Prefixes that can occur in a GHC OccName -prefixes :: [T.Text] -prefixes = - [ - -- long ones - "$con2tag_" - , "$tag2con_" - , "$maxtag_" - - -- four chars - , "$sel:" - , "$tc'" - - -- three chars - , "$dm" - , "$co" - , "$tc" - , "$cp" - , "$fx" - - -- two chars - , "$W" - , "$w" - , "$m" - , "$b" - , "$c" - , "$d" - , "$i" - , "$s" - , "$f" - , "$r" - , "C:" - , "N:" - , "D:" - , "$p" - , "$L" - , "$f" - , "$t" - , "$c" - , "$m" - ] - - -safeTyThingForRecord :: TyThing -> Maybe (T.Text, [T.Text]) -safeTyThingForRecord (AnId _) = Nothing -safeTyThingForRecord (AConLike dc) = - let ctxStr = showGhc . occName . conLikeName $ dc - field_names = T.pack . unpackFS . flLabel <$> conLikeFieldLabels dc - in - Just (ctxStr, field_names) -safeTyThingForRecord _ = Nothing - -mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> T.Text -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem -mkRecordSnippetCompItem uri parent ctxStr compl mn docs imp = r - where - r = CI { - compKind = CiSnippet - , insertText = buildSnippet - , importedFrom = importedFrom - , typeText = Nothing - , label = ctxStr - , isInfix = Nothing - , docs = docs - , isTypeCompl = False - , additionalTextEdits = imp <&> \x -> - ExtendImport - { doc = uri, - thingParent = parent, - importName = showModName $ unLoc $ ideclName $ unLoc x, - importQual = getImportQual x, - newThing = ctxStr - } - } - - placeholder_pairs = zip compl ([1..]::[Int]) - snippet_parts = map (\(x, i) -> x <> "=${" <> T.pack (show i) <> ":_" <> x <> "}") placeholder_pairs - snippet = T.intercalate (T.pack ", ") snippet_parts - buildSnippet = ctxStr <> " {" <> snippet <> "}" - importedFrom = Right mn - -getImportQual :: LImportDecl GhcPs -> Maybe T.Text -getImportQual (L _ imp) - | isQualifiedImport imp = Just $ T.pack $ moduleNameString $ maybe (unLoc $ ideclName imp) unLoc (ideclAs imp) - | otherwise = Nothing +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} + +#include "ghc-api-version.h" + +-- Mostly taken from "haskell-ide-engine" +module Development.IDE.Plugin.Completions.Logic ( + CachedCompletions +, cacheDataProducer +, localCompletionsForParsedModule +, WithSnippets(..) +, getCompletions +) where + +import Control.Applicative +import Data.Char (isUpper) +import Data.Generics +import Data.List.Extra as List hiding + (stripPrefix) +import qualified Data.Map as Map + +import Data.Maybe (fromMaybe, isJust, + listToMaybe, + mapMaybe) +import qualified Data.Text as T +import qualified Text.Fuzzy as Fuzzy + +import HscTypes +import Name +import RdrName +import Type +#if MIN_GHC_API_VERSION(8,10,0) +import Coercion +import Pair +import Predicate (isDictTy) +#endif + +import ConLike +import Control.Monad +import Data.Aeson (ToJSON (toJSON)) +import Data.Either (fromRight) +import Data.Functor +import qualified Data.Set as Set +import Development.IDE.Core.Compile +import Development.IDE.Core.PositionMapping +import Development.IDE.GHC.Compat as GHC +import Development.IDE.GHC.Error +import Development.IDE.GHC.Util +import Development.IDE.Plugin.Completions.Types +import Development.IDE.Spans.Common +import Development.IDE.Spans.Documentation +import Development.IDE.Spans.LocalBindings +import Development.IDE.Types.HscEnvEq +import Development.IDE.Types.Options +import GhcPlugins (flLabel, unpackFS) +import Ide.PluginUtils (mkLspCommand) +import Ide.Types (CommandId (..), + PluginId, + WithSnippets (..)) +import Language.LSP.Types +import Language.LSP.Types.Capabilities +import qualified Language.LSP.VFS as VFS +import Outputable (Outputable) + +-- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs + +-- | A context of a declaration in the program +-- e.g. is the declaration a type declaration or a value declaration +-- Used for determining which code completions to show +-- TODO: expand this with more contexts like classes or instances for +-- smarter code completion +data Context = TypeContext + | ValueContext + | ModuleContext String -- ^ module context with module name + | ImportContext String -- ^ import context with module name + | ImportListContext String -- ^ import list context with module name + | ImportHidingContext String -- ^ import hiding context with module name + | ExportContext -- ^ List of exported identifiers from the current module + deriving (Show, Eq) + +-- | Generates a map of where the context is a type and where the context is a value +-- i.e. where are the value decls and the type decls +getCContext :: Position -> ParsedModule -> Maybe Context +getCContext pos pm + | Just (L r modName) <- moduleHeader + , pos `isInsideSrcSpan` r + = Just (ModuleContext (moduleNameString modName)) + + | Just (L r _) <- exportList + , pos `isInsideSrcSpan` r + = Just ExportContext + + | Just ctx <- something (Nothing `mkQ` go `extQ` goInline) decl + = Just ctx + + | Just ctx <- something (Nothing `mkQ` importGo) imports + = Just ctx + + | otherwise + = Nothing + + where decl = hsmodDecls $ unLoc $ pm_parsed_source pm + moduleHeader = hsmodName $ unLoc $ pm_parsed_source pm + exportList = hsmodExports $ unLoc $ pm_parsed_source pm + imports = hsmodImports $ unLoc $ pm_parsed_source pm + + go :: LHsDecl GhcPs -> Maybe Context + go (L r SigD {}) + | pos `isInsideSrcSpan` r = Just TypeContext + | otherwise = Nothing + go (L r GHC.ValD {}) + | pos `isInsideSrcSpan` r = Just ValueContext + | otherwise = Nothing + go _ = Nothing + + goInline :: GHC.LHsType GhcPs -> Maybe Context + goInline (GHC.L r _) + | pos `isInsideSrcSpan` r = Just TypeContext + goInline _ = Nothing + + importGo :: GHC.LImportDecl GhcPs -> Maybe Context + importGo (L r impDecl) + | pos `isInsideSrcSpan` r + = importInline importModuleName (ideclHiding impDecl) + <|> Just (ImportContext importModuleName) + + | otherwise = Nothing + where importModuleName = moduleNameString $ unLoc $ ideclName impDecl + + importInline :: String -> Maybe (Bool, GHC.Located [LIE GhcPs]) -> Maybe Context + importInline modName (Just (True, L r _)) + | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName + | otherwise = Nothing + importInline modName (Just (False, L r _)) + | pos `isInsideSrcSpan` r = Just $ ImportListContext modName + | otherwise = Nothing + importInline _ _ = Nothing + +occNameToComKind :: Maybe T.Text -> OccName -> CompletionItemKind +occNameToComKind ty oc + | isVarOcc oc = case occNameString oc of + i:_ | isUpper i -> CiConstructor + _ -> CiFunction + | isTcOcc oc = case ty of + Just t + | "Constraint" `T.isSuffixOf` t + -> CiClass + _ -> CiStruct + | isDataOcc oc = CiConstructor + | otherwise = CiVariable + + +showModName :: ModuleName -> T.Text +showModName = T.pack . moduleNameString + +-- mkCompl :: IdeOptions -> CompItem -> CompletionItem +-- mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs} = +-- CompletionItem label kind (List []) ((colon <>) <$> typeText) +-- (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs') +-- Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet) +-- Nothing Nothing Nothing Nothing Nothing + +mkCompl :: PluginId -> IdeOptions -> CompItem -> IO CompletionItem +mkCompl + pId + IdeOptions {..} + CI + { compKind, + isInfix, + insertText, + importedFrom, + typeText, + label, + docs, + additionalTextEdits + } = do + mbCommand <- mkAdditionalEditsCommand pId `traverse` additionalTextEdits + let ci = CompletionItem + {_label = label, + _kind = kind, + _tags = Nothing, + _detail = (colon <>) <$> typeText, + _documentation = documentation, + _deprecated = Nothing, + _preselect = Nothing, + _sortText = Nothing, + _filterText = Nothing, + _insertText = Just insertText, + _insertTextFormat = Just Snippet, + _textEdit = Nothing, + _additionalTextEdits = Nothing, + _commitCharacters = Nothing, + _command = mbCommand, + _xdata = Nothing} + return $ removeSnippetsWhen (isJust isInfix) ci + + where kind = Just compKind + docs' = imported : spanDocToMarkdown docs + imported = case importedFrom of + Left pos -> "*Defined at '" <> ppr pos <> "'*\n'" + Right mod -> "*Defined in '" <> mod <> "'*\n" + colon = if optNewColonConvention then ": " else ":: " + documentation = Just $ CompletionDocMarkup $ + MarkupContent MkMarkdown $ + T.intercalate sectionSeparator docs' + +mkAdditionalEditsCommand :: PluginId -> ExtendImport -> IO Command +mkAdditionalEditsCommand pId edits = pure $ + mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits]) + +mkNameCompItem :: Uri -> Maybe T.Text -> OccName -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem +mkNameCompItem doc thingParent origName origMod thingType isInfix docs !imp = CI {..} + where + compKind = occNameToComKind typeText origName + importedFrom = Right $ showModName origMod + isTypeCompl = isTcOcc origName + label = stripPrefix $ showGhc origName + insertText = case isInfix of + Nothing -> case getArgText <$> thingType of + Nothing -> label + Just argText -> label <> " " <> argText + Just LeftSide -> label <> "`" + + Just Surrounded -> label + typeText + | Just t <- thingType = Just . stripForall $ showGhc t + | otherwise = Nothing + additionalTextEdits = + imp <&> \x -> + ExtendImport + { doc, + thingParent, + importName = showModName $ unLoc $ ideclName $ unLoc x, + importQual = getImportQual x, + newThing = showNameWithoutUniques origName + } + + stripForall :: T.Text -> T.Text + stripForall t + | T.isPrefixOf "forall" t = + -- We drop 2 to remove the '.' and the space after it + T.drop 2 (T.dropWhile (/= '.') t) + | otherwise = t + + getArgText :: Type -> T.Text + getArgText typ = argText + where + argTypes = getArgs typ + argText :: T.Text + argText = mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes + snippet :: Int -> Type -> T.Text + snippet i t = "${" <> T.pack (show i) <> ":" <> showGhc t <> "}" + getArgs :: Type -> [Type] + getArgs t + | isPredTy t = [] + | isDictTy t = [] + | isForAllTy t = getArgs $ snd (splitForAllTys t) + | isFunTy t = + let (args, ret) = splitFunTys t + in if isForAllTy ret + then getArgs ret + else Prelude.filter (not . isDictTy) args + | isPiTy t = getArgs $ snd (splitPiTys t) +#if MIN_GHC_API_VERSION(8,10,0) + | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t + = getArgs t +#else + | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t) +#endif + | otherwise = [] + +mkModCompl :: T.Text -> CompletionItem +mkModCompl label = + CompletionItem label (Just CiModule) Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing + +mkImportCompl :: T.Text -> T.Text -> CompletionItem +mkImportCompl enteredQual label = + CompletionItem m (Just CiModule) Nothing (Just label) + Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing + where + m = fromMaybe "" (T.stripPrefix enteredQual label) + +mkExtCompl :: T.Text -> CompletionItem +mkExtCompl label = + CompletionItem label (Just CiKeyword) Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing + +mkPragmaCompl :: T.Text -> T.Text -> CompletionItem +mkPragmaCompl label insertText = + CompletionItem label (Just CiKeyword) Nothing Nothing + Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet) + Nothing Nothing Nothing Nothing Nothing + + +cacheDataProducer :: Uri -> HscEnvEq -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> IO CachedCompletions +cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do + let + packageState = hscEnv env + curModName = moduleName curMod + + importMap = Map.fromList [ (getLoc imp, imp) | imp <- limports ] + + iDeclToModName :: ImportDecl name -> ModuleName + iDeclToModName = unLoc . ideclName + + asNamespace :: ImportDecl name -> ModuleName + asNamespace imp = maybe (iDeclToModName imp) GHC.unLoc (ideclAs imp) + -- Full canonical names of imported modules + importDeclerations = map unLoc limports + + + -- The given namespaces for the imported modules (ie. full name, or alias if used) + allModNamesAsNS = map (showModName . asNamespace) importDeclerations + + rdrElts = globalRdrEnvElts globalEnv + + foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b + foldMapM f xs = foldr step return xs mempty where + step x r z = f x >>= \y -> r $! z `mappend` y + + getCompls :: [GlobalRdrElt] -> IO ([CompItem],QualCompls) + getCompls = foldMapM getComplsForOne + + getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls) + getComplsForOne (GRE n par True _) = + (, mempty) <$> toCompItem par curMod curModName n Nothing + getComplsForOne (GRE n par False prov) = + flip foldMapM (map is_decl prov) $ \spec -> do + -- we don't want to extend import if it's already in scope + let originalImportDecl = if null $ lookupGRE_Name inScopeEnv n then Map.lookup (is_dloc spec) importMap else Nothing + compItem <- toCompItem par curMod (is_mod spec) n originalImportDecl + let unqual + | is_qual spec = [] + | otherwise = compItem + qual + | is_qual spec = Map.singleton asMod compItem + | otherwise = Map.fromList [(asMod,compItem),(origMod,compItem)] + asMod = showModName (is_as spec) + origMod = showModName (is_mod spec) + return (unqual,QualCompls qual) + + toCompItem :: Parent -> Module -> ModuleName -> Name -> Maybe (LImportDecl GhcPs) -> IO [CompItem] + toCompItem par m mn n imp' = do + docs <- getDocumentationTryGhc packageState curMod n + let (mbParent, originName) = case par of + NoParent -> (Nothing, nameOccName n) + ParentIs n' -> (Just . T.pack $ printName n', nameOccName n) + FldParent n' lbl -> (Just . T.pack $ printName n', maybe (nameOccName n) mkVarOccFS lbl) + tys <- catchSrcErrors (hsc_dflags packageState) "completion" $ do + name' <- lookupName packageState m n + return ( name' >>= safeTyThingType + , guard (isJust mbParent) >> name' >>= safeTyThingForRecord + ) + let (ty, record_ty) = fromRight (Nothing, Nothing) tys + + let recordCompls = case record_ty of + Just (ctxStr, flds) | not (null flds) -> + [mkRecordSnippetCompItem uri mbParent ctxStr flds (ppr mn) docs imp'] + _ -> [] + + return $ mkNameCompItem uri mbParent originName mn ty Nothing docs imp' + : recordCompls + + (unquals,quals) <- getCompls rdrElts + + -- The list of all importable Modules from all packages + moduleNames <- maybe [] (map showModName) <$> envVisibleModuleNames env + + return $ CC + { allModNamesAsNS = allModNamesAsNS + , unqualCompls = unquals + , qualCompls = quals + , importableModules = moduleNames + } + +-- | Produces completions from the top level declarations of a module. +localCompletionsForParsedModule :: Uri -> ParsedModule -> CachedCompletions +localCompletionsForParsedModule uri pm@ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls, hsmodName}} = + CC { allModNamesAsNS = mempty + , unqualCompls = compls + , qualCompls = mempty + , importableModules = mempty + } + where + typeSigIds = Set.fromList + [ id + | L _ (SigD _ (TypeSig _ ids _)) <- hsmodDecls + , L _ id <- ids + ] + hasTypeSig = (`Set.member` typeSigIds) . unLoc + + compls = concat + [ case decl of + SigD _ (TypeSig _ ids typ) -> + [mkComp id CiFunction (Just $ ppr typ) | id <- ids] + ValD _ FunBind{fun_id} -> + [ mkComp fun_id CiFunction Nothing + | not (hasTypeSig fun_id) + ] + ValD _ PatBind{pat_lhs} -> + [mkComp id CiVariable Nothing + | VarPat _ id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs] + TyClD _ ClassDecl{tcdLName, tcdSigs} -> + mkComp tcdLName CiClass Nothing : + [ mkComp id CiFunction (Just $ ppr typ) + | L _ (TypeSig _ ids typ) <- tcdSigs + , id <- ids] + TyClD _ x -> + let generalCompls = [mkComp id cl Nothing + | id <- listify (\(_ :: Located(IdP GhcPs)) -> True) x + , let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)] + -- here we only have to look at the outermost type + recordCompls = findRecordCompl uri pm thisModName x + in + -- the constructors and snippets will be duplicated here giving the user 2 choices. + generalCompls ++ recordCompls + ForD _ ForeignImport{fd_name,fd_sig_ty} -> + [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)] + ForD _ ForeignExport{fd_name,fd_sig_ty} -> + [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)] + _ -> [] + | L _ decl <- hsmodDecls + ] + + mkComp n ctyp ty = + CI ctyp pn (Right thisModName) ty pn Nothing doc (ctyp `elem` [CiStruct, CiClass]) Nothing + where + pn = ppr n + doc = SpanDocText (getDocumentation [pm] n) (SpanDocUris Nothing Nothing) + + thisModName = ppr hsmodName + +findRecordCompl :: Uri -> ParsedModule -> T.Text -> TyClDecl GhcPs -> [CompItem] +findRecordCompl uri pmod mn DataDecl {tcdLName, tcdDataDefn} = result + where + result = [mkRecordSnippetCompItem uri (Just $ showNameWithoutUniques $ unLoc tcdLName) + (showGhc . unLoc $ con_name) field_labels mn doc Nothing + | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn + , Just con_details <- [getFlds con_args] + , let field_names = mapMaybe extract con_details + , let field_labels = showGhc . unLoc <$> field_names + , (not . List.null) field_labels + ] + doc = SpanDocText (getDocumentation [pmod] tcdLName) (SpanDocUris Nothing Nothing) + + getFlds :: HsConDetails arg (Located [LConDeclField GhcPs]) -> Maybe [ConDeclField GhcPs] + getFlds conArg = case conArg of + RecCon rec -> Just $ unLoc <$> unLoc rec + PrefixCon _ -> Just [] + _ -> Nothing + + extract ConDeclField{..} + -- TODO: Why is cd_fld_names a list? + | Just fld_name <- rdrNameFieldOcc . unLoc <$> listToMaybe cd_fld_names = Just fld_name + | otherwise = Nothing + -- XConDeclField + extract _ = Nothing +findRecordCompl _ _ _ _ = [] + +ppr :: Outputable a => a -> T.Text +ppr = T.pack . prettyPrint + +toggleSnippets :: ClientCapabilities -> WithSnippets -> CompletionItem -> CompletionItem +toggleSnippets ClientCapabilities {_textDocument} (WithSnippets with) = + removeSnippetsWhen (not $ with && supported) + where + supported = + Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport) + +removeSnippetsWhen :: Bool -> CompletionItem -> CompletionItem +removeSnippetsWhen condition x = + if condition + then + x + { _insertTextFormat = Just PlainText, + _insertText = Nothing + } + else x + +-- | Returns the cached completions for the given module and position. +getCompletions + :: PluginId + -> IdeOptions + -> CachedCompletions + -> Maybe (ParsedModule, PositionMapping) + -> (Bindings, PositionMapping) + -> VFS.PosPrefixInfo + -> ClientCapabilities + -> WithSnippets + -> IO [CompletionItem] +getCompletions plId ideOpts CC {allModNamesAsNS, unqualCompls, qualCompls, importableModules} + maybe_parsed (localBindings, bmapping) prefixInfo caps withSnippets = do + let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo + enteredQual = if T.null prefixModule then "" else prefixModule <> "." + fullPrefix = enteredQual <> prefixText + + {- correct the position by moving 'foo :: Int -> String -> ' + ^ + to 'foo :: Int -> String -> ' + ^ + -} + pos = VFS.cursorPos prefixInfo + + filtModNameCompls = + map mkModCompl + $ mapMaybe (T.stripPrefix enteredQual) + $ Fuzzy.simpleFilter fullPrefix allModNamesAsNS + + filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False + where + + mcc = case maybe_parsed of + Nothing -> Nothing + Just (pm, pmapping) -> + let PositionMapping pDelta = pmapping + position' = fromDelta pDelta pos + lpos = lowerRange position' + hpos = upperRange position' + in getCContext lpos pm <|> getCContext hpos pm + + -- completions specific to the current context + ctxCompls' = case mcc of + Nothing -> compls + Just TypeContext -> filter isTypeCompl compls + Just ValueContext -> filter (not . isTypeCompl) compls + Just _ -> filter (not . isTypeCompl) compls + -- Add whether the text to insert has backticks + ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls' + + infixCompls :: Maybe Backtick + infixCompls = isUsedAsInfix fullLine prefixModule prefixText pos + + PositionMapping bDelta = bmapping + oldPos = fromDelta bDelta $ VFS.cursorPos prefixInfo + startLoc = lowerRange oldPos + endLoc = upperRange oldPos + localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc + localBindsToCompItem :: Name -> Maybe Type -> CompItem + localBindsToCompItem name typ = CI ctyp pn thisModName ty pn Nothing emptySpanDoc (not $ isValOcc occ) Nothing + where + occ = nameOccName name + ctyp = occNameToComKind Nothing occ + pn = ppr name + ty = ppr <$> typ + thisModName = case nameModule_maybe name of + Nothing -> Left $ nameSrcSpan name + Just m -> Right $ ppr m + + compls = if T.null prefixModule + then localCompls ++ unqualCompls + else Map.findWithDefault [] prefixModule $ getQualCompls qualCompls + + filtListWith f list = + [ f label + | label <- Fuzzy.simpleFilter fullPrefix list + , enteredQual `T.isPrefixOf` label + ] + + filtListWithSnippet f list suffix = + [ toggleSnippets caps withSnippets (f label (snippet <> suffix)) + | (snippet, label) <- list + , Fuzzy.test fullPrefix label + ] + + filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules + filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas + filtOptsCompls = filtListWith mkExtCompl + filtKeywordCompls + | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts) + | otherwise = [] + + stripLeading :: Char -> String -> String + stripLeading _ [] = [] + stripLeading c (s:ss) + | s == c = ss + | otherwise = s:ss + + if + | "import " `T.isPrefixOf` fullLine + -> return filtImportCompls + -- we leave this condition here to avoid duplications and return empty list + -- since HLS implements this completion (#haskell-language-server/pull/662) + | "{-# language" `T.isPrefixOf` T.toLower fullLine + -> return [] + | "{-# options_ghc" `T.isPrefixOf` T.toLower fullLine + -> return $ filtOptsCompls (map (T.pack . stripLeading '-') $ flagsForCompletion False) + | "{-# " `T.isPrefixOf` fullLine + -> return $ filtPragmaCompls (pragmaSuffix fullLine) + | otherwise -> do + let uniqueFiltCompls = nubOrdOn insertText filtCompls + compls <- mapM (mkCompl plId ideOpts) uniqueFiltCompls + return $ filtModNameCompls + ++ filtKeywordCompls + ++ map ( toggleSnippets caps withSnippets) compls + + +-- --------------------------------------------------------------------- +-- helper functions for pragmas +-- --------------------------------------------------------------------- + +validPragmas :: [(T.Text, T.Text)] +validPragmas = + [ ("LANGUAGE ${1:extension}" , "LANGUAGE") + , ("OPTIONS_GHC -${1:option}" , "OPTIONS_GHC") + , ("INLINE ${1:function}" , "INLINE") + , ("NOINLINE ${1:function}" , "NOINLINE") + , ("INLINABLE ${1:function}" , "INLINABLE") + , ("WARNING ${1:message}" , "WARNING") + , ("DEPRECATED ${1:message}" , "DEPRECATED") + , ("ANN ${1:annotation}" , "ANN") + , ("RULES" , "RULES") + , ("SPECIALIZE ${1:function}" , "SPECIALIZE") + , ("SPECIALIZE INLINE ${1:function}", "SPECIALIZE INLINE") + ] + +pragmaSuffix :: T.Text -> T.Text +pragmaSuffix fullLine + | "}" `T.isSuffixOf` fullLine = mempty + | otherwise = " #-}" + +-- --------------------------------------------------------------------- +-- helper functions for infix backticks +-- --------------------------------------------------------------------- + +hasTrailingBacktick :: T.Text -> Position -> Bool +hasTrailingBacktick line Position { _character } + | T.length line > _character = (line `T.index` _character) == '`' + | otherwise = False + +isUsedAsInfix :: T.Text -> T.Text -> T.Text -> Position -> Maybe Backtick +isUsedAsInfix line prefixMod prefixText pos + | hasClosingBacktick && hasOpeningBacktick = Just Surrounded + | hasOpeningBacktick = Just LeftSide + | otherwise = Nothing + where + hasOpeningBacktick = openingBacktick line prefixMod prefixText pos + hasClosingBacktick = hasTrailingBacktick line pos + +openingBacktick :: T.Text -> T.Text -> T.Text -> Position -> Bool +openingBacktick line prefixModule prefixText Position { _character } + | backtickIndex < 0 || backtickIndex > T.length line = False + | otherwise = (line `T.index` backtickIndex) == '`' + where + backtickIndex :: Int + backtickIndex = + let + prefixLength = T.length prefixText + moduleLength = if prefixModule == "" + then 0 + else T.length prefixModule + 1 {- Because of "." -} + in + -- Points to the first letter of either the module or prefix text + _character - (prefixLength + moduleLength) - 1 + + +-- --------------------------------------------------------------------- + +-- | Under certain circumstance GHC generates some extra stuff that we +-- don't want in the autocompleted symbols + {- When e.g. DuplicateRecordFields is enabled, compiler generates + names like "$sel:accessor:One" and "$sel:accessor:Two" to disambiguate record selectors + https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation + -} +-- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace. +stripPrefix :: T.Text -> T.Text +stripPrefix name = T.takeWhile (/=':') $ go prefixes + where + go [] = name + go (p:ps) + | T.isPrefixOf p name = T.drop (T.length p) name + | otherwise = go ps + +-- | Prefixes that can occur in a GHC OccName +prefixes :: [T.Text] +prefixes = + [ + -- long ones + "$con2tag_" + , "$tag2con_" + , "$maxtag_" + + -- four chars + , "$sel:" + , "$tc'" + + -- three chars + , "$dm" + , "$co" + , "$tc" + , "$cp" + , "$fx" + + -- two chars + , "$W" + , "$w" + , "$m" + , "$b" + , "$c" + , "$d" + , "$i" + , "$s" + , "$f" + , "$r" + , "C:" + , "N:" + , "D:" + , "$p" + , "$L" + , "$f" + , "$t" + , "$c" + , "$m" + ] + + +safeTyThingForRecord :: TyThing -> Maybe (T.Text, [T.Text]) +safeTyThingForRecord (AnId _) = Nothing +safeTyThingForRecord (AConLike dc) = + let ctxStr = showGhc . occName . conLikeName $ dc + field_names = T.pack . unpackFS . flLabel <$> conLikeFieldLabels dc + in + Just (ctxStr, field_names) +safeTyThingForRecord _ = Nothing + +mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> T.Text -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem +mkRecordSnippetCompItem uri parent ctxStr compl mn docs imp = r + where + r = CI { + compKind = CiSnippet + , insertText = buildSnippet + , importedFrom = importedFrom + , typeText = Nothing + , label = ctxStr + , isInfix = Nothing + , docs = docs + , isTypeCompl = False + , additionalTextEdits = imp <&> \x -> + ExtendImport + { doc = uri, + thingParent = parent, + importName = showModName $ unLoc $ ideclName $ unLoc x, + importQual = getImportQual x, + newThing = ctxStr + } + } + + placeholder_pairs = zip compl ([1..]::[Int]) + snippet_parts = map (\(x, i) -> x <> "=${" <> T.pack (show i) <> ":_" <> x <> "}") placeholder_pairs + snippet = T.intercalate (T.pack ", ") snippet_parts + buildSnippet = ctxStr <> " {" <> snippet <> "}" + importedFrom = Right mn + +getImportQual :: LImportDecl GhcPs -> Maybe T.Text +getImportQual (L _ imp) + | isQualifiedImport imp = Just $ T.pack $ moduleNameString $ maybe (unLoc $ ideclName imp) unLoc (ideclAs imp) + | otherwise = Nothing diff --git a/src/Development/IDE/Plugin/Completions/Types.hs b/src/Development/IDE/Plugin/Completions/Types.hs --- a/src/Development/IDE/Plugin/Completions/Types.hs +++ b/src/Development/IDE/Plugin/Completions/Types.hs @@ -1,78 +1,78 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -module Development.IDE.Plugin.Completions.Types ( - module Development.IDE.Plugin.Completions.Types -) where - -import Control.DeepSeq -import qualified Data.Map as Map -import qualified Data.Text as T -import SrcLoc - -import Development.IDE.Spans.Common -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) -import Language.LSP.Types (CompletionItemKind, Uri) - --- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs - -data Backtick = Surrounded | LeftSide - deriving (Eq, Ord, Show) - -extendImportCommandId :: Text -extendImportCommandId = "extendImport" - -data ExtendImport = ExtendImport - { doc :: !Uri, - newThing :: !T.Text, - thingParent :: !(Maybe T.Text), - importName :: !T.Text, - importQual :: !(Maybe T.Text) - } - deriving (Eq, Show, Generic) - deriving anyclass (FromJSON, ToJSON) - -data CompItem = CI - { compKind :: CompletionItemKind - , insertText :: T.Text -- ^ Snippet for the completion - , importedFrom :: Either SrcSpan T.Text -- ^ From where this item is imported from. - , typeText :: Maybe T.Text -- ^ Available type information. - , label :: T.Text -- ^ Label to display to the user. - , isInfix :: Maybe Backtick -- ^ Did the completion happen - -- in the context of an infix notation. - , docs :: SpanDoc -- ^ Available documentation. - , isTypeCompl :: Bool - , additionalTextEdits :: Maybe ExtendImport - } - deriving (Eq, Show) - --- Associates a module's qualifier with its members -newtype QualCompls - = QualCompls { getQualCompls :: Map.Map T.Text [CompItem] } - deriving Show -instance Semigroup QualCompls where - (QualCompls a) <> (QualCompls b) = QualCompls $ Map.unionWith (++) a b -instance Monoid QualCompls where - mempty = QualCompls Map.empty - mappend = (Prelude.<>) - --- | End result of the completions -data CachedCompletions = CC - { allModNamesAsNS :: [T.Text] -- ^ All module names in scope. - -- Prelude is a single module - , unqualCompls :: [CompItem] -- ^ All Possible completion items - , qualCompls :: QualCompls -- ^ Completion items associated to - -- to a specific module name. - , importableModules :: [T.Text] -- ^ All modules that may be imported. - } deriving Show - -instance NFData CachedCompletions where - rnf = rwhnf - -instance Monoid CachedCompletions where - mempty = CC mempty mempty mempty mempty - -instance Semigroup CachedCompletions where - CC a b c d <> CC a' b' c' d' = - CC (a<>a') (b<>b') (c<>c') (d<>d') +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +module Development.IDE.Plugin.Completions.Types ( + module Development.IDE.Plugin.Completions.Types +) where + +import Control.DeepSeq +import qualified Data.Map as Map +import qualified Data.Text as T +import SrcLoc + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import Development.IDE.Spans.Common +import GHC.Generics (Generic) +import Language.LSP.Types (CompletionItemKind, Uri) + +-- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs + +data Backtick = Surrounded | LeftSide + deriving (Eq, Ord, Show) + +extendImportCommandId :: Text +extendImportCommandId = "extendImport" + +data ExtendImport = ExtendImport + { doc :: !Uri, + newThing :: !T.Text, + thingParent :: !(Maybe T.Text), + importName :: !T.Text, + importQual :: !(Maybe T.Text) + } + deriving (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +data CompItem = CI + { compKind :: CompletionItemKind + , insertText :: T.Text -- ^ Snippet for the completion + , importedFrom :: Either SrcSpan T.Text -- ^ From where this item is imported from. + , typeText :: Maybe T.Text -- ^ Available type information. + , label :: T.Text -- ^ Label to display to the user. + , isInfix :: Maybe Backtick -- ^ Did the completion happen + -- in the context of an infix notation. + , docs :: SpanDoc -- ^ Available documentation. + , isTypeCompl :: Bool + , additionalTextEdits :: Maybe ExtendImport + } + deriving (Eq, Show) + +-- Associates a module's qualifier with its members +newtype QualCompls + = QualCompls { getQualCompls :: Map.Map T.Text [CompItem] } + deriving Show +instance Semigroup QualCompls where + (QualCompls a) <> (QualCompls b) = QualCompls $ Map.unionWith (++) a b +instance Monoid QualCompls where + mempty = QualCompls Map.empty + mappend = (Prelude.<>) + +-- | End result of the completions +data CachedCompletions = CC + { allModNamesAsNS :: [T.Text] -- ^ All module names in scope. + -- Prelude is a single module + , unqualCompls :: [CompItem] -- ^ All Possible completion items + , qualCompls :: QualCompls -- ^ Completion items associated to + -- to a specific module name. + , importableModules :: [T.Text] -- ^ All modules that may be imported. + } deriving Show + +instance NFData CachedCompletions where + rnf = rwhnf + +instance Monoid CachedCompletions where + mempty = CC mempty mempty mempty mempty + +instance Semigroup CachedCompletions where + CC a b c d <> CC a' b' c' d' = + CC (a<>a') (b<>b') (c<>c') (d<>d') diff --git a/src/Development/IDE/Plugin/HLS.hs b/src/Development/IDE/Plugin/HLS.hs --- a/src/Development/IDE/Plugin/HLS.hs +++ b/src/Development/IDE/Plugin/HLS.hs @@ -1,186 +1,186 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} - -module Development.IDE.Plugin.HLS - ( - asGhcIdePlugin - ) where - -import Control.Exception (SomeException) -import Control.Monad -import qualified Data.Aeson as J -import Data.Bifunctor -import Data.Dependent.Map (DMap) -import qualified Data.Dependent.Map as DMap -import Data.Dependent.Sum -import Data.Either -import qualified Data.List as List -import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.String -import qualified Data.Text as T -import Development.IDE.Core.Shake -import Development.IDE.Core.Tracing -import Development.IDE.LSP.Server -import Development.IDE.Plugin -import Development.Shake (Rules) -import Ide.Plugin.Config -import Ide.PluginUtils (getClientConfig) -import Ide.Types as HLS -import qualified Language.LSP.Server as LSP -import Language.LSP.Types -import qualified Language.LSP.Types as J -import Text.Regex.TDFA.Text () -import UnliftIO (MonadUnliftIO) -import UnliftIO.Async (forConcurrently) -import UnliftIO.Exception (catchAny) - --- --------------------------------------------------------------------- --- - --- | Map a set of plugins to the underlying ghcide engine. -asGhcIdePlugin :: Config -> IdePlugins IdeState -> Plugin Config -asGhcIdePlugin defaultConfig mp = - mkPlugin rulesPlugins HLS.pluginRules <> - mkPlugin executeCommandPlugins HLS.pluginCommands <> - mkPlugin (extensiblePlugins defaultConfig) HLS.pluginHandlers - where - ls = Map.toList (ipMap mp) - - mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> b) -> Plugin Config - mkPlugin maker selector = - case map (second selector) ls of - -- If there are no plugins that provide a descriptor, use mempty to - -- create the plugin – otherwise we we end up declaring handlers for - -- capabilities that there are no plugins for - [] -> mempty - xs -> maker xs - --- --------------------------------------------------------------------- - -rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config -rulesPlugins rs = Plugin rules mempty - where - rules = foldMap snd rs - --- --------------------------------------------------------------------- - -executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config -executeCommandPlugins ecs = Plugin mempty (executeCommandHandlers ecs) - -executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config) -executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd - where - pluginMap = Map.fromList ecs - - parseCmdId :: T.Text -> Maybe (PluginId, CommandId) - parseCmdId x = case T.splitOn ":" x of - [plugin, command] -> Just (PluginId plugin, CommandId command) - [_, plugin, command] -> Just (PluginId plugin, CommandId command) - _ -> Nothing - - -- The parameters to the HLS command are always the first element - - execCmd ide (ExecuteCommandParams _ cmdId args) = do - let cmdParams :: J.Value - cmdParams = case args of - Just (J.List (x:_)) -> x - _ -> J.Null - case parseCmdId cmdId of - -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions - Just ("hls", "fallbackCodeAction") -> - case J.fromJSON cmdParams of - J.Success (FallbackCodeActionParams mEdit mCmd) -> do - - -- Send off the workspace request if it has one - forM_ mEdit $ \edit -> - LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) - - case mCmd of - -- If we have a command, continue to execute it - Just (J.Command _ innerCmdId innerArgs) - -> execCmd ide (ExecuteCommandParams Nothing innerCmdId innerArgs) - Nothing -> return $ Right J.Null - - J.Error _str -> return $ Right J.Null - - -- Just an ordinary HIE command - Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams - - -- Couldn't parse the command identifier - _ -> return $ Left $ ResponseError InvalidParams "Invalid command identifier" Nothing - - runPluginCommand ide p@(PluginId p') com@(CommandId com') arg = - case Map.lookup p pluginMap of - Nothing -> return - (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing) - Just xs -> case List.find ((com ==) . commandId) xs of - Nothing -> return $ Left $ - ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p' - <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing - Just (PluginCommand _ _ f) -> case J.fromJSON arg of - J.Error err -> return $ Left $ - ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p' - <> ": " <> T.pack err - <> "\narg = " <> T.pack (show arg)) Nothing - J.Success a -> f ide a - --- --------------------------------------------------------------------- - -extensiblePlugins :: Config -> [(PluginId, PluginHandlers IdeState)] -> Plugin Config -extensiblePlugins defaultConfig xs = Plugin mempty handlers - where - IdeHandlers handlers' = foldMap bakePluginId xs - bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers - bakePluginId (pid,PluginHandlers hs) = IdeHandlers $ DMap.map - (\(PluginHandler f) -> IdeHandler [(pid,f pid)]) - hs - handlers = mconcat $ do - (IdeMethod m :=> IdeHandler fs') <- DMap.assocs handlers' - pure $ requestHandler m $ \ide params -> do - config <- fromMaybe defaultConfig <$> Ide.PluginUtils.getClientConfig - let fs = filter (\(pid,_) -> pluginEnabled m pid config) fs' - case nonEmpty fs of - Nothing -> pure $ Left $ ResponseError InvalidRequest - ("No plugin enabled for " <> T.pack (show m) <> ", available: " <> T.pack (show $ map fst fs)) - Nothing - Just fs -> do - let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e) - es <- runConcurrently msg (show m) fs ide params - let (errs,succs) = partitionEithers $ toList es - case nonEmpty succs of - Nothing -> pure $ Left $ combineErrors errs - Just xs -> do - caps <- LSP.getClientCapabilities - pure $ Right $ combineResponses m config caps params xs - -runConcurrently - :: MonadUnliftIO m - => (SomeException -> PluginId -> T.Text) - -> String -- ^ label - -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d))) - -> a - -> b - -> m (NonEmpty (Either ResponseError d)) -runConcurrently msg method fs a b = fmap join $ forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do - f a b - `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing) - -combineErrors :: [ResponseError] -> ResponseError -combineErrors [x] = x -combineErrors xs = ResponseError InternalError (T.pack (show xs)) Nothing - --- | Combine the 'PluginHandler' for all plugins -newtype IdeHandler (m :: J.Method FromClient Request) - = IdeHandler [(PluginId,IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))] - --- | Combine the 'PluginHandlers' for all plugins -newtype IdeHandlers = IdeHandlers (DMap IdeMethod IdeHandler) - -instance Semigroup IdeHandlers where - (IdeHandlers a) <> (IdeHandlers b) = IdeHandlers $ DMap.unionWithKey go a b - where - go _ (IdeHandler a) (IdeHandler b) = IdeHandler (a ++ b) -instance Monoid IdeHandlers where - mempty = IdeHandlers mempty +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} + +module Development.IDE.Plugin.HLS + ( + asGhcIdePlugin + ) where + +import Control.Exception (SomeException) +import Control.Monad +import qualified Data.Aeson as J +import Data.Bifunctor +import Data.Dependent.Map (DMap) +import qualified Data.Dependent.Map as DMap +import Data.Dependent.Sum +import Data.Either +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.String +import qualified Data.Text as T +import Development.IDE.Core.Shake +import Development.IDE.Core.Tracing +import Development.IDE.LSP.Server +import Development.IDE.Plugin +import Development.Shake (Rules) +import Ide.Plugin.Config +import Ide.PluginUtils (getClientConfig) +import Ide.Types as HLS +import qualified Language.LSP.Server as LSP +import Language.LSP.Types +import qualified Language.LSP.Types as J +import Text.Regex.TDFA.Text () +import UnliftIO (MonadUnliftIO) +import UnliftIO.Async (forConcurrently) +import UnliftIO.Exception (catchAny) + +-- --------------------------------------------------------------------- +-- + +-- | Map a set of plugins to the underlying ghcide engine. +asGhcIdePlugin :: Config -> IdePlugins IdeState -> Plugin Config +asGhcIdePlugin defaultConfig mp = + mkPlugin rulesPlugins HLS.pluginRules <> + mkPlugin executeCommandPlugins HLS.pluginCommands <> + mkPlugin (extensiblePlugins defaultConfig) HLS.pluginHandlers + where + ls = Map.toList (ipMap mp) + + mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> b) -> Plugin Config + mkPlugin maker selector = + case map (second selector) ls of + -- If there are no plugins that provide a descriptor, use mempty to + -- create the plugin – otherwise we we end up declaring handlers for + -- capabilities that there are no plugins for + [] -> mempty + xs -> maker xs + +-- --------------------------------------------------------------------- + +rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config +rulesPlugins rs = Plugin rules mempty + where + rules = foldMap snd rs + +-- --------------------------------------------------------------------- + +executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config +executeCommandPlugins ecs = Plugin mempty (executeCommandHandlers ecs) + +executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config) +executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd + where + pluginMap = Map.fromList ecs + + parseCmdId :: T.Text -> Maybe (PluginId, CommandId) + parseCmdId x = case T.splitOn ":" x of + [plugin, command] -> Just (PluginId plugin, CommandId command) + [_, plugin, command] -> Just (PluginId plugin, CommandId command) + _ -> Nothing + + -- The parameters to the HLS command are always the first element + + execCmd ide (ExecuteCommandParams _ cmdId args) = do + let cmdParams :: J.Value + cmdParams = case args of + Just (J.List (x:_)) -> x + _ -> J.Null + case parseCmdId cmdId of + -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions + Just ("hls", "fallbackCodeAction") -> + case J.fromJSON cmdParams of + J.Success (FallbackCodeActionParams mEdit mCmd) -> do + + -- Send off the workspace request if it has one + forM_ mEdit $ \edit -> + LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + + case mCmd of + -- If we have a command, continue to execute it + Just (J.Command _ innerCmdId innerArgs) + -> execCmd ide (ExecuteCommandParams Nothing innerCmdId innerArgs) + Nothing -> return $ Right J.Null + + J.Error _str -> return $ Right J.Null + + -- Just an ordinary HIE command + Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams + + -- Couldn't parse the command identifier + _ -> return $ Left $ ResponseError InvalidParams "Invalid command identifier" Nothing + + runPluginCommand ide p@(PluginId p') com@(CommandId com') arg = + case Map.lookup p pluginMap of + Nothing -> return + (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing) + Just xs -> case List.find ((com ==) . commandId) xs of + Nothing -> return $ Left $ + ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p' + <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing + Just (PluginCommand _ _ f) -> case J.fromJSON arg of + J.Error err -> return $ Left $ + ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p' + <> ": " <> T.pack err + <> "\narg = " <> T.pack (show arg)) Nothing + J.Success a -> f ide a + +-- --------------------------------------------------------------------- + +extensiblePlugins :: Config -> [(PluginId, PluginHandlers IdeState)] -> Plugin Config +extensiblePlugins defaultConfig xs = Plugin mempty handlers + where + IdeHandlers handlers' = foldMap bakePluginId xs + bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers + bakePluginId (pid,PluginHandlers hs) = IdeHandlers $ DMap.map + (\(PluginHandler f) -> IdeHandler [(pid,f pid)]) + hs + handlers = mconcat $ do + (IdeMethod m :=> IdeHandler fs') <- DMap.assocs handlers' + pure $ requestHandler m $ \ide params -> do + config <- fromMaybe defaultConfig <$> Ide.PluginUtils.getClientConfig + let fs = filter (\(pid,_) -> pluginEnabled m pid config) fs' + case nonEmpty fs of + Nothing -> pure $ Left $ ResponseError InvalidRequest + ("No plugin enabled for " <> T.pack (show m) <> ", available: " <> T.pack (show $ map fst fs)) + Nothing + Just fs -> do + let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e) + es <- runConcurrently msg (show m) fs ide params + let (errs,succs) = partitionEithers $ toList es + case nonEmpty succs of + Nothing -> pure $ Left $ combineErrors errs + Just xs -> do + caps <- LSP.getClientCapabilities + pure $ Right $ combineResponses m config caps params xs + +runConcurrently + :: MonadUnliftIO m + => (SomeException -> PluginId -> T.Text) + -> String -- ^ label + -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d))) + -> a + -> b + -> m (NonEmpty (Either ResponseError d)) +runConcurrently msg method fs a b = fmap join $ forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do + f a b + `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing) + +combineErrors :: [ResponseError] -> ResponseError +combineErrors [x] = x +combineErrors xs = ResponseError InternalError (T.pack (show xs)) Nothing + +-- | Combine the 'PluginHandler' for all plugins +newtype IdeHandler (m :: J.Method FromClient Request) + = IdeHandler [(PluginId,IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))] + +-- | Combine the 'PluginHandlers' for all plugins +newtype IdeHandlers = IdeHandlers (DMap IdeMethod IdeHandler) + +instance Semigroup IdeHandlers where + (IdeHandlers a) <> (IdeHandlers b) = IdeHandlers $ DMap.unionWithKey go a b + where + go _ (IdeHandler a) (IdeHandler b) = IdeHandler (a ++ b) +instance Monoid IdeHandlers where + mempty = IdeHandlers mempty diff --git a/src/Development/IDE/Plugin/HLS/GhcIde.hs b/src/Development/IDE/Plugin/HLS/GhcIde.hs --- a/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -1,48 +1,48 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Exposes the ghcide features as an HLS plugin -module Development.IDE.Plugin.HLS.GhcIde - ( - descriptors - ) where -import Development.IDE -import Development.IDE.LSP.HoverDefinition -import Development.IDE.LSP.Outline -import Ide.Types -import Language.LSP.Types -import Language.LSP.Server (LspM) -import Text.Regex.TDFA.Text() -import qualified Development.IDE.Plugin.CodeAction as CodeAction -import qualified Development.IDE.Plugin.Completions as Completions -import qualified Development.IDE.Plugin.TypeLenses as TypeLenses -import Control.Monad.IO.Class - -descriptors :: [PluginDescriptor IdeState] -descriptors = - [ descriptor "ghcide-hover-and-symbols", - CodeAction.descriptor "ghcide-code-actions", - Completions.descriptor "ghcide-completions", - TypeLenses.descriptor "ghcide-type-lenses" - ] - --- --------------------------------------------------------------------- - -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentHover hover' - <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider - } - --- --------------------------------------------------------------------- - -hover' :: IdeState -> PluginId -> HoverParams -> LspM c (Either ResponseError (Maybe Hover)) -hover' ideState _ HoverParams{..} = do - liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ - hover ideState TextDocumentPositionParams{..} - --- --------------------------------------------------------------------- -symbolsProvider :: IdeState -> PluginId -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation)) -symbolsProvider ide _ params = moduleOutline ide params - --- --------------------------------------------------------------------- +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Exposes the ghcide features as an HLS plugin +module Development.IDE.Plugin.HLS.GhcIde + ( + descriptors + ) where +import Development.IDE +import Development.IDE.LSP.HoverDefinition +import Development.IDE.LSP.Outline +import Ide.Types +import Language.LSP.Types +import Language.LSP.Server (LspM) +import Text.Regex.TDFA.Text() +import qualified Development.IDE.Plugin.CodeAction as CodeAction +import qualified Development.IDE.Plugin.Completions as Completions +import qualified Development.IDE.Plugin.TypeLenses as TypeLenses +import Control.Monad.IO.Class + +descriptors :: [PluginDescriptor IdeState] +descriptors = + [ descriptor "ghcide-hover-and-symbols", + CodeAction.descriptor "ghcide-code-actions", + Completions.descriptor "ghcide-completions", + TypeLenses.descriptor "ghcide-type-lenses" + ] + +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) + { pluginHandlers = mkPluginHandler STextDocumentHover hover' + <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider + } + +-- --------------------------------------------------------------------- + +hover' :: IdeState -> PluginId -> HoverParams -> LspM c (Either ResponseError (Maybe Hover)) +hover' ideState _ HoverParams{..} = do + liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ + hover ideState TextDocumentPositionParams{..} + +-- --------------------------------------------------------------------- +symbolsProvider :: IdeState -> PluginId -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation)) +symbolsProvider ide _ params = moduleOutline ide params + +-- --------------------------------------------------------------------- diff --git a/src/Development/IDE/Plugin/Test.hs b/src/Development/IDE/Plugin/Test.hs --- a/src/Development/IDE/Plugin/Test.hs +++ b/src/Development/IDE/Plugin/Test.hs @@ -1,123 +1,123 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DerivingStrategies #-} --- | A plugin that adds custom messages for use in tests -module Development.IDE.Plugin.Test - ( TestRequest(..) - , WaitForIdeRuleResult(..) - , plugin - , blockCommandDescriptor - , blockCommandId - ) where - -import Control.Monad.STM -import Control.Monad.IO.Class -import Data.Aeson -import Data.Aeson.Types -import Data.CaseInsensitive (CI, original) -import Development.IDE.Core.Service -import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat -import Development.IDE.Types.HscEnvEq (HscEnvEq(hscEnv)) -import Development.IDE.Plugin -import Development.IDE.LSP.Server -import Development.IDE.Types.Action -import GHC.Generics (Generic) -import GhcPlugins (HscEnv(hsc_dflags)) -import Language.LSP.Types -import System.Time.Extra -import Development.IDE.Core.RuleTypes -import Control.Monad -import Development.Shake (Action) -import Data.Maybe (isJust) -import Data.Bifunctor -import Data.Text (pack, Text) -import Data.String -import Development.IDE.Types.Location (fromUri) -import Control.Concurrent (threadDelay) -import Ide.Types -import qualified Language.LSP.Server as LSP - -data TestRequest - = BlockSeconds Seconds -- ^ :: Null - | GetInterfaceFilesDir FilePath -- ^ :: String - | GetShakeSessionQueueCount -- ^ :: Number - | WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null - | WaitForIdeRule String Uri -- ^ :: WaitForIdeRuleResult - deriving Generic - deriving anyclass (FromJSON, ToJSON) - -newtype WaitForIdeRuleResult = WaitForIdeRuleResult { ideResultSuccess::Bool} - deriving newtype (FromJSON, ToJSON) - -plugin :: Plugin c -plugin = Plugin { - pluginRules = return (), - pluginHandlers = requestHandler (SCustomMethod "test") testRequestHandler' -} - where - testRequestHandler' ide req - | Just customReq <- parseMaybe parseJSON req - = testRequestHandler ide customReq - | otherwise - = return $ Left - $ ResponseError InvalidRequest "Cannot parse request" Nothing - - -testRequestHandler :: IdeState - -> TestRequest - -> LSP.LspM c (Either ResponseError Value) -testRequestHandler _ (BlockSeconds secs) = do - LSP.sendNotification (SCustomMethod "ghcide/blocking/request") $ - toJSON secs - liftIO $ sleep secs - return (Right Null) -testRequestHandler s (GetInterfaceFilesDir fp) = liftIO $ do - let nfp = toNormalizedFilePath fp - sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp - let hiPath = hiDir $ hsc_dflags $ hscEnv sess - return $ Right (toJSON hiPath) -testRequestHandler s GetShakeSessionQueueCount = liftIO $ do - n <- atomically $ countQueue $ actionQueue $ shakeExtras s - return $ Right (toJSON n) -testRequestHandler s WaitForShakeQueue = liftIO $ do - atomically $ do - n <- countQueue $ actionQueue $ shakeExtras s - when (n>0) retry - return $ Right Null -testRequestHandler s (WaitForIdeRule k file) = liftIO $ do - let nfp = fromUri $ toNormalizedUri file - success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp - let res = WaitForIdeRuleResult <$> success - return $ bimap mkResponseError toJSON res - -mkResponseError :: Text -> ResponseError -mkResponseError msg = ResponseError InvalidRequest msg Nothing - -parseAction :: CI String -> NormalizedFilePath -> Action (Either Text Bool) -parseAction "typecheck" fp = Right . isJust <$> use TypeCheck fp -parseAction "getLocatedImports" fp = Right . isJust <$> use GetLocatedImports fp -parseAction "getmodsummary" fp = Right . isJust <$> use GetModSummary fp -parseAction "getmodsummarywithouttimestamps" fp = Right . isJust <$> use GetModSummaryWithoutTimestamps fp -parseAction "getparsedmodule" fp = Right . isJust <$> use GetParsedModule fp -parseAction "ghcsession" fp = Right . isJust <$> use GhcSession fp -parseAction "ghcsessiondeps" fp = Right . isJust <$> use GhcSessionDeps fp -parseAction "gethieast" fp = Right . isJust <$> use GetHieAst fp -parseAction "getDependencies" fp = Right . isJust <$> use GetDependencies fp -parseAction "getFileContents" fp = Right . isJust <$> use GetFileContents fp -parseAction other _ = return $ Left $ "Cannot parse ide rule: " <> pack (original other) - --- | a command that blocks forever. Used for testing -blockCommandId :: Text -blockCommandId = "ghcide.command.block" - -blockCommandDescriptor :: PluginId -> PluginDescriptor state -blockCommandDescriptor plId = (defaultPluginDescriptor plId) { - pluginCommands = [PluginCommand (CommandId blockCommandId) "blocks forever" blockCommandHandler] -} - -blockCommandHandler :: CommandFunction state ExecuteCommandParams -blockCommandHandler _ideState _params = do - LSP.sendNotification (SCustomMethod "ghcide/blocking/command") Null - liftIO $ threadDelay maxBound - return (Right Null) +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +-- | A plugin that adds custom messages for use in tests +module Development.IDE.Plugin.Test + ( TestRequest(..) + , WaitForIdeRuleResult(..) + , plugin + , blockCommandDescriptor + , blockCommandId + ) where + +import Control.Concurrent (threadDelay) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.STM +import Data.Aeson +import Data.Aeson.Types +import Data.Bifunctor +import Data.CaseInsensitive (CI, original) +import Data.Maybe (isJust) +import Data.String +import Data.Text (Text, pack) +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Service +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat +import Development.IDE.LSP.Server +import Development.IDE.Plugin +import Development.IDE.Types.Action +import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) +import Development.IDE.Types.Location (fromUri) +import Development.Shake (Action) +import GHC.Generics (Generic) +import GhcPlugins (HscEnv (hsc_dflags)) +import Ide.Types +import qualified Language.LSP.Server as LSP +import Language.LSP.Types +import System.Time.Extra + +data TestRequest + = BlockSeconds Seconds -- ^ :: Null + | GetInterfaceFilesDir FilePath -- ^ :: String + | GetShakeSessionQueueCount -- ^ :: Number + | WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null + | WaitForIdeRule String Uri -- ^ :: WaitForIdeRuleResult + deriving Generic + deriving anyclass (FromJSON, ToJSON) + +newtype WaitForIdeRuleResult = WaitForIdeRuleResult { ideResultSuccess::Bool} + deriving newtype (FromJSON, ToJSON) + +plugin :: Plugin c +plugin = Plugin { + pluginRules = return (), + pluginHandlers = requestHandler (SCustomMethod "test") testRequestHandler' +} + where + testRequestHandler' ide req + | Just customReq <- parseMaybe parseJSON req + = testRequestHandler ide customReq + | otherwise + = return $ Left + $ ResponseError InvalidRequest "Cannot parse request" Nothing + + +testRequestHandler :: IdeState + -> TestRequest + -> LSP.LspM c (Either ResponseError Value) +testRequestHandler _ (BlockSeconds secs) = do + LSP.sendNotification (SCustomMethod "ghcide/blocking/request") $ + toJSON secs + liftIO $ sleep secs + return (Right Null) +testRequestHandler s (GetInterfaceFilesDir fp) = liftIO $ do + let nfp = toNormalizedFilePath fp + sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp + let hiPath = hiDir $ hsc_dflags $ hscEnv sess + return $ Right (toJSON hiPath) +testRequestHandler s GetShakeSessionQueueCount = liftIO $ do + n <- atomically $ countQueue $ actionQueue $ shakeExtras s + return $ Right (toJSON n) +testRequestHandler s WaitForShakeQueue = liftIO $ do + atomically $ do + n <- countQueue $ actionQueue $ shakeExtras s + when (n>0) retry + return $ Right Null +testRequestHandler s (WaitForIdeRule k file) = liftIO $ do + let nfp = fromUri $ toNormalizedUri file + success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp + let res = WaitForIdeRuleResult <$> success + return $ bimap mkResponseError toJSON res + +mkResponseError :: Text -> ResponseError +mkResponseError msg = ResponseError InvalidRequest msg Nothing + +parseAction :: CI String -> NormalizedFilePath -> Action (Either Text Bool) +parseAction "typecheck" fp = Right . isJust <$> use TypeCheck fp +parseAction "getLocatedImports" fp = Right . isJust <$> use GetLocatedImports fp +parseAction "getmodsummary" fp = Right . isJust <$> use GetModSummary fp +parseAction "getmodsummarywithouttimestamps" fp = Right . isJust <$> use GetModSummaryWithoutTimestamps fp +parseAction "getparsedmodule" fp = Right . isJust <$> use GetParsedModule fp +parseAction "ghcsession" fp = Right . isJust <$> use GhcSession fp +parseAction "ghcsessiondeps" fp = Right . isJust <$> use GhcSessionDeps fp +parseAction "gethieast" fp = Right . isJust <$> use GetHieAst fp +parseAction "getDependencies" fp = Right . isJust <$> use GetDependencies fp +parseAction "getFileContents" fp = Right . isJust <$> use GetFileContents fp +parseAction other _ = return $ Left $ "Cannot parse ide rule: " <> pack (original other) + +-- | a command that blocks forever. Used for testing +blockCommandId :: Text +blockCommandId = "ghcide.command.block" + +blockCommandDescriptor :: PluginId -> PluginDescriptor state +blockCommandDescriptor plId = (defaultPluginDescriptor plId) { + pluginCommands = [PluginCommand (CommandId blockCommandId) "blocks forever" blockCommandHandler] +} + +blockCommandHandler :: CommandFunction state ExecuteCommandParams +blockCommandHandler _ideState _params = do + LSP.sendNotification (SCustomMethod "ghcide/blocking/command") Null + liftIO $ threadDelay maxBound + return (Right Null) diff --git a/src/Development/IDE/Plugin/TypeLenses.hs b/src/Development/IDE/Plugin/TypeLenses.hs --- a/src/Development/IDE/Plugin/TypeLenses.hs +++ b/src/Development/IDE/Plugin/TypeLenses.hs @@ -1,117 +1,277 @@ --- | An HLS plugin to provide code lenses for type signatures -module Development.IDE.Plugin.TypeLenses - ( descriptor, - suggestSignature, - typeLensCommandId, - ) -where - -import Control.Monad.IO.Class -import Data.Aeson.Types (Value (..), toJSON) -import qualified Data.HashMap.Strict as Map -import qualified Data.Text as T -import Development.IDE.Core.RuleTypes (TypeCheck (TypeCheck)) -import Development.IDE.Core.Rules (IdeState, runAction) -import Development.IDE.Core.Service (getDiagnostics) -import Development.IDE.Core.Shake (getHiddenDiagnostics, use) -import Development.IDE.Types.Location - ( Position (Position, _character, _line), - Range (Range, _end, _start), - toNormalizedFilePath', - uriToFilePath', - ) -import Ide.PluginUtils (mkLspCommand) -import Ide.Types - ( CommandFunction, - CommandId (CommandId), - PluginCommand (PluginCommand), - PluginDescriptor(..), - PluginId, - defaultPluginDescriptor, - mkPluginHandler - ) -import qualified Language.LSP.Server as LSP -import Language.LSP.Types - ( ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), - CodeLens (CodeLens), - CodeLensParams (CodeLensParams, _textDocument), - Diagnostic (..), - List (..), - ResponseError, - TextDocumentIdentifier (TextDocumentIdentifier), - TextEdit (TextEdit), - WorkspaceEdit (WorkspaceEdit), - SMethod(..) - ) -import Text.Regex.TDFA ((=~)) - -typeLensCommandId :: T.Text -typeLensCommandId = "typesignature.add" - -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = - (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider, - pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] - } - -codeLensProvider :: - IdeState -> - PluginId -> - CodeLensParams -> - LSP.LspM c (Either ResponseError (List CodeLens)) -codeLensProvider ideState pId CodeLensParams {_textDocument = TextDocumentIdentifier uri} = do - fmap (Right . List) $ case uriToFilePath' uri of - Just (toNormalizedFilePath' -> filePath) -> liftIO $ do - _ <- runAction "codeLens" ideState (use TypeCheck filePath) - diag <- getDiagnostics ideState - hDiag <- getHiddenDiagnostics ideState - sequence - [ generateLens pId _range title edit - | (dFile, _, dDiag@Diagnostic {_range = _range}) <- diag ++ hDiag, - dFile == filePath, - (title, tedit) <- suggestSignature False dDiag, - let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing - ] - Nothing -> pure [] - -generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> IO CodeLens -generateLens pId _range title edit = do - let cId = mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit]) - return $ CodeLens _range (Just cId) Nothing - -commandHandler :: CommandFunction IdeState WorkspaceEdit -commandHandler _ideState wedit = do - _ <- LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - return $ Right Null - -suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])] -suggestSignature isQuickFix Diagnostic {_range = _range@Range {..}, ..} - | _message - =~ ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text) = - let signature = - removeInitialForAll $ - T.takeWhile (\x -> x /= '*' && x /= '•') $ - T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message - startOfLine = Position (_line _start) startCharacter - beforeLine = Range startOfLine startOfLine - title = if isQuickFix then "add signature: " <> signature else signature - action = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " " - in [(title, [action])] - where - removeInitialForAll :: T.Text -> T.Text - removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty)) - | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty)) - | otherwise = nm <> ty - startCharacter - | "Polymorphic local binding" `T.isPrefixOf` _message = - _character _start - | otherwise = - 0 -suggestSignature _ _ = [] - -unifySpaces :: T.Text -> T.Text -unifySpaces = T.unwords . T.words - -filterNewlines :: T.Text -> T.Text -filterNewlines = T.concat . T.lines +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TypeFamilies #-} + +-- | An HLS plugin to provide code lenses for type signatures +module Development.IDE.Plugin.TypeLenses ( + descriptor, + suggestSignature, + typeLensCommandId, + GlobalBindingTypeSig (..), + GetGlobalBindingTypeSigs (..), + GlobalBindingTypeSigsResult (..), +) where + +import Avail (availsToNameSet) +import Control.DeepSeq (rwhnf) +import Control.Monad (join) +import Control.Monad.Extra (whenMaybe) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.Aeson as A +import Data.Aeson.Types (Value (..), toJSON) +import qualified Data.Aeson.Types as A +import qualified Data.HashMap.Strict as Map +import Data.List (find) +import Data.Maybe (catMaybes, fromJust, + fromMaybe) +import qualified Data.Text as T +import Development.IDE (GhcSession (..), + HscEnvEq (hscEnv), + RuleResult, Rules, define, + srcSpanToRange) +import Development.IDE.Core.Compile (TcModuleResult (..)) +import Development.IDE.Core.RuleTypes (GetBindings (GetBindings), + TypeCheck (TypeCheck)) +import Development.IDE.Core.Rules (IdeState, runAction) +import Development.IDE.Core.Service (getDiagnostics) +import Development.IDE.Core.Shake (getHiddenDiagnostics, use) +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Util (printName) +import Development.IDE.Spans.Common (safeTyThingType) +import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope) +import Development.IDE.Types.Location (Position (Position, _character, _line), + Range (Range, _end, _start), + toNormalizedFilePath', + uriToFilePath') +import Development.Shake.Classes +import GHC.Generics (Generic) +import GhcPlugins (GlobalRdrEnv, + HscEnv (hsc_dflags), SDoc, + elemNameSet, getSrcSpan, + idName, lookupTypeEnv, + mkRealSrcLoc, + realSrcLocSpan, + tidyOpenType) +import HscTypes (mkPrintUnqualified) +import Ide.Plugin.Config (Config, + PluginConfig (plcConfig)) +import Ide.PluginUtils (getPluginConfig, + mkLspCommand) +import Ide.Types (CommandFunction, + CommandId (CommandId), + PluginCommand (PluginCommand), + PluginDescriptor (..), + PluginId, + defaultPluginDescriptor, + mkPluginHandler) +import qualified Language.LSP.Server as LSP +import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), + CodeLens (CodeLens), + CodeLensParams (CodeLensParams, _textDocument), + Diagnostic (..), + List (..), ResponseError, + SMethod (..), + TextDocumentIdentifier (TextDocumentIdentifier), + TextEdit (TextEdit), + WorkspaceEdit (WorkspaceEdit)) +import Outputable (showSDocForUser) +import PatSyn (patSynName) +import TcEnv (tcInitTidyEnv) +import TcRnMonad (initTcWithGbl) +import TcRnTypes (TcGblEnv (..)) +import TcType (pprSigmaType) +import Text.Regex.TDFA ((=~), (=~~)) + +typeLensCommandId :: T.Text +typeLensCommandId = "typesignature.add" + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = + (defaultPluginDescriptor plId) + { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider + , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] + , pluginRules = rules + } + +codeLensProvider :: + IdeState -> + PluginId -> + CodeLensParams -> + LSP.LspM Config (Either ResponseError (List CodeLens)) +codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do + (fromMaybe Always . join -> mode) <- fmap (parseCustomConfig . plcConfig) <$> getPluginConfig pId + fmap (Right . List) $ case uriToFilePath' uri of + Just (toNormalizedFilePath' -> filePath) -> liftIO $ do + tmr <- runAction "codeLens.TypeCheck" ideState (use TypeCheck filePath) + bindings <- runAction "codeLens.GetBindings" ideState (use GetBindings filePath) + gblSigs <- runAction "codeLens.GetGlobalBindingTypeSigs" ideState (use GetGlobalBindingTypeSigs filePath) + + diag <- getDiagnostics ideState + hDiag <- getHiddenDiagnostics ideState + + let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing + generateLensForGlobal sig@GlobalBindingTypeSig{..} = do + range <- srcSpanToRange $ gbSrcSpan sig + tedit <- gblBindingTypeSigToEdit sig + let wedit = toWorkSpaceEdit [tedit] + pure $ generateLens pId range (T.pack gbRendered) wedit + gblSigs' = maybe [] (\(GlobalBindingTypeSigsResult x) -> x) gblSigs + generateLensFromDiags f = + sequence + [ pure $ generateLens pId _range title edit + | (dFile, _, dDiag@Diagnostic{_range = _range}) <- diag ++ hDiag + , dFile == filePath + , (title, tedit) <- f dDiag + , let edit = toWorkSpaceEdit tedit + ] + + case mode of + Always -> + pure (catMaybes $ generateLensForGlobal <$> gblSigs') + <> generateLensFromDiags (suggestLocalSignature False tmr bindings) -- we still need diagnostics for local bindings + Exported -> pure $ catMaybes $ generateLensForGlobal <$> filter gbExported gblSigs' + Diagnostics -> generateLensFromDiags $ suggestSignature False gblSigs tmr bindings + Nothing -> pure [] + +generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens +generateLens pId _range title edit = + let cId = mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit]) + in CodeLens _range (Just cId) Nothing + +commandHandler :: CommandFunction IdeState WorkspaceEdit +commandHandler _ideState wedit = do + _ <- LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + return $ Right Null + +-------------------------------------------------------------------------------- + +suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] +suggestSignature isQuickFix mGblSigs mTmr mBindings diag = + suggestGlobalSignature isQuickFix mGblSigs diag <> suggestLocalSignature isQuickFix mTmr mBindings diag + +suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, [TextEdit])] +suggestGlobalSignature isQuickFix mGblSigs Diagnostic{_message, _range} + | _message + =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text) + , Just (GlobalBindingTypeSigsResult sigs) <- mGblSigs + , Just sig <- find (\x -> sameThing (gbSrcSpan x) _range) sigs + , signature <- T.pack $ gbRendered sig + , title <- if isQuickFix then "add signature: " <> signature else signature + , Just action <- gblBindingTypeSigToEdit sig = + [(title, [action])] + | otherwise = [] + +suggestLocalSignature :: Bool -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] +suggestLocalSignature isQuickFix mTmr mBindings Diagnostic{_message, _range = _range@Range{..}} + | Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, [identifier]) <- + (T.unwords . T.words $ _message) + =~~ ("Polymorphic local binding with no type signature: (.*) ::" :: T.Text) + , Just bindings <- mBindings + , localScope <- getFuzzyScope bindings _start _end + , -- we can't use srcspan to lookup scoped bindings, because the error message reported by GHC includes the entire binding, instead of simply the name + Just (name, ty) <- find (\(x, _) -> printName x == T.unpack identifier) localScope >>= \(name, mTy) -> (name,) <$> mTy + , Just TcModuleResult{tmrTypechecked = TcGblEnv{tcg_rdr_env, tcg_sigs}} <- mTmr + , -- not a top-level thing, to avoid duplication + not $ name `elemNameSet` tcg_sigs + , tyMsg <- showSDocForUser unsafeGlobalDynFlags (mkPrintUnqualified unsafeGlobalDynFlags tcg_rdr_env) $ pprSigmaType ty + , signature <- T.pack $ printName name <> " :: " <> tyMsg + , startCharacter <- _character _start + , startOfLine <- Position (_line _start) startCharacter + , beforeLine <- Range startOfLine startOfLine + , title <- if isQuickFix then "add signature: " <> signature else signature + , action <- TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " " = + [(title, [action])] + | otherwise = [] + +sameThing :: SrcSpan -> Range -> Bool +sameThing s1 s2 = (_start <$> srcSpanToRange s1) == (_start <$> Just s2) + +gblBindingTypeSigToEdit :: GlobalBindingTypeSig -> Maybe TextEdit +gblBindingTypeSigToEdit GlobalBindingTypeSig{..} + | Just Range{..} <- srcSpanToRange $ getSrcSpan gbName + , startOfLine <- Position (_line _start) 0 + , beforeLine <- Range startOfLine startOfLine = + Just $ TextEdit beforeLine $ T.pack gbRendered <> "\n" + | otherwise = Nothing + +data Mode + = -- | always displays type lenses of global bindings, no matter what GHC flags are set + Always + | -- | similar to 'Always', but only displays for exported global bindings + Exported + | -- | follows error messages produced by GHC + Diagnostics + deriving (Eq, Ord, Show, Read, Enum) + +instance A.FromJSON Mode where + parseJSON = A.withText "Mode" $ \s -> + case T.toLower s of + "always" -> pure Always + "exported" -> pure Exported + "diagnostics" -> pure Diagnostics + _ -> A.unexpected (A.String s) + +-------------------------------------------------------------------------------- + +showDocRdrEnv :: DynFlags -> GlobalRdrEnv -> SDoc -> String +showDocRdrEnv dflags rdrEnv = showSDocForUser dflags (mkPrintUnqualified dflags rdrEnv) + +data GetGlobalBindingTypeSigs = GetGlobalBindingTypeSigs + deriving (Generic, Show, Eq, Ord, Hashable, NFData, Binary) + +data GlobalBindingTypeSig = GlobalBindingTypeSig + { gbName :: Name + , gbRendered :: String + , gbExported :: Bool + } + +gbSrcSpan :: GlobalBindingTypeSig -> SrcSpan +gbSrcSpan GlobalBindingTypeSig{gbName} = getSrcSpan gbName + +newtype GlobalBindingTypeSigsResult = GlobalBindingTypeSigsResult [GlobalBindingTypeSig] + +instance Show GlobalBindingTypeSigsResult where + show _ = "" + +instance NFData GlobalBindingTypeSigsResult where + rnf = rwhnf + +type instance RuleResult GetGlobalBindingTypeSigs = GlobalBindingTypeSigsResult + +rules :: Rules () +rules = do + define $ \GetGlobalBindingTypeSigs nfp -> do + tmr <- use TypeCheck nfp + -- we need session here for tidying types + hsc <- use GhcSession nfp + result <- liftIO $ gblBindingType (hscEnv <$> hsc) (tmrTypechecked <$> tmr) + pure ([], result) + +parseCustomConfig :: A.Object -> Maybe Mode +parseCustomConfig = A.parseMaybe (A..: "mode") + +gblBindingType :: Maybe HscEnv -> Maybe TcGblEnv -> IO (Maybe GlobalBindingTypeSigsResult) +gblBindingType (Just hsc) (Just gblEnv) = do + let exports = availsToNameSet $ tcg_exports gblEnv + sigs = tcg_sigs gblEnv + binds = collectHsBindsBinders $ tcg_binds gblEnv + patSyns = tcg_patsyns gblEnv + dflags = hsc_dflags hsc + rdrEnv = tcg_rdr_env gblEnv + showDoc = showDocRdrEnv dflags rdrEnv + hasSig :: (Monad m) => Name -> m a -> m (Maybe a) + hasSig name f = whenMaybe (name `elemNameSet` sigs) f + bindToSig id = do + let name = idName id + hasSig name $ do + env <- tcInitTidyEnv + let (_, ty) = tidyOpenType env (idType id) + pure $ GlobalBindingTypeSig name (printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports) + patToSig p = do + let name = patSynName p + -- we don't use pprPatSynType, since it always prints forall + ty = fromJust $ lookupTypeEnv (tcg_type_env gblEnv) name >>= safeTyThingType + hasSig name $ pure $ GlobalBindingTypeSig name ("pattern " <> printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports) + (_, maybe [] catMaybes -> bindings) <- initTcWithGbl hsc gblEnv (realSrcLocSpan $ mkRealSrcLoc "" 1 1) $ mapM bindToSig binds + patterns <- catMaybes <$> mapM patToSig patSyns + pure . Just . GlobalBindingTypeSigsResult $ bindings <> patterns +gblBindingType _ _ = pure Nothing diff --git a/src/Development/IDE/Spans/AtPoint.hs b/src/Development/IDE/Spans/AtPoint.hs --- a/src/Development/IDE/Spans/AtPoint.hs +++ b/src/Development/IDE/Spans/AtPoint.hs @@ -1,371 +1,371 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE GADTs #-} -{-# LANGUAGE CPP #-} -#include "ghc-api-version.h" - --- | Gives information about symbols at a given point in DAML files. --- These are all pure functions that should execute quickly. -module Development.IDE.Spans.AtPoint ( - atPoint - , gotoDefinition - , gotoTypeDefinition - , documentHighlight - , pointCommand - , referencesAtPoint - , computeTypeReferences - , FOIReferences(..) - , defRowToSymbolInfo - ) where - -import Development.IDE.GHC.Error -import Development.IDE.GHC.Orphans() -import Development.IDE.Types.Location -import Language.LSP.Types - --- compiler and infrastructure -import Development.IDE.GHC.Compat -import Development.IDE.Types.Options -import Development.IDE.Spans.Common -import Development.IDE.Core.RuleTypes -import Development.IDE.Core.PositionMapping - --- GHC API imports -import Name -import Outputable hiding ((<>)) -import SrcLoc -import TyCoRep hiding (FunTy) -import TyCon -import qualified Var -import NameEnv -import IfaceType -import FastString (unpackFS) - -import Control.Applicative -import Control.Monad.Extra -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Class -import Control.Monad.IO.Class -import Data.Maybe -import qualified Data.Text as T -import qualified Data.Map.Strict as M -import qualified Data.HashMap.Strict as HM - -import qualified Data.Array as A -import Data.Either -import Data.List.Extra (nubOrd, dropEnd1) -import Data.List (isSuffixOf) - -import HieDb hiding (pointCommand) - --- | Gives a Uri for the module, given the .hie file location and the the module info --- The Bool denotes if it is a boot module -type LookupModule m = FilePath -> ModuleName -> UnitId -> Bool -> MaybeT m Uri - --- | HieFileResult for files of interest, along with the position mappings -newtype FOIReferences = FOIReferences (HM.HashMap NormalizedFilePath (HieAstResult, PositionMapping)) - -computeTypeReferences :: Foldable f => f (HieAST Type) -> M.Map Name [Span] -computeTypeReferences = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty - where - go ast = M.unionsWith (++) (this : map go (nodeChildren ast)) - where - this = M.fromListWith (++) - $ map (, [nodeSpan ast]) - $ concatMap namesInType - $ mapMaybe (\x -> guard (not $ all isOccurrence $ identInfo x) *> identType x) - $ M.elems - $ nodeIdentifiers $ nodeInfo ast - --- | Given a file and position, return the names at a point, the references for --- those names in the FOIs, and a list of file paths we already searched through -foiReferencesAtPoint - :: NormalizedFilePath - -> Position - -> FOIReferences - -> ([Name],[Location],[FilePath]) -foiReferencesAtPoint file pos (FOIReferences asts) = - case HM.lookup file asts of - Nothing -> ([],[],[]) - Just (HAR _ hf _ _ _,mapping) -> - let posFile = fromMaybe pos $ fromCurrentPosition mapping pos - names = concat $ pointCommand hf posFile (rights . M.keys . nodeIdentifiers . nodeInfo) - adjustedLocs = HM.foldr go [] asts - go (HAR _ _ rf tr _, mapping) xs = refs ++ typerefs ++ xs - where - refs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation . fst) - $ concat $ mapMaybe (\n -> M.lookup (Right n) rf) names - typerefs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation) - $ concat $ mapMaybe (`M.lookup` tr) names - toCurrentLocation mapping (Location uri range) = Location uri <$> toCurrentRange mapping range - in (names, adjustedLocs,map fromNormalizedFilePath $ HM.keys asts) - -referencesAtPoint - :: MonadIO m - => HieDb - -> NormalizedFilePath -- ^ The file the cursor is in - -> Position -- ^ position in the file - -> FOIReferences -- ^ references data for FOIs - -> m [Location] -referencesAtPoint hiedb nfp pos refs = do - -- The database doesn't have up2date references data for the FOIs so we must collect those - -- from the Shake graph. - let (names, foiRefs, exclude) = foiReferencesAtPoint nfp pos refs - nonFOIRefs <- forM names $ \name -> - case nameModule_maybe name of - Nothing -> pure [] - Just mod -> do - -- Look for references (strictly in project files, not dependencies), - -- excluding the files in the FOIs (since those are in foiRefs) - rows <- liftIO $ findReferences hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude - pure $ mapMaybe rowToLoc rows - typeRefs <- forM names $ \name -> - case nameModule_maybe name of - Just mod | isTcClsNameSpace (occNameSpace $ nameOccName name) -> do - refs <- liftIO $ findTypeRefs hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude - pure $ mapMaybe typeRowToLoc refs - _ -> pure [] - pure $ nubOrd $ foiRefs ++ concat nonFOIRefs ++ concat typeRefs - -rowToLoc :: Res RefRow -> Maybe Location -rowToLoc (row:.info) = flip Location range <$> mfile - where - range = Range start end - start = Position (refSLine row - 1) (refSCol row -1) - end = Position (refELine row - 1) (refECol row -1) - mfile = case modInfoSrcFile info of - Just f -> Just $ toUri f - Nothing -> Nothing - -typeRowToLoc :: Res TypeRef -> Maybe Location -typeRowToLoc (row:.info) = do - file <- modInfoSrcFile info - pure $ Location (toUri file) range - where - range = Range start end - start = Position (typeRefSLine row - 1) (typeRefSCol row -1) - end = Position (typeRefELine row - 1) (typeRefECol row -1) - -documentHighlight - :: Monad m - => HieASTs a - -> RefMap a - -> Position - -> MaybeT m [DocumentHighlight] -documentHighlight hf rf pos = pure highlights - where - ns = concat $ pointCommand hf pos (rights . M.keys . nodeIdentifiers . nodeInfo) - highlights = do - n <- ns - ref <- fromMaybe [] (M.lookup (Right n) rf) - pure $ makeHighlight ref - makeHighlight (sp,dets) = - DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets) - highlightType s = - if any (isJust . getScopeFromContext) s - then HkWrite - else HkRead - -gotoTypeDefinition - :: MonadIO m - => HieDb - -> LookupModule m - -> IdeOptions - -> HieAstResult - -> Position - -> MaybeT m [Location] -gotoTypeDefinition hiedb lookupModule ideOpts srcSpans pos - = lift $ typeLocationsAtPoint hiedb lookupModule ideOpts pos srcSpans - --- | Locate the definition of the name at a given position. -gotoDefinition - :: MonadIO m - => HieDb - -> LookupModule m - -> IdeOptions - -> M.Map ModuleName NormalizedFilePath - -> HieASTs a - -> Position - -> MaybeT m [Location] -gotoDefinition hiedb getHieFile ideOpts imports srcSpans pos - = lift $ locationsAtPoint hiedb getHieFile ideOpts imports pos srcSpans - --- | Synopsis for the name at a given position. -atPoint - :: IdeOptions - -> HieAstResult - -> DocAndKindMap - -> Position - -> Maybe (Maybe Range, [T.Text]) -atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) pos = listToMaybe $ pointCommand hf pos hoverInfo - where - -- Hover info for values/data - hoverInfo ast = (Just range, prettyNames ++ pTypes) - where - pTypes - | length names == 1 = dropEnd1 $ map wrapHaskell prettyTypes - | otherwise = map wrapHaskell prettyTypes - - range = realSrcSpanToRange $ nodeSpan ast - - wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n" - info = nodeInfo ast - names = M.assocs $ nodeIdentifiers info - types = nodeType info - - prettyNames :: [T.Text] - prettyNames = map prettyName names - prettyName (Right n, dets) = T.unlines $ - wrapHaskell (showNameWithoutUniques n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) - : definedAt n - ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n - ] - where maybeKind = fmap showGhc $ safeTyThingType =<< lookupNameEnv km n - prettyName (Left m,_) = showGhc m - - prettyTypes = map (("_ :: "<>) . prettyType) types - prettyType t = case kind of - HieFresh -> showGhc t - HieFromDisk full_file -> showGhc $ hieTypeToIface $ recoverFullType t (hie_types full_file) - - definedAt name = - -- do not show "at " and similar messages - -- see the code of 'pprNameDefnLoc' for more information - case nameSrcLoc name of - UnhelpfulLoc {} | isInternalName name || isSystemName name -> [] - _ -> ["*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*"] - -typeLocationsAtPoint - :: forall m - . MonadIO m - => HieDb - -> LookupModule m - -> IdeOptions - -> Position - -> HieAstResult - -> m [Location] -typeLocationsAtPoint hiedb lookupModule _ideOptions pos (HAR _ ast _ _ hieKind) = - case hieKind of - HieFromDisk hf -> - let arr = hie_types hf - ts = concat $ pointCommand ast pos getts - unfold = map (arr A.!) - getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni) - where ni = nodeInfo x - getTypes ts = flip concatMap (unfold ts) $ \case - HTyVarTy n -> [n] -#if MIN_GHC_API_VERSION(8,8,0) - HAppTy a (HieArgs xs) -> getTypes (a : map snd xs) -#else - HAppTy a b -> getTypes [a,b] -#endif - HTyConApp tc (HieArgs xs) -> ifaceTyConName tc : getTypes (map snd xs) - HForAllTy _ a -> getTypes [a] - HFunTy a b -> getTypes [a,b] - HQualTy a b -> getTypes [a,b] - HCastTy a -> getTypes [a] - _ -> [] - in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts) - HieFresh -> - let ts = concat $ pointCommand ast pos getts - getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni) - where ni = nodeInfo x - in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts) - -namesInType :: Type -> [Name] -namesInType (TyVarTy n) = [Var.varName n] -namesInType (AppTy a b) = getTypes [a,b] -namesInType (TyConApp tc ts) = tyConName tc : getTypes ts -namesInType (ForAllTy b t) = Var.varName (binderVar b) : namesInType t -namesInType (FunTy a b) = getTypes [a,b] -namesInType (CastTy t _) = namesInType t -namesInType (LitTy _) = [] -namesInType _ = [] - -getTypes :: [Type] -> [Name] -getTypes ts = concatMap namesInType ts - -locationsAtPoint - :: forall m a - . MonadIO m - => HieDb - -> LookupModule m - -> IdeOptions - -> M.Map ModuleName NormalizedFilePath - -> Position - -> HieASTs a - -> m [Location] -locationsAtPoint hiedb lookupModule _ideOptions imports pos ast = - let ns = concat $ pointCommand ast pos (M.keys . nodeIdentifiers . nodeInfo) - zeroPos = Position 0 0 - zeroRange = Range zeroPos zeroPos - modToLocation m = fmap (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports - in fmap (nubOrd . concat) $ mapMaybeM (either (pure . modToLocation) $ nameToLocation hiedb lookupModule) ns - --- | Given a 'Name' attempt to find the location where it is defined. -nameToLocation :: MonadIO m => HieDb -> LookupModule m -> Name -> m (Maybe [Location]) -nameToLocation hiedb lookupModule name = runMaybeT $ - case nameSrcSpan name of - sp@(RealSrcSpan rsp) - -- Lookup in the db if we got a location in a boot file - | not $ "boot" `isSuffixOf` unpackFS (srcSpanFile rsp) -> MaybeT $ pure $ fmap pure $ srcSpanToLocation sp - sp -> do - guard (sp /= wiredInSrcSpan) - -- This case usually arises when the definition is in an external package. - -- In this case the interface files contain garbage source spans - -- so we instead read the .hie files to get useful source spans. - mod <- MaybeT $ return $ nameModule_maybe name - erow <- liftIO $ findDef hiedb (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) - case erow of - [] -> do - -- If the lookup failed, try again without specifying a unit-id. - -- This is a hack to make find definition work better with ghcide's nascent multi-component support, - -- where names from a component that has been indexed in a previous session but not loaded in this - -- session may end up with different unit ids - erow <- liftIO $ findDef hiedb (nameOccName name) (Just $ moduleName mod) Nothing - case erow of - [] -> MaybeT $ pure Nothing - xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs - xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs - -defRowToLocation :: Monad m => LookupModule m -> Res DefRow -> MaybeT m Location -defRowToLocation lookupModule (row:.info) = do - let start = Position (defSLine row - 1) (defSCol row - 1) - end = Position (defELine row - 1) (defECol row - 1) - range = Range start end - file <- case modInfoSrcFile info of - Just src -> pure $ toUri src - Nothing -> lookupModule (defSrc row) (modInfoName info) (modInfoUnit info) (modInfoIsBoot info) - pure $ Location file range - -toUri :: FilePath -> Uri -toUri = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' - -defRowToSymbolInfo :: Res DefRow -> Maybe SymbolInformation -defRowToSymbolInfo (DefRow{..}:.(modInfoSrcFile -> Just srcFile)) - = Just $ SymbolInformation (showGhc defNameOcc) kind Nothing loc Nothing - where - kind - | isVarOcc defNameOcc = SkVariable - | isDataOcc defNameOcc = SkConstructor - | isTcOcc defNameOcc = SkStruct - | otherwise = SkUnknown 1 - loc = Location file range - file = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' $ srcFile - range = Range start end - start = Position (defSLine - 1) (defSCol - 1) - end = Position (defELine - 1) (defECol - 1) -defRowToSymbolInfo _ = Nothing - -pointCommand :: HieASTs t -> Position -> (HieAST t -> a) -> [a] -pointCommand hf pos k = - catMaybes $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast -> - case selectSmallestContaining (sp fs) ast of - Nothing -> Nothing - Just ast' -> Just $ k ast' - where - sloc fs = mkRealSrcLoc fs (line+1) (cha+1) - sp fs = mkRealSrcSpan (sloc fs) (sloc fs) - line = _line pos - cha = _character pos +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +#include "ghc-api-version.h" + +-- | Gives information about symbols at a given point in DAML files. +-- These are all pure functions that should execute quickly. +module Development.IDE.Spans.AtPoint ( + atPoint + , gotoDefinition + , gotoTypeDefinition + , documentHighlight + , pointCommand + , referencesAtPoint + , computeTypeReferences + , FOIReferences(..) + , defRowToSymbolInfo + ) where + +import Development.IDE.GHC.Error +import Development.IDE.GHC.Orphans () +import Development.IDE.Types.Location +import Language.LSP.Types + +-- compiler and infrastructure +import Development.IDE.Core.PositionMapping +import Development.IDE.Core.RuleTypes +import Development.IDE.GHC.Compat +import Development.IDE.Spans.Common +import Development.IDE.Types.Options + +-- GHC API imports +import FastString (unpackFS) +import IfaceType +import Name +import NameEnv +import Outputable hiding ((<>)) +import SrcLoc +import TyCoRep hiding (FunTy) +import TyCon +import qualified Var + +import Control.Applicative +import Control.Monad.Extra +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import qualified Data.HashMap.Strict as HM +import qualified Data.Map.Strict as M +import Data.Maybe +import qualified Data.Text as T + +import qualified Data.Array as A +import Data.Either +import Data.List (isSuffixOf) +import Data.List.Extra (dropEnd1, nubOrd) + +import HieDb hiding (pointCommand) + +-- | Gives a Uri for the module, given the .hie file location and the the module info +-- The Bool denotes if it is a boot module +type LookupModule m = FilePath -> ModuleName -> UnitId -> Bool -> MaybeT m Uri + +-- | HieFileResult for files of interest, along with the position mappings +newtype FOIReferences = FOIReferences (HM.HashMap NormalizedFilePath (HieAstResult, PositionMapping)) + +computeTypeReferences :: Foldable f => f (HieAST Type) -> M.Map Name [Span] +computeTypeReferences = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty + where + go ast = M.unionsWith (++) (this : map go (nodeChildren ast)) + where + this = M.fromListWith (++) + $ map (, [nodeSpan ast]) + $ concatMap namesInType + $ mapMaybe (\x -> guard (not $ all isOccurrence $ identInfo x) *> identType x) + $ M.elems + $ nodeIdentifiers $ nodeInfo ast + +-- | Given a file and position, return the names at a point, the references for +-- those names in the FOIs, and a list of file paths we already searched through +foiReferencesAtPoint + :: NormalizedFilePath + -> Position + -> FOIReferences + -> ([Name],[Location],[FilePath]) +foiReferencesAtPoint file pos (FOIReferences asts) = + case HM.lookup file asts of + Nothing -> ([],[],[]) + Just (HAR _ hf _ _ _,mapping) -> + let posFile = fromMaybe pos $ fromCurrentPosition mapping pos + names = concat $ pointCommand hf posFile (rights . M.keys . nodeIdentifiers . nodeInfo) + adjustedLocs = HM.foldr go [] asts + go (HAR _ _ rf tr _, mapping) xs = refs ++ typerefs ++ xs + where + refs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation . fst) + $ concat $ mapMaybe (\n -> M.lookup (Right n) rf) names + typerefs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation) + $ concat $ mapMaybe (`M.lookup` tr) names + toCurrentLocation mapping (Location uri range) = Location uri <$> toCurrentRange mapping range + in (names, adjustedLocs,map fromNormalizedFilePath $ HM.keys asts) + +referencesAtPoint + :: MonadIO m + => HieDb + -> NormalizedFilePath -- ^ The file the cursor is in + -> Position -- ^ position in the file + -> FOIReferences -- ^ references data for FOIs + -> m [Location] +referencesAtPoint hiedb nfp pos refs = do + -- The database doesn't have up2date references data for the FOIs so we must collect those + -- from the Shake graph. + let (names, foiRefs, exclude) = foiReferencesAtPoint nfp pos refs + nonFOIRefs <- forM names $ \name -> + case nameModule_maybe name of + Nothing -> pure [] + Just mod -> do + -- Look for references (strictly in project files, not dependencies), + -- excluding the files in the FOIs (since those are in foiRefs) + rows <- liftIO $ findReferences hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude + pure $ mapMaybe rowToLoc rows + typeRefs <- forM names $ \name -> + case nameModule_maybe name of + Just mod | isTcClsNameSpace (occNameSpace $ nameOccName name) -> do + refs <- liftIO $ findTypeRefs hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude + pure $ mapMaybe typeRowToLoc refs + _ -> pure [] + pure $ nubOrd $ foiRefs ++ concat nonFOIRefs ++ concat typeRefs + +rowToLoc :: Res RefRow -> Maybe Location +rowToLoc (row:.info) = flip Location range <$> mfile + where + range = Range start end + start = Position (refSLine row - 1) (refSCol row -1) + end = Position (refELine row - 1) (refECol row -1) + mfile = case modInfoSrcFile info of + Just f -> Just $ toUri f + Nothing -> Nothing + +typeRowToLoc :: Res TypeRef -> Maybe Location +typeRowToLoc (row:.info) = do + file <- modInfoSrcFile info + pure $ Location (toUri file) range + where + range = Range start end + start = Position (typeRefSLine row - 1) (typeRefSCol row -1) + end = Position (typeRefELine row - 1) (typeRefECol row -1) + +documentHighlight + :: Monad m + => HieASTs a + -> RefMap a + -> Position + -> MaybeT m [DocumentHighlight] +documentHighlight hf rf pos = pure highlights + where + ns = concat $ pointCommand hf pos (rights . M.keys . nodeIdentifiers . nodeInfo) + highlights = do + n <- ns + ref <- fromMaybe [] (M.lookup (Right n) rf) + pure $ makeHighlight ref + makeHighlight (sp,dets) = + DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets) + highlightType s = + if any (isJust . getScopeFromContext) s + then HkWrite + else HkRead + +gotoTypeDefinition + :: MonadIO m + => HieDb + -> LookupModule m + -> IdeOptions + -> HieAstResult + -> Position + -> MaybeT m [Location] +gotoTypeDefinition hiedb lookupModule ideOpts srcSpans pos + = lift $ typeLocationsAtPoint hiedb lookupModule ideOpts pos srcSpans + +-- | Locate the definition of the name at a given position. +gotoDefinition + :: MonadIO m + => HieDb + -> LookupModule m + -> IdeOptions + -> M.Map ModuleName NormalizedFilePath + -> HieASTs a + -> Position + -> MaybeT m [Location] +gotoDefinition hiedb getHieFile ideOpts imports srcSpans pos + = lift $ locationsAtPoint hiedb getHieFile ideOpts imports pos srcSpans + +-- | Synopsis for the name at a given position. +atPoint + :: IdeOptions + -> HieAstResult + -> DocAndKindMap + -> Position + -> Maybe (Maybe Range, [T.Text]) +atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) pos = listToMaybe $ pointCommand hf pos hoverInfo + where + -- Hover info for values/data + hoverInfo ast = (Just range, prettyNames ++ pTypes) + where + pTypes + | length names == 1 = dropEnd1 $ map wrapHaskell prettyTypes + | otherwise = map wrapHaskell prettyTypes + + range = realSrcSpanToRange $ nodeSpan ast + + wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n" + info = nodeInfo ast + names = M.assocs $ nodeIdentifiers info + types = nodeType info + + prettyNames :: [T.Text] + prettyNames = map prettyName names + prettyName (Right n, dets) = T.unlines $ + wrapHaskell (showNameWithoutUniques n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) + : definedAt n + ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n + ] + where maybeKind = fmap showGhc $ safeTyThingType =<< lookupNameEnv km n + prettyName (Left m,_) = showGhc m + + prettyTypes = map (("_ :: "<>) . prettyType) types + prettyType t = case kind of + HieFresh -> showGhc t + HieFromDisk full_file -> showGhc $ hieTypeToIface $ recoverFullType t (hie_types full_file) + + definedAt name = + -- do not show "at " and similar messages + -- see the code of 'pprNameDefnLoc' for more information + case nameSrcLoc name of + UnhelpfulLoc {} | isInternalName name || isSystemName name -> [] + _ -> ["*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*"] + +typeLocationsAtPoint + :: forall m + . MonadIO m + => HieDb + -> LookupModule m + -> IdeOptions + -> Position + -> HieAstResult + -> m [Location] +typeLocationsAtPoint hiedb lookupModule _ideOptions pos (HAR _ ast _ _ hieKind) = + case hieKind of + HieFromDisk hf -> + let arr = hie_types hf + ts = concat $ pointCommand ast pos getts + unfold = map (arr A.!) + getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni) + where ni = nodeInfo x + getTypes ts = flip concatMap (unfold ts) $ \case + HTyVarTy n -> [n] +#if MIN_GHC_API_VERSION(8,8,0) + HAppTy a (HieArgs xs) -> getTypes (a : map snd xs) +#else + HAppTy a b -> getTypes [a,b] +#endif + HTyConApp tc (HieArgs xs) -> ifaceTyConName tc : getTypes (map snd xs) + HForAllTy _ a -> getTypes [a] + HFunTy a b -> getTypes [a,b] + HQualTy a b -> getTypes [a,b] + HCastTy a -> getTypes [a] + _ -> [] + in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts) + HieFresh -> + let ts = concat $ pointCommand ast pos getts + getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni) + where ni = nodeInfo x + in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts) + +namesInType :: Type -> [Name] +namesInType (TyVarTy n) = [Var.varName n] +namesInType (AppTy a b) = getTypes [a,b] +namesInType (TyConApp tc ts) = tyConName tc : getTypes ts +namesInType (ForAllTy b t) = Var.varName (binderVar b) : namesInType t +namesInType (FunTy a b) = getTypes [a,b] +namesInType (CastTy t _) = namesInType t +namesInType (LitTy _) = [] +namesInType _ = [] + +getTypes :: [Type] -> [Name] +getTypes ts = concatMap namesInType ts + +locationsAtPoint + :: forall m a + . MonadIO m + => HieDb + -> LookupModule m + -> IdeOptions + -> M.Map ModuleName NormalizedFilePath + -> Position + -> HieASTs a + -> m [Location] +locationsAtPoint hiedb lookupModule _ideOptions imports pos ast = + let ns = concat $ pointCommand ast pos (M.keys . nodeIdentifiers . nodeInfo) + zeroPos = Position 0 0 + zeroRange = Range zeroPos zeroPos + modToLocation m = fmap (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports + in fmap (nubOrd . concat) $ mapMaybeM (either (pure . modToLocation) $ nameToLocation hiedb lookupModule) ns + +-- | Given a 'Name' attempt to find the location where it is defined. +nameToLocation :: MonadIO m => HieDb -> LookupModule m -> Name -> m (Maybe [Location]) +nameToLocation hiedb lookupModule name = runMaybeT $ + case nameSrcSpan name of + sp@(RealSrcSpan rsp) + -- Lookup in the db if we got a location in a boot file + | not $ "boot" `isSuffixOf` unpackFS (srcSpanFile rsp) -> MaybeT $ pure $ fmap pure $ srcSpanToLocation sp + sp -> do + guard (sp /= wiredInSrcSpan) + -- This case usually arises when the definition is in an external package. + -- In this case the interface files contain garbage source spans + -- so we instead read the .hie files to get useful source spans. + mod <- MaybeT $ return $ nameModule_maybe name + erow <- liftIO $ findDef hiedb (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) + case erow of + [] -> do + -- If the lookup failed, try again without specifying a unit-id. + -- This is a hack to make find definition work better with ghcide's nascent multi-component support, + -- where names from a component that has been indexed in a previous session but not loaded in this + -- session may end up with different unit ids + erow <- liftIO $ findDef hiedb (nameOccName name) (Just $ moduleName mod) Nothing + case erow of + [] -> MaybeT $ pure Nothing + xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs + xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs + +defRowToLocation :: Monad m => LookupModule m -> Res DefRow -> MaybeT m Location +defRowToLocation lookupModule (row:.info) = do + let start = Position (defSLine row - 1) (defSCol row - 1) + end = Position (defELine row - 1) (defECol row - 1) + range = Range start end + file <- case modInfoSrcFile info of + Just src -> pure $ toUri src + Nothing -> lookupModule (defSrc row) (modInfoName info) (modInfoUnit info) (modInfoIsBoot info) + pure $ Location file range + +toUri :: FilePath -> Uri +toUri = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' + +defRowToSymbolInfo :: Res DefRow -> Maybe SymbolInformation +defRowToSymbolInfo (DefRow{..}:.(modInfoSrcFile -> Just srcFile)) + = Just $ SymbolInformation (showGhc defNameOcc) kind Nothing loc Nothing + where + kind + | isVarOcc defNameOcc = SkVariable + | isDataOcc defNameOcc = SkConstructor + | isTcOcc defNameOcc = SkStruct + | otherwise = SkUnknown 1 + loc = Location file range + file = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' $ srcFile + range = Range start end + start = Position (defSLine - 1) (defSCol - 1) + end = Position (defELine - 1) (defECol - 1) +defRowToSymbolInfo _ = Nothing + +pointCommand :: HieASTs t -> Position -> (HieAST t -> a) -> [a] +pointCommand hf pos k = + catMaybes $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast -> + case selectSmallestContaining (sp fs) ast of + Nothing -> Nothing + Just ast' -> Just $ k ast' + where + sloc fs = mkRealSrcLoc fs (line+1) (cha+1) + sp fs = mkRealSrcSpan (sloc fs) (sloc fs) + line = _line pos + cha = _character pos diff --git a/src/Development/IDE/Spans/Common.hs b/src/Development/IDE/Spans/Common.hs --- a/src/Development/IDE/Spans/Common.hs +++ b/src/Development/IDE/Spans/Common.hs @@ -1,192 +1,191 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DeriveAnyClass #-} -#include "ghc-api-version.h" - -module Development.IDE.Spans.Common ( - showGhc -, showNameWithoutUniques -, unqualIEWrapName -, safeTyThingId -, safeTyThingType -, SpanDoc(..) -, SpanDocUris(..) -, emptySpanDoc -, spanDocToMarkdown -, spanDocToMarkdownForTest -, DocMap -, KindMap -) where - -import Data.Maybe -import qualified Data.Text as T -import Data.List.Extra -import Control.DeepSeq -import GHC.Generics - -import GHC -import Outputable hiding ((<>)) -import ConLike -import DataCon -import Var -import NameEnv -import DynFlags - -import qualified Documentation.Haddock.Parser as H -import qualified Documentation.Haddock.Types as H -import Development.IDE.GHC.Orphans () -import Development.IDE.GHC.Util -import RdrName (rdrNameOcc) - -type DocMap = NameEnv SpanDoc -type KindMap = NameEnv TyThing - -showGhc :: Outputable a => a -> T.Text -showGhc = showSD . ppr - -showSD :: SDoc -> T.Text -showSD = T.pack . unsafePrintSDoc - -showNameWithoutUniques :: Outputable a => a -> T.Text -showNameWithoutUniques = T.pack . prettyprint - where - dyn = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques - prettyprint x = renderWithStyle dyn (ppr x) style - style = mkUserStyle dyn neverQualify AllTheWay - --- | Shows IEWrappedName, without any modifier, qualifier or unique identifier. -unqualIEWrapName :: IEWrappedName RdrName -> T.Text -unqualIEWrapName = showNameWithoutUniques . rdrNameOcc . ieWrappedName - --- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs -safeTyThingType :: TyThing -> Maybe Type -safeTyThingType thing - | Just i <- safeTyThingId thing = Just (varType i) -safeTyThingType (ATyCon tycon) = Just (tyConKind tycon) -safeTyThingType _ = Nothing - -safeTyThingId :: TyThing -> Maybe Id -safeTyThingId (AnId i) = Just i -safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc -safeTyThingId _ = Nothing - --- Possible documentation for an element in the code -data SpanDoc - = SpanDocString HsDocString SpanDocUris - | SpanDocText [T.Text] SpanDocUris - deriving stock (Eq, Show, Generic) - deriving anyclass NFData - -data SpanDocUris = - SpanDocUris - { spanDocUriDoc :: Maybe T.Text -- ^ The haddock html page - , spanDocUriSrc :: Maybe T.Text -- ^ The hyperlinked source html page - } deriving stock (Eq, Show, Generic) - deriving anyclass NFData - -emptySpanDoc :: SpanDoc -emptySpanDoc = SpanDocText [] (SpanDocUris Nothing Nothing) - -spanDocToMarkdown :: SpanDoc -> [T.Text] -spanDocToMarkdown (SpanDocString docs uris) - = [T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs] - <> ["\n"] <> spanDocUrisToMarkdown uris - -- Append the extra newlines since this is markdown --- to get a visible newline, - -- you need to have two newlines -spanDocToMarkdown (SpanDocText txt uris) = txt <> ["\n"] <> spanDocUrisToMarkdown uris - -spanDocUrisToMarkdown :: SpanDocUris -> [T.Text] -spanDocUrisToMarkdown (SpanDocUris mdoc msrc) = catMaybes - [ linkify "Documentation" <$> mdoc - , linkify "Source" <$> msrc - ] - where linkify title uri = "[" <> title <> "](" <> uri <> ")" - -spanDocToMarkdownForTest :: String -> String -spanDocToMarkdownForTest - = haddockToMarkdown . H.toRegular . H._doc . H.parseParas Nothing - --- Simple (and a bit hacky) conversion from Haddock markup to Markdown -haddockToMarkdown - :: H.DocH String String -> String - -haddockToMarkdown H.DocEmpty - = "" -haddockToMarkdown (H.DocAppend d1 d2) - = haddockToMarkdown d1 ++ " " ++ haddockToMarkdown d2 -haddockToMarkdown (H.DocString s) - = escapeBackticks s -haddockToMarkdown (H.DocParagraph p) - = "\n\n" ++ haddockToMarkdown p -haddockToMarkdown (H.DocIdentifier i) - = "`" ++ i ++ "`" -haddockToMarkdown (H.DocIdentifierUnchecked i) - = "`" ++ i ++ "`" -haddockToMarkdown (H.DocModule i) - = "`" ++ escapeBackticks i ++ "`" -haddockToMarkdown (H.DocWarning w) - = haddockToMarkdown w -haddockToMarkdown (H.DocEmphasis d) - = "*" ++ haddockToMarkdown d ++ "*" -haddockToMarkdown (H.DocBold d) - = "**" ++ haddockToMarkdown d ++ "**" -haddockToMarkdown (H.DocMonospaced d) - = "`" ++ removeUnescapedBackticks (haddockToMarkdown d) ++ "`" -haddockToMarkdown (H.DocCodeBlock d) - = "\n```haskell\n" ++ haddockToMarkdown d ++ "\n```\n" -haddockToMarkdown (H.DocExamples es) - = "\n```haskell\n" ++ unlines (map exampleToMarkdown es) ++ "\n```\n" - where - exampleToMarkdown (H.Example expr result) - = ">>> " ++ expr ++ "\n" ++ unlines result -haddockToMarkdown (H.DocHyperlink (H.Hyperlink url Nothing)) - = "<" ++ url ++ ">" -haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label))) - = "[" ++ haddockToMarkdown label ++ "](" ++ url ++ ")" -haddockToMarkdown (H.DocPic (H.Picture url Nothing)) - = "![](" ++ url ++ ")" -haddockToMarkdown (H.DocPic (H.Picture url (Just label))) - = "![" ++ label ++ "](" ++ url ++ ")" -haddockToMarkdown (H.DocAName aname) - = "[" ++ escapeBackticks aname ++ "]:" -haddockToMarkdown (H.DocHeader (H.Header level title)) - = replicate level '#' ++ " " ++ haddockToMarkdown title - -haddockToMarkdown (H.DocUnorderedList things) - = '\n' : (unlines $ map (("+ " ++) . trimStart . splitForList . haddockToMarkdown) things) -haddockToMarkdown (H.DocOrderedList things) - = '\n' : (unlines $ map (("1. " ++) . trimStart . splitForList . haddockToMarkdown) things) -haddockToMarkdown (H.DocDefList things) - = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things) - --- we cannot render math by default -haddockToMarkdown (H.DocMathInline _) - = "*cannot render inline math formula*" -haddockToMarkdown (H.DocMathDisplay _) - = "\n\n*cannot render display math formula*\n\n" - --- TODO: render tables -haddockToMarkdown (H.DocTable _t) - = "\n\n*tables are not yet supported*\n\n" - --- things I don't really know how to handle -haddockToMarkdown (H.DocProperty _) - = "" -- don't really know what to do - -escapeBackticks :: String -> String -escapeBackticks "" = "" -escapeBackticks ('`':ss) = '\\':'`':escapeBackticks ss -escapeBackticks (s :ss) = s:escapeBackticks ss - -removeUnescapedBackticks :: String -> String -removeUnescapedBackticks = \case - '\\' : '`' : ss -> '\\' : '`' : removeUnescapedBackticks ss - '`' : ss -> removeUnescapedBackticks ss - "" -> "" - s : ss -> s : removeUnescapedBackticks ss - -splitForList :: String -> String -splitForList s - = case lines s of - [] -> "" - (first:rest) -> unlines $ first : map ((" " ++) . trimStart) rest +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +#include "ghc-api-version.h" + +module Development.IDE.Spans.Common ( + showGhc +, showNameWithoutUniques +, unqualIEWrapName +, safeTyThingId +, safeTyThingType +, SpanDoc(..) +, SpanDocUris(..) +, emptySpanDoc +, spanDocToMarkdown +, spanDocToMarkdownForTest +, DocMap +, KindMap +) where + +import Control.DeepSeq +import Data.List.Extra +import Data.Maybe +import qualified Data.Text as T +import GHC.Generics + +import ConLike +import DynFlags +import GHC +import NameEnv +import Outputable hiding ((<>)) +import Var + +import Development.IDE.GHC.Orphans () +import Development.IDE.GHC.Util +import qualified Documentation.Haddock.Parser as H +import qualified Documentation.Haddock.Types as H +import RdrName (rdrNameOcc) + +type DocMap = NameEnv SpanDoc +type KindMap = NameEnv TyThing + +showGhc :: Outputable a => a -> T.Text +showGhc = showSD . ppr + +showSD :: SDoc -> T.Text +showSD = T.pack . unsafePrintSDoc + +showNameWithoutUniques :: Outputable a => a -> T.Text +showNameWithoutUniques = T.pack . prettyprint + where + dyn = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques + prettyprint x = renderWithStyle dyn (ppr x) style + style = mkUserStyle dyn neverQualify AllTheWay + +-- | Shows IEWrappedName, without any modifier, qualifier or unique identifier. +unqualIEWrapName :: IEWrappedName RdrName -> T.Text +unqualIEWrapName = showNameWithoutUniques . rdrNameOcc . ieWrappedName + +-- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs +safeTyThingType :: TyThing -> Maybe Type +safeTyThingType thing + | Just i <- safeTyThingId thing = Just (varType i) +safeTyThingType (ATyCon tycon) = Just (tyConKind tycon) +safeTyThingType _ = Nothing + +safeTyThingId :: TyThing -> Maybe Id +safeTyThingId (AnId i) = Just i +safeTyThingId (AConLike conLike) = conLikeWrapId_maybe conLike +safeTyThingId _ = Nothing + +-- Possible documentation for an element in the code +data SpanDoc + = SpanDocString HsDocString SpanDocUris + | SpanDocText [T.Text] SpanDocUris + deriving stock (Eq, Show, Generic) + deriving anyclass NFData + +data SpanDocUris = + SpanDocUris + { spanDocUriDoc :: Maybe T.Text -- ^ The haddock html page + , spanDocUriSrc :: Maybe T.Text -- ^ The hyperlinked source html page + } deriving stock (Eq, Show, Generic) + deriving anyclass NFData + +emptySpanDoc :: SpanDoc +emptySpanDoc = SpanDocText [] (SpanDocUris Nothing Nothing) + +spanDocToMarkdown :: SpanDoc -> [T.Text] +spanDocToMarkdown (SpanDocString docs uris) + = [T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs] + <> ["\n"] <> spanDocUrisToMarkdown uris + -- Append the extra newlines since this is markdown --- to get a visible newline, + -- you need to have two newlines +spanDocToMarkdown (SpanDocText txt uris) = txt <> ["\n"] <> spanDocUrisToMarkdown uris + +spanDocUrisToMarkdown :: SpanDocUris -> [T.Text] +spanDocUrisToMarkdown (SpanDocUris mdoc msrc) = catMaybes + [ linkify "Documentation" <$> mdoc + , linkify "Source" <$> msrc + ] + where linkify title uri = "[" <> title <> "](" <> uri <> ")" + +spanDocToMarkdownForTest :: String -> String +spanDocToMarkdownForTest + = haddockToMarkdown . H.toRegular . H._doc . H.parseParas Nothing + +-- Simple (and a bit hacky) conversion from Haddock markup to Markdown +haddockToMarkdown + :: H.DocH String String -> String + +haddockToMarkdown H.DocEmpty + = "" +haddockToMarkdown (H.DocAppend d1 d2) + = haddockToMarkdown d1 ++ " " ++ haddockToMarkdown d2 +haddockToMarkdown (H.DocString s) + = escapeBackticks s +haddockToMarkdown (H.DocParagraph p) + = "\n\n" ++ haddockToMarkdown p +haddockToMarkdown (H.DocIdentifier i) + = "`" ++ i ++ "`" +haddockToMarkdown (H.DocIdentifierUnchecked i) + = "`" ++ i ++ "`" +haddockToMarkdown (H.DocModule i) + = "`" ++ escapeBackticks i ++ "`" +haddockToMarkdown (H.DocWarning w) + = haddockToMarkdown w +haddockToMarkdown (H.DocEmphasis d) + = "*" ++ haddockToMarkdown d ++ "*" +haddockToMarkdown (H.DocBold d) + = "**" ++ haddockToMarkdown d ++ "**" +haddockToMarkdown (H.DocMonospaced d) + = "`" ++ removeUnescapedBackticks (haddockToMarkdown d) ++ "`" +haddockToMarkdown (H.DocCodeBlock d) + = "\n```haskell\n" ++ haddockToMarkdown d ++ "\n```\n" +haddockToMarkdown (H.DocExamples es) + = "\n```haskell\n" ++ unlines (map exampleToMarkdown es) ++ "\n```\n" + where + exampleToMarkdown (H.Example expr result) + = ">>> " ++ expr ++ "\n" ++ unlines result +haddockToMarkdown (H.DocHyperlink (H.Hyperlink url Nothing)) + = "<" ++ url ++ ">" +haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label))) + = "[" ++ haddockToMarkdown label ++ "](" ++ url ++ ")" +haddockToMarkdown (H.DocPic (H.Picture url Nothing)) + = "![](" ++ url ++ ")" +haddockToMarkdown (H.DocPic (H.Picture url (Just label))) + = "![" ++ label ++ "](" ++ url ++ ")" +haddockToMarkdown (H.DocAName aname) + = "[" ++ escapeBackticks aname ++ "]:" +haddockToMarkdown (H.DocHeader (H.Header level title)) + = replicate level '#' ++ " " ++ haddockToMarkdown title + +haddockToMarkdown (H.DocUnorderedList things) + = '\n' : (unlines $ map (("+ " ++) . trimStart . splitForList . haddockToMarkdown) things) +haddockToMarkdown (H.DocOrderedList things) + = '\n' : (unlines $ map (("1. " ++) . trimStart . splitForList . haddockToMarkdown) things) +haddockToMarkdown (H.DocDefList things) + = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things) + +-- we cannot render math by default +haddockToMarkdown (H.DocMathInline _) + = "*cannot render inline math formula*" +haddockToMarkdown (H.DocMathDisplay _) + = "\n\n*cannot render display math formula*\n\n" + +-- TODO: render tables +haddockToMarkdown (H.DocTable _t) + = "\n\n*tables are not yet supported*\n\n" + +-- things I don't really know how to handle +haddockToMarkdown (H.DocProperty _) + = "" -- don't really know what to do + +escapeBackticks :: String -> String +escapeBackticks "" = "" +escapeBackticks ('`':ss) = '\\':'`':escapeBackticks ss +escapeBackticks (s :ss) = s:escapeBackticks ss + +removeUnescapedBackticks :: String -> String +removeUnescapedBackticks = \case + '\\' : '`' : ss -> '\\' : '`' : removeUnescapedBackticks ss + '`' : ss -> removeUnescapedBackticks ss + "" -> "" + s : ss -> s : removeUnescapedBackticks ss + +splitForList :: String -> String +splitForList s + = case lines s of + [] -> "" + (first:rest) -> unlines $ first : map ((" " ++) . trimStart) rest diff --git a/src/Development/IDE/Spans/Documentation.hs b/src/Development/IDE/Spans/Documentation.hs --- a/src/Development/IDE/Spans/Documentation.hs +++ b/src/Development/IDE/Spans/Documentation.hs @@ -1,223 +1,223 @@ -{-# LANGUAGE RankNTypes #-} --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE CPP #-} -#include "ghc-api-version.h" - -module Development.IDE.Spans.Documentation ( - getDocumentation - , getDocumentationTryGhc - , getDocumentationsTryGhc - , DocMap - , mkDocMap - ) where - -import Control.Monad -import Control.Monad.Extra (findM) -import Data.Either -import Data.Foldable -import Data.List.Extra -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Maybe -import qualified Data.Text as T -import Development.IDE.Core.Compile -import Development.IDE.GHC.Compat -import Development.IDE.GHC.Error -import Development.IDE.Spans.Common -import Development.IDE.Core.RuleTypes -import System.Directory -import System.FilePath - -import FastString -import SrcLoc (RealLocated) -import GhcMonad -import Packages -import Name -import Language.LSP.Types (getUri, filePathToUri) -import TcRnTypes -import ExtractDocs -import NameEnv -import HscTypes (HscEnv(hsc_dflags)) - -mkDocMap - :: HscEnv - -> RefMap a - -> TcGblEnv - -> IO DocAndKindMap -mkDocMap env rm this_mod = - do let (_ , DeclDocMap this_docs, _) = extractDocs this_mod - d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names - k <- foldrM getType (tcg_type_env this_mod) names - pure $ DKMap d k - where - getDocs n map - | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist - | otherwise = do - doc <- getDocumentationTryGhc env mod n - pure $ extendNameEnv map n doc - getType n map - | isTcOcc $ occName n = do - kind <- lookupKind env mod n - pure $ maybe map (extendNameEnv map n) kind - | otherwise = pure map - names = rights $ S.toList idents - idents = M.keysSet rm - mod = tcg_mod this_mod - -lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing) -lookupKind env mod = - fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod - -getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc -getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n] - -getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc] -getDocumentationsTryGhc env mod names = do - res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names - case res of - Left _ -> return [] - Right res -> zipWithM unwrap res names - where - unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n - unwrap _ n = mkSpanDocText n - - mkSpanDocText name = - SpanDocText [] <$> getUris name - - -- Get the uris to the documentation and source html pages if they exist - getUris name = do - let df = hsc_dflags env - (docFu, srcFu) <- - case nameModule_maybe name of - Just mod -> liftIO $ do - doc <- toFileUriText $ lookupDocHtmlForModule df mod - src <- toFileUriText $ lookupSrcHtmlForModule df mod - return (doc, src) - Nothing -> pure (Nothing, Nothing) - let docUri = (<> "#" <> selector <> showNameWithoutUniques name) <$> docFu - srcUri = (<> "#" <> showNameWithoutUniques name) <$> srcFu - selector - | isValName name = "v:" - | otherwise = "t:" - return $ SpanDocUris docUri srcUri - - toFileUriText = (fmap . fmap) (getUri . filePathToUri) - -getDocumentation - :: HasSrcSpan name - => [ParsedModule] -- ^ All of the possible modules it could be defined in. - -> name -- ^ The name you want documentation for. - -> [T.Text] --- This finds any documentation between the name you want --- documentation for and the one before it. This is only an --- approximately correct algorithm and there are easily constructed --- cases where it will be wrong (if so then usually slightly but there --- may be edge cases where it is very wrong). --- TODO : Build a version of GHC exactprint to extract this information --- more accurately. -getDocumentation sources targetName = fromMaybe [] $ do - -- Find the module the target is defined in. - targetNameSpan <- realSpan $ getLoc targetName - tc <- - find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName) - $ reverse sources -- TODO : Is reversing the list here really neccessary? - - -- Top level names bound by the module - let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc - , L _ (ValD _ hsbind) <- hsmodDecls - , Just n <- [name_of_bind hsbind] - ] - -- Sort the names' source spans. - let sortedSpans = sortedNameSpans bs - -- Now go ahead and extract the docs. - let docs = ann tc - nameInd <- elemIndex targetNameSpan sortedSpans - let prevNameSpan = - if nameInd >= 1 - then sortedSpans !! (nameInd - 1) - else zeroSpan $ srcSpanFile targetNameSpan - -- Annoyingly "-- |" documentation isn't annotated with a location, - -- so you have to pull it out from the elements. - pure - $ docHeaders - $ filter (\(L target _) -> isBetween target prevNameSpan targetNameSpan) - $ mapMaybe (\(L l v) -> L <$> realSpan l <*> pure v) - $ join - $ M.elems - docs - where - -- Get the name bound by a binding. We only concern ourselves with - -- @FunBind@ (which covers functions and variables). - name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName) - name_of_bind FunBind {fun_id} = Just fun_id - name_of_bind _ = Nothing - -- Get source spans from names, discard unhelpful spans, remove - -- duplicates and sort. - sortedNameSpans :: [Located RdrName] -> [RealSrcSpan] - sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls) - isBetween target before after = before <= target && target <= after - ann = snd . pm_annotations - annotationFileName :: ParsedModule -> Maybe FastString - annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann - realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan] - realSpans = - mapMaybe (realSpan . getLoc) - . join - . M.elems - --- | Shows this part of the documentation -docHeaders :: [RealLocated AnnotationComment] - -> [T.Text] -docHeaders = mapMaybe (\(L _ x) -> wrk x) - where - wrk = \case - -- When `Opt_Haddock` is enabled. - AnnDocCommentNext s -> Just $ T.pack s - -- When `Opt_KeepRawTokenStream` enabled. - AnnLineComment s -> if "-- |" `isPrefixOf` s - then Just $ T.pack s - else Nothing - _ -> Nothing - --- These are taken from haskell-ide-engine's Haddock plugin - --- | Given a module finds the local @doc/html/Foo-Bar-Baz.html@ page. --- An example for a cabal installed module: --- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/Data-Vector-Primitive.html@ -lookupDocHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath) -lookupDocHtmlForModule = - lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir modDocName <.> "html") - --- | Given a module finds the hyperlinked source @doc/html/src/Foo.Bar.Baz.html@ page. --- An example for a cabal installed module: --- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/src/Data.Vector.Primitive.html@ -lookupSrcHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath) -lookupSrcHtmlForModule = - lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir "src" modDocName <.> "html") - -lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> DynFlags -> Module -> IO (Maybe FilePath) -lookupHtmlForModule mkDocPath df m = do - -- try all directories - let mfs = fmap (concatMap go) (lookupHtmls df ui) - html <- findM doesFileExist (concat . maybeToList $ mfs) - -- canonicalize located html to remove /../ indirection which can break some clients - -- (vscode on Windows at least) - traverse canonicalizePath html - where - go pkgDocDir = map (mkDocPath pkgDocDir) mns - ui = moduleUnitId m - -- try to locate html file from most to least specific name e.g. - -- first Language.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html - -- then Language.LSP.Types.html and Language-Haskell-LSP-Types.html etc. - mns = do - chunks <- (reverse . drop1 . inits . splitOn ".") $ (moduleNameString . moduleName) m - -- The file might use "." or "-" as separator - map (`intercalate` chunks) [".", "-"] - -lookupHtmls :: DynFlags -> UnitId -> Maybe [FilePath] -lookupHtmls df ui = - -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path - -- and therefore doesn't expand $topdir on Windows - map takeDirectory . haddockInterfaces <$> lookupPackage df ui +{-# LANGUAGE RankNTypes #-} +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE CPP #-} +#include "ghc-api-version.h" + +module Development.IDE.Spans.Documentation ( + getDocumentation + , getDocumentationTryGhc + , getDocumentationsTryGhc + , DocMap + , mkDocMap + ) where + +import Control.Monad +import Control.Monad.Extra (findM) +import Data.Either +import Data.Foldable +import Data.List.Extra +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Set as S +import qualified Data.Text as T +import Development.IDE.Core.Compile +import Development.IDE.Core.RuleTypes +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Error +import Development.IDE.Spans.Common +import System.Directory +import System.FilePath + +import ExtractDocs +import FastString +import GhcMonad +import HscTypes (HscEnv (hsc_dflags)) +import Language.LSP.Types (filePathToUri, getUri) +import Name +import NameEnv +import Packages +import SrcLoc (RealLocated) +import TcRnTypes + +mkDocMap + :: HscEnv + -> RefMap a + -> TcGblEnv + -> IO DocAndKindMap +mkDocMap env rm this_mod = + do let (_ , DeclDocMap this_docs, _) = extractDocs this_mod + d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names + k <- foldrM getType (tcg_type_env this_mod) names + pure $ DKMap d k + where + getDocs n map + | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist + | otherwise = do + doc <- getDocumentationTryGhc env mod n + pure $ extendNameEnv map n doc + getType n map + | isTcOcc $ occName n = do + kind <- lookupKind env mod n + pure $ maybe map (extendNameEnv map n) kind + | otherwise = pure map + names = rights $ S.toList idents + idents = M.keysSet rm + mod = tcg_mod this_mod + +lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing) +lookupKind env mod = + fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod + +getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc +getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n] + +getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc] +getDocumentationsTryGhc env mod names = do + res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names + case res of + Left _ -> return [] + Right res -> zipWithM unwrap res names + where + unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n + unwrap _ n = mkSpanDocText n + + mkSpanDocText name = + SpanDocText [] <$> getUris name + + -- Get the uris to the documentation and source html pages if they exist + getUris name = do + let df = hsc_dflags env + (docFu, srcFu) <- + case nameModule_maybe name of + Just mod -> liftIO $ do + doc <- toFileUriText $ lookupDocHtmlForModule df mod + src <- toFileUriText $ lookupSrcHtmlForModule df mod + return (doc, src) + Nothing -> pure (Nothing, Nothing) + let docUri = (<> "#" <> selector <> showNameWithoutUniques name) <$> docFu + srcUri = (<> "#" <> showNameWithoutUniques name) <$> srcFu + selector + | isValName name = "v:" + | otherwise = "t:" + return $ SpanDocUris docUri srcUri + + toFileUriText = (fmap . fmap) (getUri . filePathToUri) + +getDocumentation + :: HasSrcSpan name + => [ParsedModule] -- ^ All of the possible modules it could be defined in. + -> name -- ^ The name you want documentation for. + -> [T.Text] +-- This finds any documentation between the name you want +-- documentation for and the one before it. This is only an +-- approximately correct algorithm and there are easily constructed +-- cases where it will be wrong (if so then usually slightly but there +-- may be edge cases where it is very wrong). +-- TODO : Build a version of GHC exactprint to extract this information +-- more accurately. +getDocumentation sources targetName = fromMaybe [] $ do + -- Find the module the target is defined in. + targetNameSpan <- realSpan $ getLoc targetName + tc <- + find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName) + $ reverse sources -- TODO : Is reversing the list here really neccessary? + + -- Top level names bound by the module + let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc + , L _ (ValD _ hsbind) <- hsmodDecls + , Just n <- [name_of_bind hsbind] + ] + -- Sort the names' source spans. + let sortedSpans = sortedNameSpans bs + -- Now go ahead and extract the docs. + let docs = ann tc + nameInd <- elemIndex targetNameSpan sortedSpans + let prevNameSpan = + if nameInd >= 1 + then sortedSpans !! (nameInd - 1) + else zeroSpan $ srcSpanFile targetNameSpan + -- Annoyingly "-- |" documentation isn't annotated with a location, + -- so you have to pull it out from the elements. + pure + $ docHeaders + $ filter (\(L target _) -> isBetween target prevNameSpan targetNameSpan) + $ mapMaybe (\(L l v) -> L <$> realSpan l <*> pure v) + $ join + $ M.elems + docs + where + -- Get the name bound by a binding. We only concern ourselves with + -- @FunBind@ (which covers functions and variables). + name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName) + name_of_bind FunBind {fun_id} = Just fun_id + name_of_bind _ = Nothing + -- Get source spans from names, discard unhelpful spans, remove + -- duplicates and sort. + sortedNameSpans :: [Located RdrName] -> [RealSrcSpan] + sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls) + isBetween target before after = before <= target && target <= after + ann = snd . pm_annotations + annotationFileName :: ParsedModule -> Maybe FastString + annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann + realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan] + realSpans = + mapMaybe (realSpan . getLoc) + . join + . M.elems + +-- | Shows this part of the documentation +docHeaders :: [RealLocated AnnotationComment] + -> [T.Text] +docHeaders = mapMaybe (\(L _ x) -> wrk x) + where + wrk = \case + -- When `Opt_Haddock` is enabled. + AnnDocCommentNext s -> Just $ T.pack s + -- When `Opt_KeepRawTokenStream` enabled. + AnnLineComment s -> if "-- |" `isPrefixOf` s + then Just $ T.pack s + else Nothing + _ -> Nothing + +-- These are taken from haskell-ide-engine's Haddock plugin + +-- | Given a module finds the local @doc/html/Foo-Bar-Baz.html@ page. +-- An example for a cabal installed module: +-- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/Data-Vector-Primitive.html@ +lookupDocHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath) +lookupDocHtmlForModule = + lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir modDocName <.> "html") + +-- | Given a module finds the hyperlinked source @doc/html/src/Foo.Bar.Baz.html@ page. +-- An example for a cabal installed module: +-- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/src/Data.Vector.Primitive.html@ +lookupSrcHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath) +lookupSrcHtmlForModule = + lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir "src" modDocName <.> "html") + +lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> DynFlags -> Module -> IO (Maybe FilePath) +lookupHtmlForModule mkDocPath df m = do + -- try all directories + let mfs = fmap (concatMap go) (lookupHtmls df ui) + html <- findM doesFileExist (concat . maybeToList $ mfs) + -- canonicalize located html to remove /../ indirection which can break some clients + -- (vscode on Windows at least) + traverse canonicalizePath html + where + go pkgDocDir = map (mkDocPath pkgDocDir) mns + ui = moduleUnitId m + -- try to locate html file from most to least specific name e.g. + -- first Language.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html + -- then Language.LSP.Types.html and Language-Haskell-LSP-Types.html etc. + mns = do + chunks <- (reverse . drop1 . inits . splitOn ".") $ (moduleNameString . moduleName) m + -- The file might use "." or "-" as separator + map (`intercalate` chunks) [".", "-"] + +lookupHtmls :: DynFlags -> UnitId -> Maybe [FilePath] +lookupHtmls df ui = + -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path + -- and therefore doesn't expand $topdir on Windows + map takeDirectory . haddockInterfaces <$> lookupPackage df ui diff --git a/src/Development/IDE/Spans/LocalBindings.hs b/src/Development/IDE/Spans/LocalBindings.hs --- a/src/Development/IDE/Spans/LocalBindings.hs +++ b/src/Development/IDE/Spans/LocalBindings.hs @@ -1,134 +1,134 @@ -{-# LANGUAGE DerivingStrategies #-} - -module Development.IDE.Spans.LocalBindings - ( Bindings - , getLocalScope - , getFuzzyScope - , getDefiningBindings - , getFuzzyDefiningBindings - , bindings - ) where - -import Control.DeepSeq -import Control.Monad -import Data.Bifunctor -import Data.IntervalMap.FingerTree (IntervalMap, Interval (..)) -import qualified Data.IntervalMap.FingerTree as IM -import qualified Data.List as L -import qualified Data.Map as M -import qualified Data.Set as S -import Development.IDE.GHC.Compat (RefMap, identType, identInfo, getScopeFromContext, getBindSiteFromContext, Scope(..), Name, Type) -import Development.IDE.GHC.Error -import Development.IDE.Types.Location -import NameEnv -import SrcLoc - ------------------------------------------------------------------------------- --- | Turn a 'RealSrcSpan' into an 'Interval'. -realSrcSpanToInterval :: RealSrcSpan -> Interval Position -realSrcSpanToInterval rss = - Interval - (realSrcLocToPosition $ realSrcSpanStart rss) - (realSrcLocToPosition $ realSrcSpanEnd rss) - -bindings :: RefMap Type -> Bindings -bindings = uncurry Bindings . localBindings - ------------------------------------------------------------------------------- --- | Compute which identifiers are in scope at every point in the AST. Use --- 'getLocalScope' to find the results. -localBindings - :: RefMap Type - -> ( IntervalMap Position (NameEnv (Name, Maybe Type)) - , IntervalMap Position (NameEnv (Name, Maybe Type)) - ) -localBindings refmap = bimap mk mk $ unzip $ do - (ident, refs) <- M.toList refmap - Right name <- pure ident - (_, ident_details) <- refs - let ty = identType ident_details - info <- S.toList $ identInfo ident_details - pure - ( do - Just scopes <- pure $ getScopeFromContext info - scope <- scopes >>= \case - LocalScope scope -> pure $ realSrcSpanToInterval scope - _ -> [] - pure ( scope - , unitNameEnv name (name,ty) - ) - , do - Just scope <- pure $ getBindSiteFromContext info - pure ( realSrcSpanToInterval scope - , unitNameEnv name (name,ty) - ) - ) - where - mk = L.foldl' (flip (uncurry IM.insert)) mempty . join - ------------------------------------------------------------------------------- --- | The available bindings at every point in a Haskell tree. -data Bindings = Bindings - { getLocalBindings - :: IntervalMap Position (NameEnv (Name, Maybe Type)) - , getBindingSites - :: IntervalMap Position (NameEnv (Name, Maybe Type)) - } - -instance Semigroup Bindings where - Bindings a1 b1 <> Bindings a2 b2 - = Bindings (a1 <> a2) (b1 <> b2) - -instance Monoid Bindings where - mempty = Bindings mempty mempty - -instance NFData Bindings where - rnf = rwhnf - -instance Show Bindings where - show _ = "" - - ------------------------------------------------------------------------------- --- | Given a 'Bindings' get every identifier in scope at the given --- 'RealSrcSpan', -getLocalScope :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] -getLocalScope bs rss - = nameEnvElts - $ foldMap snd - $ IM.dominators (realSrcSpanToInterval rss) - $ getLocalBindings bs - ------------------------------------------------------------------------------- --- | Given a 'Bindings', get every binding currently active at a given --- 'RealSrcSpan', -getDefiningBindings :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] -getDefiningBindings bs rss - = nameEnvElts - $ foldMap snd - $ IM.dominators (realSrcSpanToInterval rss) - $ getBindingSites bs - - --- | Lookup all names in scope in any span that intersects the interval --- defined by the two positions. --- This is meant for use with the fuzzy `PositionRange` returned by `PositionMapping` -getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)] -getFuzzyScope bs a b - = nameEnvElts - $ foldMap snd - $ IM.intersections (Interval a b) - $ getLocalBindings bs - ------------------------------------------------------------------------------- --- | Given a 'Bindings', get every binding that intersects the interval defined --- by the two positions. --- This is meant for use with the fuzzy `PositionRange` returned by --- `PositionMapping` -getFuzzyDefiningBindings :: Bindings -> Position -> Position -> [(Name, Maybe Type)] -getFuzzyDefiningBindings bs a b - = nameEnvElts - $ foldMap snd - $ IM.intersections (Interval a b) - $ getBindingSites bs - +{-# LANGUAGE DerivingStrategies #-} + +module Development.IDE.Spans.LocalBindings + ( Bindings + , getLocalScope + , getFuzzyScope + , getDefiningBindings + , getFuzzyDefiningBindings + , bindings + ) where + +import Control.DeepSeq +import Control.Monad +import Data.Bifunctor +import Data.IntervalMap.FingerTree (IntervalMap, Interval (..)) +import qualified Data.IntervalMap.FingerTree as IM +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Set as S +import Development.IDE.GHC.Compat (RefMap, identType, identInfo, getScopeFromContext, getBindSiteFromContext, Scope(..), Name, Type) +import Development.IDE.GHC.Error +import Development.IDE.Types.Location +import NameEnv +import SrcLoc + +------------------------------------------------------------------------------ +-- | Turn a 'RealSrcSpan' into an 'Interval'. +realSrcSpanToInterval :: RealSrcSpan -> Interval Position +realSrcSpanToInterval rss = + Interval + (realSrcLocToPosition $ realSrcSpanStart rss) + (realSrcLocToPosition $ realSrcSpanEnd rss) + +bindings :: RefMap Type -> Bindings +bindings = uncurry Bindings . localBindings + +------------------------------------------------------------------------------ +-- | Compute which identifiers are in scope at every point in the AST. Use +-- 'getLocalScope' to find the results. +localBindings + :: RefMap Type + -> ( IntervalMap Position (NameEnv (Name, Maybe Type)) + , IntervalMap Position (NameEnv (Name, Maybe Type)) + ) +localBindings refmap = bimap mk mk $ unzip $ do + (ident, refs) <- M.toList refmap + Right name <- pure ident + (_, ident_details) <- refs + let ty = identType ident_details + info <- S.toList $ identInfo ident_details + pure + ( do + Just scopes <- pure $ getScopeFromContext info + scope <- scopes >>= \case + LocalScope scope -> pure $ realSrcSpanToInterval scope + _ -> [] + pure ( scope + , unitNameEnv name (name,ty) + ) + , do + Just scope <- pure $ getBindSiteFromContext info + pure ( realSrcSpanToInterval scope + , unitNameEnv name (name,ty) + ) + ) + where + mk = L.foldl' (flip (uncurry IM.insert)) mempty . join + +------------------------------------------------------------------------------ +-- | The available bindings at every point in a Haskell tree. +data Bindings = Bindings + { getLocalBindings + :: IntervalMap Position (NameEnv (Name, Maybe Type)) + , getBindingSites + :: IntervalMap Position (NameEnv (Name, Maybe Type)) + } + +instance Semigroup Bindings where + Bindings a1 b1 <> Bindings a2 b2 + = Bindings (a1 <> a2) (b1 <> b2) + +instance Monoid Bindings where + mempty = Bindings mempty mempty + +instance NFData Bindings where + rnf = rwhnf + +instance Show Bindings where + show _ = "" + + +------------------------------------------------------------------------------ +-- | Given a 'Bindings' get every identifier in scope at the given +-- 'RealSrcSpan', +getLocalScope :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] +getLocalScope bs rss + = nameEnvElts + $ foldMap snd + $ IM.dominators (realSrcSpanToInterval rss) + $ getLocalBindings bs + +------------------------------------------------------------------------------ +-- | Given a 'Bindings', get every binding currently active at a given +-- 'RealSrcSpan', +getDefiningBindings :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] +getDefiningBindings bs rss + = nameEnvElts + $ foldMap snd + $ IM.dominators (realSrcSpanToInterval rss) + $ getBindingSites bs + + +-- | Lookup all names in scope in any span that intersects the interval +-- defined by the two positions. +-- This is meant for use with the fuzzy `PositionRange` returned by `PositionMapping` +getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)] +getFuzzyScope bs a b + = nameEnvElts + $ foldMap snd + $ IM.intersections (Interval a b) + $ getLocalBindings bs + +------------------------------------------------------------------------------ +-- | Given a 'Bindings', get every binding that intersects the interval defined +-- by the two positions. +-- This is meant for use with the fuzzy `PositionRange` returned by +-- `PositionMapping` +getFuzzyDefiningBindings :: Bindings -> Position -> Position -> [(Name, Maybe Type)] +getFuzzyDefiningBindings bs a b + = nameEnvElts + $ foldMap snd + $ IM.intersections (Interval a b) + $ getBindingSites bs + diff --git a/src/Development/IDE/Types/Action.hs b/src/Development/IDE/Types/Action.hs --- a/src/Development/IDE/Types/Action.hs +++ b/src/Development/IDE/Types/Action.hs @@ -1,88 +1,88 @@ -module Development.IDE.Types.Action - ( DelayedAction (..), - DelayedActionInternal, - ActionQueue, - newQueue, - pushQueue, - popQueue, - doneQueue, - peekInProgress, - abortQueue,countQueue) -where - -import Control.Concurrent.STM -import Data.Hashable (Hashable (..)) -import Data.HashSet (HashSet) -import qualified Data.HashSet as Set -import Data.Unique (Unique) -import Development.IDE.Types.Logger -import Development.Shake (Action) -import Numeric.Natural - -data DelayedAction a = DelayedAction - { uniqueID :: Maybe Unique, - -- | Name we use for debugging - actionName :: String, - -- | Priority with which to log the action - actionPriority :: Priority, - -- | The payload - getAction :: Action a - } - deriving (Functor) - -type DelayedActionInternal = DelayedAction () - -instance Eq (DelayedAction a) where - a == b = uniqueID a == uniqueID b - -instance Hashable (DelayedAction a) where - hashWithSalt s = hashWithSalt s . uniqueID - -instance Show (DelayedAction a) where - show d = "DelayedAction: " ++ actionName d - ------------------------------------------------------------------------------- - -data ActionQueue = ActionQueue - { newActions :: TQueue DelayedActionInternal, - inProgress :: TVar (HashSet DelayedActionInternal) - } - -newQueue :: IO ActionQueue -newQueue = atomically $ do - newActions <- newTQueue - inProgress <- newTVar mempty - return ActionQueue {..} - -pushQueue :: DelayedActionInternal -> ActionQueue -> STM () -pushQueue act ActionQueue {..} = writeTQueue newActions act - --- | You must call 'doneQueue' to signal completion -popQueue :: ActionQueue -> STM DelayedActionInternal -popQueue ActionQueue {..} = do - x <- readTQueue newActions - modifyTVar inProgress (Set.insert x) - return x - --- | Completely remove an action from the queue -abortQueue :: DelayedActionInternal -> ActionQueue -> STM () -abortQueue x ActionQueue {..} = do - qq <- flushTQueue newActions - mapM_ (writeTQueue newActions) (filter (/= x) qq) - modifyTVar inProgress (Set.delete x) - --- | Mark an action as complete when called after 'popQueue'. --- Has no effect otherwise -doneQueue :: DelayedActionInternal -> ActionQueue -> STM () -doneQueue x ActionQueue {..} = do - modifyTVar inProgress (Set.delete x) - -countQueue :: ActionQueue -> STM Natural -countQueue ActionQueue{..} = do - backlog <- flushTQueue newActions - mapM_ (writeTQueue newActions) backlog - m <- Set.size <$> readTVar inProgress - return $ fromIntegral $ length backlog + m - -peekInProgress :: ActionQueue -> STM [DelayedActionInternal] -peekInProgress ActionQueue {..} = Set.toList <$> readTVar inProgress +module Development.IDE.Types.Action + ( DelayedAction (..), + DelayedActionInternal, + ActionQueue, + newQueue, + pushQueue, + popQueue, + doneQueue, + peekInProgress, + abortQueue,countQueue) +where + +import Control.Concurrent.STM +import Data.HashSet (HashSet) +import qualified Data.HashSet as Set +import Data.Hashable (Hashable (..)) +import Data.Unique (Unique) +import Development.IDE.Types.Logger +import Development.Shake (Action) +import Numeric.Natural + +data DelayedAction a = DelayedAction + { uniqueID :: Maybe Unique, + -- | Name we use for debugging + actionName :: String, + -- | Priority with which to log the action + actionPriority :: Priority, + -- | The payload + getAction :: Action a + } + deriving (Functor) + +type DelayedActionInternal = DelayedAction () + +instance Eq (DelayedAction a) where + a == b = uniqueID a == uniqueID b + +instance Hashable (DelayedAction a) where + hashWithSalt s = hashWithSalt s . uniqueID + +instance Show (DelayedAction a) where + show d = "DelayedAction: " ++ actionName d + +------------------------------------------------------------------------------ + +data ActionQueue = ActionQueue + { newActions :: TQueue DelayedActionInternal, + inProgress :: TVar (HashSet DelayedActionInternal) + } + +newQueue :: IO ActionQueue +newQueue = atomically $ do + newActions <- newTQueue + inProgress <- newTVar mempty + return ActionQueue {..} + +pushQueue :: DelayedActionInternal -> ActionQueue -> STM () +pushQueue act ActionQueue {..} = writeTQueue newActions act + +-- | You must call 'doneQueue' to signal completion +popQueue :: ActionQueue -> STM DelayedActionInternal +popQueue ActionQueue {..} = do + x <- readTQueue newActions + modifyTVar inProgress (Set.insert x) + return x + +-- | Completely remove an action from the queue +abortQueue :: DelayedActionInternal -> ActionQueue -> STM () +abortQueue x ActionQueue {..} = do + qq <- flushTQueue newActions + mapM_ (writeTQueue newActions) (filter (/= x) qq) + modifyTVar inProgress (Set.delete x) + +-- | Mark an action as complete when called after 'popQueue'. +-- Has no effect otherwise +doneQueue :: DelayedActionInternal -> ActionQueue -> STM () +doneQueue x ActionQueue {..} = do + modifyTVar inProgress (Set.delete x) + +countQueue :: ActionQueue -> STM Natural +countQueue ActionQueue{..} = do + backlog <- flushTQueue newActions + mapM_ (writeTQueue newActions) backlog + m <- Set.size <$> readTVar inProgress + return $ fromIntegral $ length backlog + m + +peekInProgress :: ActionQueue -> STM [DelayedActionInternal] +peekInProgress ActionQueue {..} = Set.toList <$> readTVar inProgress diff --git a/src/Development/IDE/Types/Diagnostics.hs b/src/Development/IDE/Types/Diagnostics.hs --- a/src/Development/IDE/Types/Diagnostics.hs +++ b/src/Development/IDE/Types/Diagnostics.hs @@ -1,151 +1,150 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - - -module Development.IDE.Types.Diagnostics ( - LSP.Diagnostic(..), - ShowDiagnostic(..), - FileDiagnostic, - IdeResult, - LSP.DiagnosticSeverity(..), - DiagnosticStore, - List(..), - ideErrorText, - ideErrorWithSource, - showDiagnostics, - showDiagnosticsColored, - ) where - -import Control.DeepSeq -import Data.Maybe as Maybe -import qualified Data.Text as T -import Data.Text.Prettyprint.Doc -import Language.LSP.Types as LSP (DiagnosticSource, - DiagnosticSeverity(..) - , Diagnostic(..) - , List(..) - ) -import Language.LSP.Diagnostics -import Data.Text.Prettyprint.Doc.Render.Text -import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal -import Data.Text.Prettyprint.Doc.Render.Terminal (Color(..), color) - -import Development.IDE.Types.Location - - --- | The result of an IDE operation. Warnings and errors are in the Diagnostic, --- and a value is in the Maybe. For operations that throw an error you --- expect a non-empty list of diagnostics, at least one of which is an error, --- and a Nothing. For operations that succeed you expect perhaps some warnings --- and a Just. For operations that depend on other failing operations you may --- get empty diagnostics and a Nothing, to indicate this phase throws no fresh --- errors but still failed. --- --- A rule on a file should only return diagnostics for that given file. It should --- not propagate diagnostic errors through multiple phases. -type IdeResult v = ([FileDiagnostic], Maybe v) - -ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic -ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError) - -ideErrorWithSource - :: Maybe DiagnosticSource - -> Maybe DiagnosticSeverity - -> a - -> T.Text - -> (a, ShowDiagnostic, Diagnostic) -ideErrorWithSource source sev fp msg = (fp, ShowDiag, LSP.Diagnostic { - _range = noRange, - _severity = sev, - _code = Nothing, - _source = source, - _message = msg, - _relatedInformation = Nothing, - _tags = Nothing - }) - --- | Defines whether a particular diagnostic should be reported --- back to the user. --- --- One important use case is "missing signature" code lenses, --- for which we need to enable the corresponding warning during --- type checking. However, we do not want to show the warning --- unless the programmer asks for it (#261). -data ShowDiagnostic - = ShowDiag -- ^ Report back to the user - | HideDiag -- ^ Hide from user - deriving (Eq, Ord, Show) - -instance NFData ShowDiagnostic where - rnf = rwhnf - --- | Human readable diagnostics for a specific file. --- --- This type packages a pretty printed, human readable error message --- along with the related source location so that we can display the error --- on either the console or in the IDE at the right source location. --- -type FileDiagnostic = (NormalizedFilePath, ShowDiagnostic, Diagnostic) - -prettyRange :: Range -> Doc Terminal.AnsiStyle -prettyRange Range{..} = f _start <> "-" <> f _end - where f Position{..} = pretty (_line+1) <> colon <> pretty (_character+1) - -stringParagraphs :: T.Text -> Doc a -stringParagraphs = vcat . map (fillSep . map pretty . T.words) . T.lines - -showDiagnostics :: [FileDiagnostic] -> T.Text -showDiagnostics = srenderPlain . prettyDiagnostics - -showDiagnosticsColored :: [FileDiagnostic] -> T.Text -showDiagnosticsColored = srenderColored . prettyDiagnostics - - -prettyDiagnostics :: [FileDiagnostic] -> Doc Terminal.AnsiStyle -prettyDiagnostics = vcat . map prettyDiagnostic - -prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle -prettyDiagnostic (fp, sh, LSP.Diagnostic{..}) = - vcat - [ slabel_ "File: " $ pretty (fromNormalizedFilePath fp) - , slabel_ "Hidden: " $ if sh == ShowDiag then "no" else "yes" - , slabel_ "Range: " $ prettyRange _range - , slabel_ "Source: " $ pretty _source - , slabel_ "Severity:" $ pretty $ show sev - , slabel_ "Message: " - $ case sev of - LSP.DsError -> annotate $ color Red - LSP.DsWarning -> annotate $ color Yellow - LSP.DsInfo -> annotate $ color Blue - LSP.DsHint -> annotate $ color Magenta - $ stringParagraphs _message - ] - where - sev = fromMaybe LSP.DsError _severity - - --- | Label a document. -slabel_ :: String -> Doc a -> Doc a -slabel_ t d = nest 2 $ sep [pretty t, d] - --- | The layout options used for the SDK assistant. -cliLayout :: - Int - -- ^ Rendering width of the pretty printer. - -> LayoutOptions -cliLayout renderWidth = LayoutOptions - { layoutPageWidth = AvailablePerLine renderWidth 0.9 - } - --- | Render without any syntax annotations -srenderPlain :: Doc ann -> T.Text -srenderPlain = renderStrict . layoutSmart (cliLayout defaultTermWidth) - --- | Render a 'Document' as an ANSII colored string. -srenderColored :: Doc Terminal.AnsiStyle -> T.Text -srenderColored = - Terminal.renderStrict . - layoutSmart defaultLayoutOptions { layoutPageWidth = AvailablePerLine 100 1.0 } - -defaultTermWidth :: Int -defaultTermWidth = 80 +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + + +module Development.IDE.Types.Diagnostics ( + LSP.Diagnostic(..), + ShowDiagnostic(..), + FileDiagnostic, + IdeResult, + LSP.DiagnosticSeverity(..), + DiagnosticStore, + List(..), + ideErrorText, + ideErrorWithSource, + showDiagnostics, + showDiagnosticsColored, + ) where + +import Control.DeepSeq +import Data.Maybe as Maybe +import qualified Data.Text as T +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Terminal (Color (..), color) +import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal +import Data.Text.Prettyprint.Doc.Render.Text +import Language.LSP.Diagnostics +import Language.LSP.Types as LSP (Diagnostic (..), + DiagnosticSeverity (..), + DiagnosticSource, + List (..)) + +import Development.IDE.Types.Location + + +-- | The result of an IDE operation. Warnings and errors are in the Diagnostic, +-- and a value is in the Maybe. For operations that throw an error you +-- expect a non-empty list of diagnostics, at least one of which is an error, +-- and a Nothing. For operations that succeed you expect perhaps some warnings +-- and a Just. For operations that depend on other failing operations you may +-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh +-- errors but still failed. +-- +-- A rule on a file should only return diagnostics for that given file. It should +-- not propagate diagnostic errors through multiple phases. +type IdeResult v = ([FileDiagnostic], Maybe v) + +ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic +ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError) + +ideErrorWithSource + :: Maybe DiagnosticSource + -> Maybe DiagnosticSeverity + -> a + -> T.Text + -> (a, ShowDiagnostic, Diagnostic) +ideErrorWithSource source sev fp msg = (fp, ShowDiag, LSP.Diagnostic { + _range = noRange, + _severity = sev, + _code = Nothing, + _source = source, + _message = msg, + _relatedInformation = Nothing, + _tags = Nothing + }) + +-- | Defines whether a particular diagnostic should be reported +-- back to the user. +-- +-- One important use case is "missing signature" code lenses, +-- for which we need to enable the corresponding warning during +-- type checking. However, we do not want to show the warning +-- unless the programmer asks for it (#261). +data ShowDiagnostic + = ShowDiag -- ^ Report back to the user + | HideDiag -- ^ Hide from user + deriving (Eq, Ord, Show) + +instance NFData ShowDiagnostic where + rnf = rwhnf + +-- | Human readable diagnostics for a specific file. +-- +-- This type packages a pretty printed, human readable error message +-- along with the related source location so that we can display the error +-- on either the console or in the IDE at the right source location. +-- +type FileDiagnostic = (NormalizedFilePath, ShowDiagnostic, Diagnostic) + +prettyRange :: Range -> Doc Terminal.AnsiStyle +prettyRange Range{..} = f _start <> "-" <> f _end + where f Position{..} = pretty (_line+1) <> colon <> pretty (_character+1) + +stringParagraphs :: T.Text -> Doc a +stringParagraphs = vcat . map (fillSep . map pretty . T.words) . T.lines + +showDiagnostics :: [FileDiagnostic] -> T.Text +showDiagnostics = srenderPlain . prettyDiagnostics + +showDiagnosticsColored :: [FileDiagnostic] -> T.Text +showDiagnosticsColored = srenderColored . prettyDiagnostics + + +prettyDiagnostics :: [FileDiagnostic] -> Doc Terminal.AnsiStyle +prettyDiagnostics = vcat . map prettyDiagnostic + +prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle +prettyDiagnostic (fp, sh, LSP.Diagnostic{..}) = + vcat + [ slabel_ "File: " $ pretty (fromNormalizedFilePath fp) + , slabel_ "Hidden: " $ if sh == ShowDiag then "no" else "yes" + , slabel_ "Range: " $ prettyRange _range + , slabel_ "Source: " $ pretty _source + , slabel_ "Severity:" $ pretty $ show sev + , slabel_ "Message: " + $ case sev of + LSP.DsError -> annotate $ color Red + LSP.DsWarning -> annotate $ color Yellow + LSP.DsInfo -> annotate $ color Blue + LSP.DsHint -> annotate $ color Magenta + $ stringParagraphs _message + ] + where + sev = fromMaybe LSP.DsError _severity + + +-- | Label a document. +slabel_ :: String -> Doc a -> Doc a +slabel_ t d = nest 2 $ sep [pretty t, d] + +-- | The layout options used for the SDK assistant. +cliLayout :: + Int + -- ^ Rendering width of the pretty printer. + -> LayoutOptions +cliLayout renderWidth = LayoutOptions + { layoutPageWidth = AvailablePerLine renderWidth 0.9 + } + +-- | Render without any syntax annotations +srenderPlain :: Doc ann -> T.Text +srenderPlain = renderStrict . layoutSmart (cliLayout defaultTermWidth) + +-- | Render a 'Document' as an ANSII colored string. +srenderColored :: Doc Terminal.AnsiStyle -> T.Text +srenderColored = + Terminal.renderStrict . + layoutSmart defaultLayoutOptions { layoutPageWidth = AvailablePerLine 100 1.0 } + +defaultTermWidth :: Int +defaultTermWidth = 80 diff --git a/src/Development/IDE/Types/Exports.hs b/src/Development/IDE/Types/Exports.hs --- a/src/Development/IDE/Types/Exports.hs +++ b/src/Development/IDE/Types/Exports.hs @@ -1,101 +1,101 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -module Development.IDE.Types.Exports -( - IdentInfo(..), - ExportsMap(..), - createExportsMap, - createExportsMapMg, - createExportsMapTc -) where - -import Avail (AvailInfo(..)) -import Control.DeepSeq (NFData(..)) -import Data.Text (pack, Text) -import Development.IDE.GHC.Compat -import Development.IDE.GHC.Util -import Data.HashMap.Strict (HashMap) -import GHC.Generics (Generic) -import Name -import FieldLabel (flSelector) -import qualified Data.HashMap.Strict as Map -import GhcPlugins (IfaceExport, ModGuts(..)) -import Data.HashSet (HashSet) -import qualified Data.HashSet as Set -import Data.Bifunctor (Bifunctor(second)) -import Data.Hashable (Hashable) -import TcRnTypes(TcGblEnv(..)) - -newtype ExportsMap = ExportsMap - {getExportsMap :: HashMap IdentifierText (HashSet IdentInfo)} - deriving newtype (Monoid, NFData, Show) - -instance Semigroup ExportsMap where - ExportsMap a <> ExportsMap b = ExportsMap $ Map.unionWith (<>) a b - -type IdentifierText = Text - -data IdentInfo = IdentInfo - { name :: !Text - , rendered :: Text - , parent :: !(Maybe Text) - , isDatacon :: !Bool - , moduleNameText :: !Text - } - deriving (Generic, Show) - deriving anyclass Hashable - -instance Eq IdentInfo where - a == b = name a == name b - && parent a == parent b - && isDatacon a == isDatacon b - && moduleNameText a == moduleNameText b - -instance NFData IdentInfo where - rnf IdentInfo{..} = - -- deliberately skip the rendered field - rnf name `seq` rnf parent `seq` rnf isDatacon `seq` rnf moduleNameText - -mkIdentInfos :: Text -> AvailInfo -> [IdentInfo] -mkIdentInfos mod (Avail n) = - [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) mod] -mkIdentInfos mod (AvailTC parent (n:nn) flds) - -- Following the GHC convention that parent == n if parent is exported - | n == parent - = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) (isDataConName n) mod - | n <- nn ++ map flSelector flds - ] ++ - [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) mod] - where - parentP = pack $ printName parent - -mkIdentInfos mod (AvailTC _ nn flds) - = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) mod - | n <- nn ++ map flSelector flds - ] - -createExportsMap :: [ModIface] -> ExportsMap -createExportsMap = ExportsMap . Map.fromListWith (<>) . concatMap doOne - where - doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (mi_exports mi) - where - mn = moduleName $ mi_module mi - -createExportsMapMg :: [ModGuts] -> ExportsMap -createExportsMapMg = ExportsMap . Map.fromListWith (<>) . concatMap doOne - where - doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (mg_exports mi) - where - mn = moduleName $ mg_module mi - -createExportsMapTc :: [TcGblEnv] -> ExportsMap -createExportsMapTc = ExportsMap . Map.fromListWith (<>) . concatMap doOne - where - doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (tcg_exports mi) - where - mn = moduleName $ tcg_mod mi - -unpackAvail :: ModuleName -> IfaceExport -> [(Text, [IdentInfo])] -unpackAvail !(pack . moduleNameString -> mod) = map f . mkIdentInfos mod - where - f id@IdentInfo {..} = (name, [id]) +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +module Development.IDE.Types.Exports +( + IdentInfo(..), + ExportsMap(..), + createExportsMap, + createExportsMapMg, + createExportsMapTc +) where + +import Avail (AvailInfo (..)) +import Control.DeepSeq (NFData (..)) +import Data.Bifunctor (Bifunctor (second)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map +import Data.HashSet (HashSet) +import qualified Data.HashSet as Set +import Data.Hashable (Hashable) +import Data.Text (Text, pack) +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Util +import FieldLabel (flSelector) +import GHC.Generics (Generic) +import GhcPlugins (IfaceExport, ModGuts (..)) +import Name +import TcRnTypes (TcGblEnv (..)) + +newtype ExportsMap = ExportsMap + {getExportsMap :: HashMap IdentifierText (HashSet IdentInfo)} + deriving newtype (Monoid, NFData, Show) + +instance Semigroup ExportsMap where + ExportsMap a <> ExportsMap b = ExportsMap $ Map.unionWith (<>) a b + +type IdentifierText = Text + +data IdentInfo = IdentInfo + { name :: !Text + , rendered :: Text + , parent :: !(Maybe Text) + , isDatacon :: !Bool + , moduleNameText :: !Text + } + deriving (Generic, Show) + deriving anyclass Hashable + +instance Eq IdentInfo where + a == b = name a == name b + && parent a == parent b + && isDatacon a == isDatacon b + && moduleNameText a == moduleNameText b + +instance NFData IdentInfo where + rnf IdentInfo{..} = + -- deliberately skip the rendered field + rnf name `seq` rnf parent `seq` rnf isDatacon `seq` rnf moduleNameText + +mkIdentInfos :: Text -> AvailInfo -> [IdentInfo] +mkIdentInfos mod (Avail n) = + [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) mod] +mkIdentInfos mod (AvailTC parent (n:nn) flds) + -- Following the GHC convention that parent == n if parent is exported + | n == parent + = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) (isDataConName n) mod + | n <- nn ++ map flSelector flds + ] ++ + [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) mod] + where + parentP = pack $ printName parent + +mkIdentInfos mod (AvailTC _ nn flds) + = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) mod + | n <- nn ++ map flSelector flds + ] + +createExportsMap :: [ModIface] -> ExportsMap +createExportsMap = ExportsMap . Map.fromListWith (<>) . concatMap doOne + where + doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (mi_exports mi) + where + mn = moduleName $ mi_module mi + +createExportsMapMg :: [ModGuts] -> ExportsMap +createExportsMapMg = ExportsMap . Map.fromListWith (<>) . concatMap doOne + where + doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (mg_exports mi) + where + mn = moduleName $ mg_module mi + +createExportsMapTc :: [TcGblEnv] -> ExportsMap +createExportsMapTc = ExportsMap . Map.fromListWith (<>) . concatMap doOne + where + doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (tcg_exports mi) + where + mn = moduleName $ tcg_mod mi + +unpackAvail :: ModuleName -> IfaceExport -> [(Text, [IdentInfo])] +unpackAvail !(pack . moduleNameString -> mod) = map f . mkIdentInfos mod + where + f id@IdentInfo {..} = (name, [id]) diff --git a/src/Development/IDE/Types/HscEnvEq.hs b/src/Development/IDE/Types/HscEnvEq.hs --- a/src/Development/IDE/Types/HscEnvEq.hs +++ b/src/Development/IDE/Types/HscEnvEq.hs @@ -1,159 +1,165 @@ -module Development.IDE.Types.HscEnvEq -( HscEnvEq, - hscEnv, newHscEnvEq, - hscEnvWithImportPaths, - newHscEnvEqPreserveImportPaths, - newHscEnvEqWithImportPaths, - envImportPaths, - envPackageExports, - envVisibleModuleNames, - deps -) where - - -import Development.IDE.Types.Exports (ExportsMap, createExportsMap) -import Data.Unique -import Development.Shake.Classes -import Module (InstalledUnitId) -import System.Directory (canonicalizePath) -import Development.IDE.GHC.Compat -import GhcPlugins(HscEnv (hsc_dflags), PackageState (explicitPackages), InstalledPackageInfo (exposedModules), Module(..), packageConfigId, listVisibleModuleNames) -import System.FilePath -import Development.IDE.GHC.Util (lookupPackageConfig) -import Control.Monad.IO.Class -import TcRnMonad (initIfaceLoad, WhereFrom (ImportByUser)) -import LoadIface (loadInterface) -import qualified Maybes -import OpenTelemetry.Eventlog (withSpan) -import Control.Monad.Extra (mapMaybeM, join, eitherM) -import Control.Concurrent.Extra (newVar, modifyVar) -import Control.Concurrent.Async (Async, async, waitCatch) -import Control.Exception (throwIO, mask, evaluate) -import Development.IDE.GHC.Error (catchSrcErrors) -import Control.DeepSeq (force) -import Data.Either (fromRight) - --- | An 'HscEnv' with equality. Two values are considered equal --- if they are created with the same call to 'newHscEnvEq'. -data HscEnvEq = HscEnvEq - { envUnique :: !Unique - , hscEnv :: !HscEnv - , deps :: [(InstalledUnitId, DynFlags)] - -- ^ In memory components for this HscEnv - -- This is only used at the moment for the import dirs in - -- the DynFlags - , envImportPaths :: Maybe [String] - -- ^ If Just, import dirs originally configured in this env - -- If Nothing, the env import dirs are unaltered - , envPackageExports :: IO ExportsMap - , envVisibleModuleNames :: IO (Maybe [ModuleName]) - -- ^ 'listVisibleModuleNames' is a pure function, - -- but it could panic due to a ghc bug: https://github.com/haskell/haskell-language-server/issues/1365 - -- So it's wrapped in IO here for error handling - -- If Nothing, 'listVisibleModuleNames' panic - } - --- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEq :: FilePath -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEq cradlePath hscEnv0 deps = do - let relativeToCradle = (takeDirectory cradlePath ) - hscEnv = removeImportPaths hscEnv0 - - -- Canonicalize import paths since we also canonicalize targets - importPathsCanon <- - mapM canonicalizePath $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) - - newHscEnvEqWithImportPaths (Just importPathsCanon) hscEnv deps - -newHscEnvEqWithImportPaths :: Maybe [String] -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do - - let dflags = hsc_dflags hscEnv - - envUnique <- newUnique - - -- it's very important to delay the package exports computation - envPackageExports <- onceAsync $ withSpan "Package Exports" $ \_sp -> do - -- compute the package imports - let pkgst = pkgState dflags - depends = explicitPackages pkgst - targets = - [ (pkg, mn) - | d <- depends - , Just pkg <- [lookupPackageConfig d hscEnv] - , (mn, _) <- exposedModules pkg - ] - - doOne (pkg, mn) = do - modIface <- liftIO $ initIfaceLoad hscEnv $ loadInterface - "" - (Module (packageConfigId pkg) mn) - (ImportByUser False) - return $ case modIface of - Maybes.Failed _r -> Nothing - Maybes.Succeeded mi -> Just mi - modIfaces <- mapMaybeM doOne targets - return $ createExportsMap modIfaces - - -- similar to envPackageExports, evaluated lazily - envVisibleModuleNames <- onceAsync $ - fromRight Nothing - <$> catchSrcErrors - dflags - "listVisibleModuleNames" - (evaluate . force . Just $ listVisibleModuleNames dflags) - - return HscEnvEq{..} - --- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEqPreserveImportPaths - :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing - --- | Unwrap the 'HscEnv' with the original import paths. --- Used only for locating imports -hscEnvWithImportPaths :: HscEnvEq -> HscEnv -hscEnvWithImportPaths HscEnvEq{..} - | Just imps <- envImportPaths - = hscEnv{hsc_dflags = (hsc_dflags hscEnv){importPaths = imps}} - | otherwise - = hscEnv - -removeImportPaths :: HscEnv -> HscEnv -removeImportPaths hsc = hsc{hsc_dflags = (hsc_dflags hsc){importPaths = []}} - -instance Show HscEnvEq where - show HscEnvEq{envUnique} = "HscEnvEq " ++ show (hashUnique envUnique) - -instance Eq HscEnvEq where - a == b = envUnique a == envUnique b - -instance NFData HscEnvEq where - rnf (HscEnvEq a b c d _ _) = - -- deliberately skip the package exports map and visible module names - rnf (hashUnique a) `seq` b `seq` c `seq` rnf d - -instance Hashable HscEnvEq where - hashWithSalt s = hashWithSalt s . envUnique - --- Fake instance needed to persuade Shake to accept this type as a key. --- No harm done as ghcide never persists these keys currently -instance Binary HscEnvEq where - put _ = error "not really" - get = error "not really" - --- | Given an action, produce a wrapped action that runs at most once. --- The action is run in an async so it won't be killed by async exceptions --- If the function raises an exception, the same exception will be reraised each time. -onceAsync :: IO a -> IO (IO a) -onceAsync act = do - var <- newVar OncePending - let run as = eitherM throwIO pure (waitCatch as) - pure $ mask $ \unmask -> join $ modifyVar var $ \v -> case v of - OnceRunning x -> pure (v, unmask $ run x) - OncePending -> do - x <- async (unmask act) - pure (OnceRunning x, unmask $ run x) - -data Once a = OncePending | OnceRunning (Async a) - +module Development.IDE.Types.HscEnvEq +( HscEnvEq, + hscEnv, newHscEnvEq, + hscEnvWithImportPaths, + newHscEnvEqPreserveImportPaths, + newHscEnvEqWithImportPaths, + envImportPaths, + envPackageExports, + envVisibleModuleNames, + deps +) where + + +import Control.Concurrent.Async (Async, async, waitCatch) +import Control.Concurrent.Strict (modifyVar, newVar) +import Control.DeepSeq (force) +import Control.Exception (evaluate, mask, throwIO) +import Control.Monad.Extra (eitherM, join, mapMaybeM) +import Control.Monad.IO.Class +import Data.Either (fromRight) +import Data.Unique +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Error (catchSrcErrors) +import Development.IDE.GHC.Util (lookupPackageConfig) +import Development.IDE.Types.Exports (ExportsMap, createExportsMap) +import Development.Shake.Classes +import GhcPlugins (HscEnv (hsc_dflags), + InstalledPackageInfo (exposedModules), + Module (..), + PackageState (explicitPackages), + listVisibleModuleNames, + packageConfigId) +import LoadIface (loadInterface) +import qualified Maybes +import Module (InstalledUnitId) +import OpenTelemetry.Eventlog (withSpan) +import System.Directory (canonicalizePath) +import System.FilePath +import TcRnMonad (WhereFrom (ImportByUser), + initIfaceLoad) + +-- | An 'HscEnv' with equality. Two values are considered equal +-- if they are created with the same call to 'newHscEnvEq'. +data HscEnvEq = HscEnvEq + { envUnique :: !Unique + , hscEnv :: !HscEnv + , deps :: [(InstalledUnitId, DynFlags)] + -- ^ In memory components for this HscEnv + -- This is only used at the moment for the import dirs in + -- the DynFlags + , envImportPaths :: Maybe [String] + -- ^ If Just, import dirs originally configured in this env + -- If Nothing, the env import dirs are unaltered + , envPackageExports :: IO ExportsMap + , envVisibleModuleNames :: IO (Maybe [ModuleName]) + -- ^ 'listVisibleModuleNames' is a pure function, + -- but it could panic due to a ghc bug: https://github.com/haskell/haskell-language-server/issues/1365 + -- So it's wrapped in IO here for error handling + -- If Nothing, 'listVisibleModuleNames' panic + } + +-- | Wrap an 'HscEnv' into an 'HscEnvEq'. +newHscEnvEq :: FilePath -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEq cradlePath hscEnv0 deps = do + let relativeToCradle = (takeDirectory cradlePath ) + hscEnv = removeImportPaths hscEnv0 + + -- Canonicalize import paths since we also canonicalize targets + importPathsCanon <- + mapM canonicalizePath $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) + + newHscEnvEqWithImportPaths (Just importPathsCanon) hscEnv deps + +newHscEnvEqWithImportPaths :: Maybe [String] -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do + + let dflags = hsc_dflags hscEnv + + envUnique <- newUnique + + -- it's very important to delay the package exports computation + envPackageExports <- onceAsync $ withSpan "Package Exports" $ \_sp -> do + -- compute the package imports + let pkgst = pkgState dflags + depends = explicitPackages pkgst + targets = + [ (pkg, mn) + | d <- depends + , Just pkg <- [lookupPackageConfig d hscEnv] + , (mn, _) <- exposedModules pkg + ] + + doOne (pkg, mn) = do + modIface <- liftIO $ initIfaceLoad hscEnv $ loadInterface + "" + (Module (packageConfigId pkg) mn) + (ImportByUser False) + return $ case modIface of + Maybes.Failed _r -> Nothing + Maybes.Succeeded mi -> Just mi + modIfaces <- mapMaybeM doOne targets + return $ createExportsMap modIfaces + + -- similar to envPackageExports, evaluated lazily + envVisibleModuleNames <- onceAsync $ + fromRight Nothing + <$> catchSrcErrors + dflags + "listVisibleModuleNames" + (evaluate . force . Just $ listVisibleModuleNames dflags) + + return HscEnvEq{..} + +-- | Wrap an 'HscEnv' into an 'HscEnvEq'. +newHscEnvEqPreserveImportPaths + :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing + +-- | Unwrap the 'HscEnv' with the original import paths. +-- Used only for locating imports +hscEnvWithImportPaths :: HscEnvEq -> HscEnv +hscEnvWithImportPaths HscEnvEq{..} + | Just imps <- envImportPaths + = hscEnv{hsc_dflags = (hsc_dflags hscEnv){importPaths = imps}} + | otherwise + = hscEnv + +removeImportPaths :: HscEnv -> HscEnv +removeImportPaths hsc = hsc{hsc_dflags = (hsc_dflags hsc){importPaths = []}} + +instance Show HscEnvEq where + show HscEnvEq{envUnique} = "HscEnvEq " ++ show (hashUnique envUnique) + +instance Eq HscEnvEq where + a == b = envUnique a == envUnique b + +instance NFData HscEnvEq where + rnf (HscEnvEq a b c d _ _) = + -- deliberately skip the package exports map and visible module names + rnf (hashUnique a) `seq` b `seq` c `seq` rnf d + +instance Hashable HscEnvEq where + hashWithSalt s = hashWithSalt s . envUnique + +-- Fake instance needed to persuade Shake to accept this type as a key. +-- No harm done as ghcide never persists these keys currently +instance Binary HscEnvEq where + put _ = error "not really" + get = error "not really" + +-- | Given an action, produce a wrapped action that runs at most once. +-- The action is run in an async so it won't be killed by async exceptions +-- If the function raises an exception, the same exception will be reraised each time. +onceAsync :: IO a -> IO (IO a) +onceAsync act = do + var <- newVar OncePending + let run as = eitherM throwIO pure (waitCatch as) + pure $ mask $ \unmask -> join $ modifyVar var $ \v -> case v of + OnceRunning x -> pure (v, unmask $ run x) + OncePending -> do + x <- async (unmask act) + pure (OnceRunning x, unmask $ run x) + +data Once a = OncePending | OnceRunning (Async a) + diff --git a/src/Development/IDE/Types/KnownTargets.hs b/src/Development/IDE/Types/KnownTargets.hs --- a/src/Development/IDE/Types/KnownTargets.hs +++ b/src/Development/IDE/Types/KnownTargets.hs @@ -1,24 +1,24 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -module Development.IDE.Types.KnownTargets (KnownTargets, Target(..), toKnownFiles) where - -import Data.HashMap.Strict -import Development.IDE.Types.Location -import Development.IDE.GHC.Compat (ModuleName) -import Development.IDE.GHC.Orphans () -import Data.Hashable -import GHC.Generics -import Control.DeepSeq -import Data.HashSet -import qualified Data.HashSet as HSet -import qualified Data.HashMap.Strict as HMap - --- | A mapping of module name to known files -type KnownTargets = HashMap Target [NormalizedFilePath] - -data Target = TargetModule ModuleName | TargetFile NormalizedFilePath - deriving ( Eq, Generic, Show ) - deriving anyclass (Hashable, NFData) - -toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath -toKnownFiles = HSet.fromList . concat . HMap.elems +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +module Development.IDE.Types.KnownTargets (KnownTargets, Target(..), toKnownFiles) where + +import Control.DeepSeq +import Data.HashMap.Strict +import qualified Data.HashMap.Strict as HMap +import Data.HashSet +import qualified Data.HashSet as HSet +import Data.Hashable +import Development.IDE.GHC.Compat (ModuleName) +import Development.IDE.GHC.Orphans () +import Development.IDE.Types.Location +import GHC.Generics + +-- | A mapping of module name to known files +type KnownTargets = HashMap Target [NormalizedFilePath] + +data Target = TargetModule ModuleName | TargetFile NormalizedFilePath + deriving ( Eq, Generic, Show ) + deriving anyclass (Hashable, NFData) + +toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath +toKnownFiles = HSet.fromList . concat . HMap.elems diff --git a/src/Development/IDE/Types/Location.hs b/src/Development/IDE/Types/Location.hs --- a/src/Development/IDE/Types/Location.hs +++ b/src/Development/IDE/Types/Location.hs @@ -1,112 +1,113 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - - --- | Types and functions for working with source code locations. -module Development.IDE.Types.Location - ( Location(..) - , noFilePath - , noRange - , Position(..) - , showPosition - , Range(..) - , LSP.Uri(..) - , LSP.NormalizedUri - , LSP.toNormalizedUri - , LSP.fromNormalizedUri - , LSP.NormalizedFilePath - , fromUri - , emptyFilePath - , emptyPathUri - , toNormalizedFilePath' - , LSP.fromNormalizedFilePath - , filePathToUri' - , uriToFilePath' - , readSrcSpan - ) where - -import Control.Applicative -import Language.LSP.Types (Location(..), Range(..), Position(..)) -import Control.Monad -import Data.Hashable (Hashable(hash)) -import Data.String -import FastString -import qualified Language.LSP.Types as LSP -import SrcLoc as GHC -import Text.ParserCombinators.ReadP as ReadP -import Data.Maybe (fromMaybe) - -toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath --- We want to keep empty paths instead of normalising them to "." -toNormalizedFilePath' "" = emptyFilePath -toNormalizedFilePath' fp = LSP.toNormalizedFilePath fp - -emptyFilePath :: LSP.NormalizedFilePath -emptyFilePath = LSP.NormalizedFilePath emptyPathUri "" - --- | We use an empty string as a filepath when we don’t have a file. --- However, haskell-lsp doesn’t support that in uriToFilePath and given --- that it is not a valid filepath it does not make sense to upstream a fix. --- So we have our own wrapper here that supports empty filepaths. -uriToFilePath' :: LSP.Uri -> Maybe FilePath -uriToFilePath' uri - | uri == LSP.fromNormalizedUri emptyPathUri = Just "" - | otherwise = LSP.uriToFilePath uri - -emptyPathUri :: LSP.NormalizedUri -emptyPathUri = - let s = "file://" - in LSP.NormalizedUri (hash s) s - -filePathToUri' :: LSP.NormalizedFilePath -> LSP.NormalizedUri -filePathToUri' = LSP.normalizedFilePathToUri - -fromUri :: LSP.NormalizedUri -> LSP.NormalizedFilePath -fromUri = fromMaybe (toNormalizedFilePath' noFilePath) . LSP.uriToNormalizedFilePath - -noFilePath :: FilePath -noFilePath = "" - --- A dummy range to use when range is unknown -noRange :: Range -noRange = Range (Position 0 0) (Position 1 0) - -showPosition :: Position -> String -showPosition Position{..} = show (_line + 1) ++ ":" ++ show (_character + 1) - --- | Parser for the GHC output format -readSrcSpan :: ReadS RealSrcSpan -readSrcSpan = readP_to_S (singleLineSrcSpanP <|> multiLineSrcSpanP) - where - singleLineSrcSpanP, multiLineSrcSpanP :: ReadP RealSrcSpan - singleLineSrcSpanP = do - fp <- filePathP - l <- readS_to_P reads <* char ':' - c0 <- readS_to_P reads - c1 <- (char '-' *> readS_to_P reads) <|> pure c0 - let from = mkRealSrcLoc fp l c0 - to = mkRealSrcLoc fp l c1 - return $ mkRealSrcSpan from to - - multiLineSrcSpanP = do - fp <- filePathP - s <- parensP (srcLocP fp) - void $ char '-' - e <- parensP (srcLocP fp) - return $ mkRealSrcSpan s e - - parensP :: ReadP a -> ReadP a - parensP = between (char '(') (char ')') - - filePathP :: ReadP FastString - filePathP = fromString <$> (readFilePath <* char ':') <|> pure "" - - srcLocP :: FastString -> ReadP RealSrcLoc - srcLocP fp = do - l <- readS_to_P reads - void $ char ',' - c <- readS_to_P reads - return $ mkRealSrcLoc fp l c - - readFilePath :: ReadP FilePath - readFilePath = some ReadP.get +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + + +-- | Types and functions for working with source code locations. +module Development.IDE.Types.Location + ( Location(..) + , noFilePath + , noRange + , Position(..) + , showPosition + , Range(..) + , LSP.Uri(..) + , LSP.NormalizedUri + , LSP.toNormalizedUri + , LSP.fromNormalizedUri + , LSP.NormalizedFilePath + , fromUri + , emptyFilePath + , emptyPathUri + , toNormalizedFilePath' + , LSP.fromNormalizedFilePath + , filePathToUri' + , uriToFilePath' + , readSrcSpan + ) where + +import Control.Applicative +import Control.Monad +import Data.Hashable (Hashable (hash)) +import Data.Maybe (fromMaybe) +import Data.String +import FastString +import Language.LSP.Types (Location (..), Position (..), + Range (..)) +import qualified Language.LSP.Types as LSP +import SrcLoc as GHC +import Text.ParserCombinators.ReadP as ReadP + +toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath +-- We want to keep empty paths instead of normalising them to "." +toNormalizedFilePath' "" = emptyFilePath +toNormalizedFilePath' fp = LSP.toNormalizedFilePath fp + +emptyFilePath :: LSP.NormalizedFilePath +emptyFilePath = LSP.NormalizedFilePath emptyPathUri "" + +-- | We use an empty string as a filepath when we don’t have a file. +-- However, haskell-lsp doesn’t support that in uriToFilePath and given +-- that it is not a valid filepath it does not make sense to upstream a fix. +-- So we have our own wrapper here that supports empty filepaths. +uriToFilePath' :: LSP.Uri -> Maybe FilePath +uriToFilePath' uri + | uri == LSP.fromNormalizedUri emptyPathUri = Just "" + | otherwise = LSP.uriToFilePath uri + +emptyPathUri :: LSP.NormalizedUri +emptyPathUri = + let s = "file://" + in LSP.NormalizedUri (hash s) s + +filePathToUri' :: LSP.NormalizedFilePath -> LSP.NormalizedUri +filePathToUri' = LSP.normalizedFilePathToUri + +fromUri :: LSP.NormalizedUri -> LSP.NormalizedFilePath +fromUri = fromMaybe (toNormalizedFilePath' noFilePath) . LSP.uriToNormalizedFilePath + +noFilePath :: FilePath +noFilePath = "" + +-- A dummy range to use when range is unknown +noRange :: Range +noRange = Range (Position 0 0) (Position 1 0) + +showPosition :: Position -> String +showPosition Position{..} = show (_line + 1) ++ ":" ++ show (_character + 1) + +-- | Parser for the GHC output format +readSrcSpan :: ReadS RealSrcSpan +readSrcSpan = readP_to_S (singleLineSrcSpanP <|> multiLineSrcSpanP) + where + singleLineSrcSpanP, multiLineSrcSpanP :: ReadP RealSrcSpan + singleLineSrcSpanP = do + fp <- filePathP + l <- readS_to_P reads <* char ':' + c0 <- readS_to_P reads + c1 <- (char '-' *> readS_to_P reads) <|> pure c0 + let from = mkRealSrcLoc fp l c0 + to = mkRealSrcLoc fp l c1 + return $ mkRealSrcSpan from to + + multiLineSrcSpanP = do + fp <- filePathP + s <- parensP (srcLocP fp) + void $ char '-' + e <- parensP (srcLocP fp) + return $ mkRealSrcSpan s e + + parensP :: ReadP a -> ReadP a + parensP = between (char '(') (char ')') + + filePathP :: ReadP FastString + filePathP = fromString <$> (readFilePath <* char ':') <|> pure "" + + srcLocP :: FastString -> ReadP RealSrcLoc + srcLocP fp = do + l <- readS_to_P reads + void $ char ',' + c <- readS_to_P reads + return $ mkRealSrcLoc fp l c + + readFilePath :: ReadP FilePath + readFilePath = some ReadP.get diff --git a/src/Development/IDE/Types/Logger.hs b/src/Development/IDE/Types/Logger.hs --- a/src/Development/IDE/Types/Logger.hs +++ b/src/Development/IDE/Types/Logger.hs @@ -1,54 +1,54 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE RankNTypes #-} --- | This is a compatibility module that abstracts over the --- concrete choice of logging framework so users can plug in whatever --- framework they want to. -module Development.IDE.Types.Logger - ( Priority(..) - , Logger(..) - , logError, logWarning, logInfo, logDebug, logTelemetry - , noLogging - ) where - -import qualified Data.Text as T - - -data Priority --- Don't change the ordering of this type or you will mess up the Ord --- instance - = Telemetry -- ^ Events that are useful for gathering user metrics. - | Debug -- ^ Verbose debug logging. - | Info -- ^ Useful information in case an error has to be understood. - | Warning - -- ^ These error messages should not occur in a expected usage, and - -- should be investigated. - | Error -- ^ Such log messages must never occur in expected usage. - deriving (Eq, Show, Ord, Enum, Bounded) - - --- | Note that this is logging actions _of the program_, not of the user. --- You shouldn't call warning/error if the user has caused an error, only --- if our code has gone wrong and is itself erroneous (e.g. we threw an exception). -data Logger = Logger {logPriority :: Priority -> T.Text -> IO ()} - - -logError :: Logger -> T.Text -> IO () -logError x = logPriority x Error - -logWarning :: Logger -> T.Text -> IO () -logWarning x = logPriority x Warning - -logInfo :: Logger -> T.Text -> IO () -logInfo x = logPriority x Info - -logDebug :: Logger -> T.Text -> IO () -logDebug x = logPriority x Debug - -logTelemetry :: Logger -> T.Text -> IO () -logTelemetry x = logPriority x Telemetry - - -noLogging :: Logger -noLogging = Logger $ \_ _ -> return () +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE RankNTypes #-} +-- | This is a compatibility module that abstracts over the +-- concrete choice of logging framework so users can plug in whatever +-- framework they want to. +module Development.IDE.Types.Logger + ( Priority(..) + , Logger(..) + , logError, logWarning, logInfo, logDebug, logTelemetry + , noLogging + ) where + +import qualified Data.Text as T + + +data Priority +-- Don't change the ordering of this type or you will mess up the Ord +-- instance + = Telemetry -- ^ Events that are useful for gathering user metrics. + | Debug -- ^ Verbose debug logging. + | Info -- ^ Useful information in case an error has to be understood. + | Warning + -- ^ These error messages should not occur in a expected usage, and + -- should be investigated. + | Error -- ^ Such log messages must never occur in expected usage. + deriving (Eq, Show, Ord, Enum, Bounded) + + +-- | Note that this is logging actions _of the program_, not of the user. +-- You shouldn't call warning/error if the user has caused an error, only +-- if our code has gone wrong and is itself erroneous (e.g. we threw an exception). +data Logger = Logger {logPriority :: Priority -> T.Text -> IO ()} + + +logError :: Logger -> T.Text -> IO () +logError x = logPriority x Error + +logWarning :: Logger -> T.Text -> IO () +logWarning x = logPriority x Warning + +logInfo :: Logger -> T.Text -> IO () +logInfo x = logPriority x Info + +logDebug :: Logger -> T.Text -> IO () +logDebug x = logPriority x Debug + +logTelemetry :: Logger -> T.Text -> IO () +logTelemetry x = logPriority x Telemetry + + +noLogging :: Logger +noLogging = Logger $ \_ _ -> return () diff --git a/src/Development/IDE/Types/Options.hs b/src/Development/IDE/Types/Options.hs --- a/src/Development/IDE/Types/Options.hs +++ b/src/Development/IDE/Types/Options.hs @@ -1,175 +1,182 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - --- | Options -module Development.IDE.Types.Options - ( IdeOptions(..) - , IdePreprocessedSource(..) - , IdeReportProgress(..) - , IdeDefer(..) - , IdeTesting(..) - , IdeOTMemoryProfiling(..) - , clientSupportsProgress - , IdePkgLocationOptions(..) - , defaultIdeOptions - , IdeResult - , IdeGhcSession(..) - , OptHaddockParse(..) - ,optShakeFiles) where - -import Development.Shake -import Development.IDE.Types.HscEnvEq (HscEnvEq) -import GHC hiding (parseModule, typecheckModule) -import GhcPlugins as GHC hiding (fst3, (<>)) -import qualified Language.LSP.Types.Capabilities as LSP -import qualified Data.Text as T -import Development.IDE.Types.Diagnostics -import Control.DeepSeq (NFData(..)) -import Ide.Plugin.Config - -data IdeGhcSession = IdeGhcSession - { loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) - -- ^ Returns the Ghc session and the cradle dependencies - , sessionVersion :: !Int - -- ^ Used as Shake key, versions must be unique and not reused - } - -instance Show IdeGhcSession where show _ = "IdeGhcSession" -instance NFData IdeGhcSession where rnf !_ = () - -data IdeOptions = IdeOptions - { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource - -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings - -- and a list of errors, along with a new parse tree. - , optGhcSession :: Action IdeGhcSession - -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@. - -- For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file. - -- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work. - , optPkgLocationOpts :: IdePkgLocationOptions - -- ^ How to locate source and @.hie@ files given a module name. - , optExtensions :: [String] - -- ^ File extensions to search for code, defaults to Haskell sources (including @.hs@) - , optShakeProfiling :: Maybe FilePath - -- ^ Set to 'Just' to create a directory of profiling reports. - , optOTMemoryProfiling :: IdeOTMemoryProfiling - -- ^ Whether to record profiling information with OpenTelemetry. You must - -- also enable the -l RTS flag for this to have any effect - , optTesting :: IdeTesting - -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants - , optReportProgress :: IdeReportProgress - -- ^ Whether to report progress during long operations. - , optLanguageSyntax :: String - -- ^ the ```language to use - , optNewColonConvention :: Bool - -- ^ whether to use new colon convention - , optKeywords :: [T.Text] - -- ^ keywords used for completions. These are customizable - -- since DAML has a different set of keywords than Haskell. - , optDefer :: IdeDefer - -- ^ Whether to defer type errors, typed holes and out of scope - -- variables. Deferral allows the IDE to continue to provide - -- features such as diagnostics and go-to-definition, in - -- situations in which they would become unavailable because of - -- the presence of type errors, holes or unbound variables. - , optCheckProject :: IO Bool - -- ^ Whether to typecheck the entire project on load - , optCheckParents :: IO CheckParents - -- ^ When to typecheck reverse dependencies of a file - , optHaddockParse :: OptHaddockParse - -- ^ Whether to return result of parsing module with Opt_Haddock. - -- Otherwise, return the result of parsing without Opt_Haddock, so - -- that the parsed module contains the result of Opt_KeepRawTokenStream, - -- which might be necessary for hlint. - , optCustomDynFlags :: DynFlags -> DynFlags - -- ^ Will be called right after setting up a new cradle, - -- allowing to customize the Ghc options used - , optShakeOptions :: ShakeOptions - } - -optShakeFiles :: IdeOptions -> Maybe FilePath -optShakeFiles opts - | value == defValue = Nothing - | otherwise = Just value - where - value = shakeFiles (optShakeOptions opts) - defValue = shakeFiles (optShakeOptions $ defaultIdeOptions undefined) -data OptHaddockParse = HaddockParse | NoHaddockParse - deriving (Eq,Ord,Show,Enum) - -data IdePreprocessedSource = IdePreprocessedSource - { preprocWarnings :: [(GHC.SrcSpan, String)] - -- ^ Warnings emitted by the preprocessor. - , preprocErrors :: [(GHC.SrcSpan, String)] - -- ^ Errors emitted by the preprocessor. - , preprocSource :: GHC.ParsedSource - -- ^ New parse tree emitted by the preprocessor. - } - -newtype IdeReportProgress = IdeReportProgress Bool -newtype IdeDefer = IdeDefer Bool -newtype IdeTesting = IdeTesting Bool -newtype IdeOTMemoryProfiling = IdeOTMemoryProfiling Bool - -clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress -clientSupportsProgress caps = IdeReportProgress $ Just True == - (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities)) - -defaultIdeOptions :: Action IdeGhcSession -> IdeOptions -defaultIdeOptions session = IdeOptions - {optPreprocessor = IdePreprocessedSource [] [] - ,optGhcSession = session - ,optExtensions = ["hs", "lhs"] - ,optPkgLocationOpts = defaultIdePkgLocationOptions - ,optShakeOptions = shakeOptions - {shakeThreads = 0 - ,shakeFiles = "/dev/null" - } - ,optShakeProfiling = Nothing - ,optOTMemoryProfiling = IdeOTMemoryProfiling False - ,optReportProgress = IdeReportProgress False - ,optLanguageSyntax = "haskell" - ,optNewColonConvention = False - ,optKeywords = haskellKeywords - ,optDefer = IdeDefer True - ,optTesting = IdeTesting False - ,optCheckProject = pure True - ,optCheckParents = pure CheckOnSaveAndClose - ,optHaddockParse = HaddockParse - ,optCustomDynFlags = id - } - - --- | The set of options used to locate files belonging to external packages. -data IdePkgLocationOptions = IdePkgLocationOptions - { optLocateHieFile :: PackageConfig -> Module -> IO (Maybe FilePath) - -- ^ Locate the HIE file for the given module. The PackageConfig can be - -- used to lookup settings like importDirs. - , optLocateSrcFile :: PackageConfig -> Module -> IO (Maybe FilePath) - -- ^ Locate the source file for the given module. The PackageConfig can be - -- used to lookup settings like importDirs. For DAML, we place them in the package DB. - -- For cabal this could point somewhere in ~/.cabal/packages. - } - -defaultIdePkgLocationOptions :: IdePkgLocationOptions -defaultIdePkgLocationOptions = IdePkgLocationOptions f f - where f _ _ = return Nothing - --- | From https://wiki.haskell.org/Keywords -haskellKeywords :: [T.Text] -haskellKeywords = - [ "as" - , "case", "of" - , "class", "instance", "type" - , "data", "family", "newtype" - , "default" - , "deriving" - , "do", "mdo", "proc", "rec" - , "forall" - , "foreign" - , "hiding" - , "if", "then", "else" - , "import", "qualified", "hiding" - , "infix", "infixl", "infixr" - , "let", "in", "where" - , "module" - ] +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +-- | Options +{-# LANGUAGE RankNTypes #-} +module Development.IDE.Types.Options + ( IdeOptions(..) + , IdePreprocessedSource(..) + , IdeReportProgress(..) + , IdeDefer(..) + , IdeTesting(..) + , IdeOTMemoryProfiling(..) + , clientSupportsProgress + , IdePkgLocationOptions(..) + , defaultIdeOptions + , IdeResult + , IdeGhcSession(..) + , OptHaddockParse(..) + ,optShakeFiles) where + +import qualified Data.Text as T +import Data.Typeable +import Development.IDE.Core.RuleTypes +import Development.IDE.Types.Diagnostics +import Development.Shake +import GHC hiding (parseModule, + typecheckModule) +import GhcPlugins as GHC hiding (fst3, (<>)) +import Ide.Plugin.Config +import qualified Language.LSP.Types.Capabilities as LSP + +data IdeOptions = IdeOptions + { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource + -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings + -- and a list of errors, along with a new parse tree. + , optGhcSession :: Action IdeGhcSession + -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@. + -- For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file. + -- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work. + , optPkgLocationOpts :: IdePkgLocationOptions + -- ^ How to locate source and @.hie@ files given a module name. + , optExtensions :: [String] + -- ^ File extensions to search for code, defaults to Haskell sources (including @.hs@) + , optShakeProfiling :: Maybe FilePath + -- ^ Set to 'Just' to create a directory of profiling reports. + , optOTMemoryProfiling :: IdeOTMemoryProfiling + -- ^ Whether to record profiling information with OpenTelemetry. You must + -- also enable the -l RTS flag for this to have any effect + , optTesting :: IdeTesting + -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants + , optReportProgress :: IdeReportProgress + -- ^ Whether to report progress during long operations. + , optLanguageSyntax :: String + -- ^ the ```language to use + , optNewColonConvention :: Bool + -- ^ whether to use new colon convention + , optKeywords :: [T.Text] + -- ^ keywords used for completions. These are customizable + -- since DAML has a different set of keywords than Haskell. + , optDefer :: IdeDefer + -- ^ Whether to defer type errors, typed holes and out of scope + -- variables. Deferral allows the IDE to continue to provide + -- features such as diagnostics and go-to-definition, in + -- situations in which they would become unavailable because of + -- the presence of type errors, holes or unbound variables. + , optCheckProject :: IO Bool + -- ^ Whether to typecheck the entire project on load + , optCheckParents :: IO CheckParents + -- ^ When to typecheck reverse dependencies of a file + , optHaddockParse :: OptHaddockParse + -- ^ Whether to return result of parsing module with Opt_Haddock. + -- Otherwise, return the result of parsing without Opt_Haddock, so + -- that the parsed module contains the result of Opt_KeepRawTokenStream, + -- which might be necessary for hlint. + , optCustomDynFlags :: DynFlags -> DynFlags + -- ^ Will be called right after setting up a new cradle, + -- allowing to customize the Ghc options used + , optShakeOptions :: ShakeOptions + , optSkipProgress :: forall a. Typeable a => a -> Bool + -- ^ Predicate to select which rule keys to exclude from progress reporting. + } + +optShakeFiles :: IdeOptions -> Maybe FilePath +optShakeFiles opts + | value == defValue = Nothing + | otherwise = Just value + where + value = shakeFiles (optShakeOptions opts) + defValue = shakeFiles (optShakeOptions $ defaultIdeOptions undefined) +data OptHaddockParse = HaddockParse | NoHaddockParse + deriving (Eq,Ord,Show,Enum) + +data IdePreprocessedSource = IdePreprocessedSource + { preprocWarnings :: [(GHC.SrcSpan, String)] + -- ^ Warnings emitted by the preprocessor. + , preprocErrors :: [(GHC.SrcSpan, String)] + -- ^ Errors emitted by the preprocessor. + , preprocSource :: GHC.ParsedSource + -- ^ New parse tree emitted by the preprocessor. + } + +newtype IdeReportProgress = IdeReportProgress Bool +newtype IdeDefer = IdeDefer Bool +newtype IdeTesting = IdeTesting Bool +newtype IdeOTMemoryProfiling = IdeOTMemoryProfiling Bool + +clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress +clientSupportsProgress caps = IdeReportProgress $ Just True == + (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities)) + +defaultIdeOptions :: Action IdeGhcSession -> IdeOptions +defaultIdeOptions session = IdeOptions + {optPreprocessor = IdePreprocessedSource [] [] + ,optGhcSession = session + ,optExtensions = ["hs", "lhs"] + ,optPkgLocationOpts = defaultIdePkgLocationOptions + ,optShakeOptions = shakeOptions + {shakeThreads = 0 + ,shakeFiles = "/dev/null" + } + ,optShakeProfiling = Nothing + ,optOTMemoryProfiling = IdeOTMemoryProfiling False + ,optReportProgress = IdeReportProgress False + ,optLanguageSyntax = "haskell" + ,optNewColonConvention = False + ,optKeywords = haskellKeywords + ,optDefer = IdeDefer True + ,optTesting = IdeTesting False + ,optCheckProject = pure True + ,optCheckParents = pure CheckOnSaveAndClose + ,optHaddockParse = HaddockParse + ,optCustomDynFlags = id + ,optSkipProgress = defaultSkipProgress + } + +defaultSkipProgress :: Typeable a => a -> Bool +defaultSkipProgress key = case () of + -- don't do progress for GetFileContents as it's cheap + _ | Just GetFileContents <- cast key -> True + -- don't do progress for GetFileExists, as there are lots of redundant nodes + -- (normally there is one node per file, but this is not the case for GetFileExists) + _ | Just GetFileExists <- cast key -> True + -- don't do progress for GetModificationTime as there are lot of redundant nodes + -- (for the interface files) + _ | Just GetModificationTime_{} <- cast key -> True + _ -> False + + +-- | The set of options used to locate files belonging to external packages. +data IdePkgLocationOptions = IdePkgLocationOptions + { optLocateHieFile :: PackageConfig -> Module -> IO (Maybe FilePath) + -- ^ Locate the HIE file for the given module. The PackageConfig can be + -- used to lookup settings like importDirs. + , optLocateSrcFile :: PackageConfig -> Module -> IO (Maybe FilePath) + -- ^ Locate the source file for the given module. The PackageConfig can be + -- used to lookup settings like importDirs. For DAML, we place them in the package DB. + -- For cabal this could point somewhere in ~/.cabal/packages. + } + +defaultIdePkgLocationOptions :: IdePkgLocationOptions +defaultIdePkgLocationOptions = IdePkgLocationOptions f f + where f _ _ = return Nothing + +-- | From https://wiki.haskell.org/Keywords +haskellKeywords :: [T.Text] +haskellKeywords = + [ "as" + , "case", "of" + , "class", "instance", "type" + , "data", "family", "newtype" + , "default" + , "deriving" + , "do", "mdo", "proc", "rec" + , "forall" + , "foreign" + , "hiding" + , "if", "then", "else" + , "import", "qualified", "hiding" + , "infix", "infixl", "infixr" + , "let", "in", "where" + , "module" + ] diff --git a/src/Development/IDE/Types/Shake.hs b/src/Development/IDE/Types/Shake.hs --- a/src/Development/IDE/Types/Shake.hs +++ b/src/Development/IDE/Types/Shake.hs @@ -1,133 +1,134 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ExistentialQuantification #-} -module Development.IDE.Types.Shake - ( Q (..), - A (..), - Value (..), - ValueWithDiagnostics (..), - Values, - Key (..), - BadDependency (..), - ShakeValue(..), - currentValue, - isBadDependency, - toShakeValue,encodeShakeValue,decodeShakeValue) -where - -import Control.DeepSeq -import Control.Exception -import qualified Data.ByteString.Char8 as BS -import Data.Dynamic -import Data.Hashable -import Data.HashMap.Strict -import Data.Vector (Vector) -import Data.Typeable -import Development.IDE.Types.Diagnostics -import Development.IDE.Types.Location -import Development.Shake (RuleResult, ShakeException (shakeExceptionInner)) -import Development.Shake.Classes -import GHC.Generics -import Language.LSP.Types -import Development.IDE.Core.PositionMapping - -data Value v - = Succeeded TextDocumentVersion v - | Stale (Maybe PositionDelta) TextDocumentVersion v - | Failed Bool -- True if we already tried the persistent rule - deriving (Functor, Generic, Show) - -instance NFData v => NFData (Value v) - --- | Convert a Value to a Maybe. This will only return `Just` for --- up2date results not for stale values. -currentValue :: Value v -> Maybe v -currentValue (Succeeded _ v) = Just v -currentValue (Stale _ _ _) = Nothing -currentValue Failed{} = Nothing - -data ValueWithDiagnostics - = ValueWithDiagnostics !(Value Dynamic) !(Vector FileDiagnostic) - --- | The state of the all values and diagnostics -type Values = HashMap (NormalizedFilePath, Key) ValueWithDiagnostics - --- | Key type -data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k - -instance Show Key where - show (Key k) = show k - -instance Eq Key where - Key k1 == Key k2 | Just k2' <- cast k2 = k1 == k2' - | otherwise = False - -instance Hashable Key where - hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key) - --- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency --- which short-circuits the rest of the action -newtype BadDependency = BadDependency String deriving Show -instance Exception BadDependency - -isBadDependency :: SomeException -> Bool -isBadDependency x - | Just (x :: ShakeException) <- fromException x = isBadDependency $ shakeExceptionInner x - | Just (_ :: BadDependency) <- fromException x = True - | otherwise = False - -newtype Q k = Q (k, NormalizedFilePath) - deriving newtype (Eq, Hashable, NFData) - -instance Binary k => Binary (Q k) where - put (Q (k, fp)) = put (k, fp) - get = do - (k, fp) <- get - -- The `get` implementation of NormalizedFilePath - -- does not handle empty file paths so we - -- need to handle this ourselves here. - pure (Q (k, toNormalizedFilePath' fp)) - -instance Show k => Show (Q k) where - show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file - --- | Invariant: the 'v' must be in normal form (fully evaluated). --- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database -newtype A v = A (Value v) - deriving Show - -instance NFData (A v) where rnf (A v) = v `seq` () - --- In the Shake database we only store one type of key/result pairs, --- namely Q (question) / A (answer). -type instance RuleResult (Q k) = A (RuleResult k) - - -toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue -toShakeValue = maybe ShakeNoCutoff - -data ShakeValue - = -- | This is what we use when we get Nothing from - -- a rule. - ShakeNoCutoff - | -- | This is used both for `Failed` - -- as well as `Succeeded`. - ShakeResult !BS.ByteString - | ShakeStale !BS.ByteString - deriving (Generic, Show) - -instance NFData ShakeValue - -encodeShakeValue :: ShakeValue -> BS.ByteString -encodeShakeValue = \case - ShakeNoCutoff -> BS.empty - ShakeResult r -> BS.cons 'r' r - ShakeStale r -> BS.cons 's' r - -decodeShakeValue :: BS.ByteString -> ShakeValue -decodeShakeValue bs = case BS.uncons bs of - Nothing -> ShakeNoCutoff - Just (x, xs) - | x == 'r' -> ShakeResult xs - | x == 's' -> ShakeStale xs - | otherwise -> error $ "Failed to parse shake value " <> show bs +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TypeFamilies #-} +module Development.IDE.Types.Shake + ( Q (..), + A (..), + Value (..), + ValueWithDiagnostics (..), + Values, + Key (..), + BadDependency (..), + ShakeValue(..), + currentValue, + isBadDependency, + toShakeValue,encodeShakeValue,decodeShakeValue) +where + +import Control.DeepSeq +import Control.Exception +import qualified Data.ByteString.Char8 as BS +import Data.Dynamic +import Data.HashMap.Strict +import Data.Hashable +import Data.Typeable +import Data.Vector (Vector) +import Development.IDE.Core.PositionMapping +import Development.IDE.Types.Diagnostics +import Development.IDE.Types.Location +import Development.Shake (RuleResult, + ShakeException (shakeExceptionInner)) +import Development.Shake.Classes +import GHC.Generics +import Language.LSP.Types + +data Value v + = Succeeded TextDocumentVersion v + | Stale (Maybe PositionDelta) TextDocumentVersion v + | Failed Bool -- True if we already tried the persistent rule + deriving (Functor, Generic, Show) + +instance NFData v => NFData (Value v) + +-- | Convert a Value to a Maybe. This will only return `Just` for +-- up2date results not for stale values. +currentValue :: Value v -> Maybe v +currentValue (Succeeded _ v) = Just v +currentValue (Stale _ _ _) = Nothing +currentValue Failed{} = Nothing + +data ValueWithDiagnostics + = ValueWithDiagnostics !(Value Dynamic) !(Vector FileDiagnostic) + +-- | The state of the all values and diagnostics +type Values = HashMap (NormalizedFilePath, Key) ValueWithDiagnostics + +-- | Key type +data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k + +instance Show Key where + show (Key k) = show k + +instance Eq Key where + Key k1 == Key k2 | Just k2' <- cast k2 = k1 == k2' + | otherwise = False + +instance Hashable Key where + hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key) + +-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency +-- which short-circuits the rest of the action +newtype BadDependency = BadDependency String deriving Show +instance Exception BadDependency + +isBadDependency :: SomeException -> Bool +isBadDependency x + | Just (x :: ShakeException) <- fromException x = isBadDependency $ shakeExceptionInner x + | Just (_ :: BadDependency) <- fromException x = True + | otherwise = False + +newtype Q k = Q (k, NormalizedFilePath) + deriving newtype (Eq, Hashable, NFData) + +instance Binary k => Binary (Q k) where + put (Q (k, fp)) = put (k, fp) + get = do + (k, fp) <- get + -- The `get` implementation of NormalizedFilePath + -- does not handle empty file paths so we + -- need to handle this ourselves here. + pure (Q (k, toNormalizedFilePath' fp)) + +instance Show k => Show (Q k) where + show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file + +-- | Invariant: the 'v' must be in normal form (fully evaluated). +-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database +newtype A v = A (Value v) + deriving Show + +instance NFData (A v) where rnf (A v) = v `seq` () + +-- In the Shake database we only store one type of key/result pairs, +-- namely Q (question) / A (answer). +type instance RuleResult (Q k) = A (RuleResult k) + + +toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue +toShakeValue = maybe ShakeNoCutoff + +data ShakeValue + = -- | This is what we use when we get Nothing from + -- a rule. + ShakeNoCutoff + | -- | This is used both for `Failed` + -- as well as `Succeeded`. + ShakeResult !BS.ByteString + | ShakeStale !BS.ByteString + deriving (Generic, Show) + +instance NFData ShakeValue + +encodeShakeValue :: ShakeValue -> BS.ByteString +encodeShakeValue = \case + ShakeNoCutoff -> BS.empty + ShakeResult r -> BS.cons 'r' r + ShakeStale r -> BS.cons 's' r + +decodeShakeValue :: BS.ByteString -> ShakeValue +decodeShakeValue bs = case BS.uncons bs of + Nothing -> ShakeNoCutoff + Just (x, xs) + | x == 'r' -> ShakeResult xs + | x == 's' -> ShakeStale xs + | otherwise -> error $ "Failed to parse shake value " <> show bs diff --git a/test/cabal/Development/IDE/Test/Runfiles.hs b/test/cabal/Development/IDE/Test/Runfiles.hs --- a/test/cabal/Development/IDE/Test/Runfiles.hs +++ b/test/cabal/Development/IDE/Test/Runfiles.hs @@ -1,9 +1,9 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -module Development.IDE.Test.Runfiles - ( locateGhcideExecutable - ) where - -locateGhcideExecutable :: IO FilePath -locateGhcideExecutable = pure "ghcide" +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Development.IDE.Test.Runfiles + ( locateGhcideExecutable + ) where + +locateGhcideExecutable :: IO FilePath +locateGhcideExecutable = pure "ghcide" diff --git a/test/data/hover/Bar.hs b/test/data/hover/Bar.hs --- a/test/data/hover/Bar.hs +++ b/test/data/hover/Bar.hs @@ -1,4 +1,4 @@ -module Bar (Bar(..)) where - --- | Bar Haddock -data Bar = Bar +module Bar (Bar(..)) where + +-- | Bar Haddock +data Bar = Bar diff --git a/test/data/hover/Foo.hs b/test/data/hover/Foo.hs --- a/test/data/hover/Foo.hs +++ b/test/data/hover/Foo.hs @@ -1,6 +1,6 @@ -module Foo (Bar, foo) where - -import Bar - --- | foo Haddock -foo = Bar +module Foo (Bar, foo) where + +import Bar + +-- | foo Haddock +foo = Bar diff --git a/test/data/hover/GotoHover.hs b/test/data/hover/GotoHover.hs --- a/test/data/hover/GotoHover.hs +++ b/test/data/hover/GotoHover.hs @@ -1,63 +1,63 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} -{- HLINT ignore -} -module GotoHover ( module GotoHover) where -import Data.Text (Text, pack) -import Foo (Bar, foo) - - -data TypeConstructor = DataConstructor - { fff :: Text - , ggg :: Int } -aaa :: TypeConstructor -aaa = DataConstructor - { fff = "dfgy" - , ggg = 832 - } -bbb :: TypeConstructor -bbb = DataConstructor "mjgp" 2994 -ccc :: (Text, Int) -ccc = (fff bbb, ggg aaa) -ddd :: Num a => a -> a -> a -ddd vv ww = vv +! ww -a +! b = a - b -hhh (Just a) (><) = a >< a -iii a b = a `b` a -jjj s = pack $ s <> s -class MyClass a where - method :: a -> Int -instance MyClass Int where - method = succ -kkk :: MyClass a => Int -> a -> Int -kkk n c = n + method c - -doBind :: Maybe () -doBind = do unwrapped <- Just () - return unwrapped - -listCompBind :: [Char] -listCompBind = [ succ c | c <- "ptfx" ] - -multipleClause :: Bool -> Char -multipleClause True = 't' -multipleClause False = 'f' - --- | Recognizable docs: kpqz -documented :: Monad m => Either Int (m a) -documented = Left 7518 - -listOfInt = [ 8391 :: Int, 6268 ] - -outer :: Bool -outer = undefined inner where - - inner :: Char - inner = undefined - -imported :: Bar -imported = foo - -aa2 :: Bool -aa2 = $(id [| True |]) - -hole :: Int -hole = _ +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} +{- HLINT ignore -} +module GotoHover ( module GotoHover) where +import Data.Text (Text, pack) +import Foo (Bar, foo) + + +data TypeConstructor = DataConstructor + { fff :: Text + , ggg :: Int } +aaa :: TypeConstructor +aaa = DataConstructor + { fff = "dfgy" + , ggg = 832 + } +bbb :: TypeConstructor +bbb = DataConstructor "mjgp" 2994 +ccc :: (Text, Int) +ccc = (fff bbb, ggg aaa) +ddd :: Num a => a -> a -> a +ddd vv ww = vv +! ww +a +! b = a - b +hhh (Just a) (><) = a >< a +iii a b = a `b` a +jjj s = pack $ s <> s +class MyClass a where + method :: a -> Int +instance MyClass Int where + method = succ +kkk :: MyClass a => Int -> a -> Int +kkk n c = n + method c + +doBind :: Maybe () +doBind = do unwrapped <- Just () + return unwrapped + +listCompBind :: [Char] +listCompBind = [ succ c | c <- "ptfx" ] + +multipleClause :: Bool -> Char +multipleClause True = 't' +multipleClause False = 'f' + +-- | Recognizable docs: kpqz +documented :: Monad m => Either Int (m a) +documented = Left 7518 + +listOfInt = [ 8391 :: Int, 6268 ] + +outer :: Bool +outer = undefined inner where + + inner :: Char + inner = undefined + +imported :: Bar +imported = foo + +aa2 :: Bool +aa2 = $(id [| True |]) + +hole :: Int +hole = _ diff --git a/test/data/multi/a/A.hs b/test/data/multi/a/A.hs --- a/test/data/multi/a/A.hs +++ b/test/data/multi/a/A.hs @@ -1,3 +1,3 @@ -module A(foo) where - -foo = () +module A(foo) where + +foo = () diff --git a/test/data/multi/a/a.cabal b/test/data/multi/a/a.cabal --- a/test/data/multi/a/a.cabal +++ b/test/data/multi/a/a.cabal @@ -1,9 +1,9 @@ -name: a -version: 1.0.0 -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: base - exposed-modules: A - hs-source-dirs: . +name: a +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base + exposed-modules: A + hs-source-dirs: . diff --git a/test/data/multi/b/B.hs b/test/data/multi/b/B.hs --- a/test/data/multi/b/B.hs +++ b/test/data/multi/b/B.hs @@ -1,3 +1,3 @@ -module B(module B) where -import A -qux = foo +module B(module B) where +import A +qux = foo diff --git a/test/data/multi/b/b.cabal b/test/data/multi/b/b.cabal --- a/test/data/multi/b/b.cabal +++ b/test/data/multi/b/b.cabal @@ -1,9 +1,9 @@ -name: b -version: 1.0.0 -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: base, a - exposed-modules: B - hs-source-dirs: . +name: b +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base, a + exposed-modules: B + hs-source-dirs: . diff --git a/test/data/multi/cabal.project b/test/data/multi/cabal.project --- a/test/data/multi/cabal.project +++ b/test/data/multi/cabal.project @@ -1,1 +1,1 @@ -packages: a b +packages: a b diff --git a/test/data/multi/hie.yaml b/test/data/multi/hie.yaml --- a/test/data/multi/hie.yaml +++ b/test/data/multi/hie.yaml @@ -1,6 +1,6 @@ -cradle: - cabal: - - path: "./a" - component: "lib:a" - - path: "./b" - component: "lib:b" +cradle: + cabal: + - path: "./a" + component: "lib:a" + - path: "./b" + component: "lib:b" diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -1,5298 +1,5440 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} -#include "ghc-api-version.h" - -module Main (main) where - -import Control.Applicative.Combinators -import Control.Exception (bracket_, catch) -import qualified Control.Lens as Lens -import Control.Monad -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson (toJSON,fromJSON) -import qualified Data.Aeson as A -import qualified Data.Binary as Binary -import Data.Default -import Data.Foldable -import Data.List.Extra -import Data.Maybe -import Data.Rope.UTF16 (Rope) -import qualified Data.Rope.UTF16 as Rope -import qualified Data.Set as Set -import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent, PositionResult(..), positionResultToMaybe) -import Development.IDE.Core.Shake (Q(..)) -import Development.IDE.GHC.Util -import qualified Data.Text as T -import Development.IDE.Plugin.Completions.Types (extendImportCommandId) -import Development.IDE.Plugin.TypeLenses (typeLensCommandId) -import Development.IDE.Spans.Common -import Development.IDE.Test - ( canonicalizeUri, - diagnostic, - expectCurrentDiagnostics, - expectDiagnostics, - expectDiagnosticsWithTags, - expectNoMoreDiagnostics, - flushMessages, - standardizeQuotes, - waitForAction, - Cursor, expectMessages ) -import Development.IDE.Test.Runfiles -import qualified Development.IDE.Types.Diagnostics as Diagnostics -import Development.IDE.Types.Location -import Development.Shake (getDirectoryFilesIO) -import Ide.Plugin.Config -import qualified Experiments as Bench -import Language.LSP.Test -import Language.LSP.Types hiding (mkRange) -import Language.LSP.Types.Capabilities -import qualified Language.LSP.Types.Lens as Lsp (diagnostics, params, message) -import Language.LSP.VFS (applyChange) -import Network.URI -import System.Environment.Blank (unsetEnv, getEnv, setEnv) -import System.FilePath -import System.IO.Extra hiding (withTempDir) -import qualified System.IO.Extra -import System.Directory -import System.Exit (ExitCode(ExitSuccess)) -import System.Process.Extra (readCreateProcessWithExitCode, CreateProcess(cwd), proc) -import System.Info.Extra (isWindows) -import Test.QuickCheck --- import Test.QuickCheck.Instances () -import Test.Tasty -import Test.Tasty.ExpectedFailure -import Test.Tasty.Ingredients.Rerun -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck -import System.Time.Extra -import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports) -import Development.IDE.Plugin.Test (TestRequest (BlockSeconds, GetInterfaceFilesDir), WaitForIdeRuleResult (..), blockCommandId) -import Control.Monad.Extra (whenJust) -import qualified Language.LSP.Types.Lens as L -import Control.Lens ((^.)) -import Data.Tuple.Extra - -waitForProgressBegin :: Session () -waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (Begin _))) -> Just () - _ -> Nothing - -waitForProgressDone :: Session () -waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () - _ -> Nothing - -main :: IO () -main = do - -- We mess with env vars so run single-threaded. - defaultMainWithRerun $ testGroup "ghcide" - [ testSession "open close" $ do - doc <- createDoc "Testing.hs" "haskell" "" - void (skipManyTill anyMessage $ message SWindowWorkDoneProgressCreate) - waitForProgressBegin - closeDoc doc - waitForProgressDone - , initializeResponseTests - , completionTests - , cppTests - , diagnosticTests - , codeActionTests - , codeLensesTests - , outlineTests - , highlightTests - , findDefinitionAndHoverTests - , pluginSimpleTests - , pluginParsedResultTests - , preprocessorTests - , thTests - , safeTests - , unitTests - , haddockTests - , positionMappingTests - , watchedFilesTests - , cradleTests - , dependentFileTest - , nonLspCommandLine - , benchmarkTests - , ifaceTests - , bootTests - , rootUriTests - , asyncTests - , clientSettingsTest - , codeActionHelperFunctionTests - , referenceTests - ] - -initializeResponseTests :: TestTree -initializeResponseTests = withResource acquire release tests where - - -- these tests document and monitor the evolution of the - -- capabilities announced by the server in the initialize - -- response. Currently the server advertises almost no capabilities - -- at all, in some cases failing to announce capabilities that it - -- actually does provide! Hopefully this will change ... - tests :: IO (ResponseMessage Initialize) -> TestTree - tests getInitializeResponse = - testGroup "initialize response capabilities" - [ chk " text doc sync" _textDocumentSync tds - , chk " hover" _hoverProvider (Just $ InL True) - , chk " completion" _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just False)) - , chk "NO signature help" _signatureHelpProvider Nothing - , chk " goto definition" _definitionProvider (Just $ InL True) - , chk " goto type definition" _typeDefinitionProvider (Just $ InL True) - -- BUG in lsp-test, this test fails, just change the accepted response - -- for now - , chk "NO goto implementation" _implementationProvider (Just $ InL False) - , chk " find references" _referencesProvider (Just $ InL True) - , chk " doc highlight" _documentHighlightProvider (Just $ InL True) - , chk " doc symbol" _documentSymbolProvider (Just $ InL True) - , chk " workspace symbol" _workspaceSymbolProvider (Just True) - , chk " code action" _codeActionProvider (Just $ InL True) - , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just False)) - , chk "NO doc formatting" _documentFormattingProvider (Just $ InL False) - , chk "NO doc range formatting" - _documentRangeFormattingProvider (Just $ InL False) - , chk "NO doc formatting on typing" - _documentOnTypeFormattingProvider Nothing - , chk "NO renaming" _renameProvider (Just $ InL False) - , chk "NO doc link" _documentLinkProvider Nothing - , chk "NO color" _colorProvider (Just $ InL False) - , chk "NO folding range" _foldingRangeProvider (Just $ InL False) - , che " execute command" _executeCommandProvider [blockCommandId, extendImportCommandId, typeLensCommandId] - , chk " workspace" _workspace (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )})) - , chk "NO experimental" _experimental Nothing - ] where - - tds = Just (InL (TextDocumentSyncOptions - { _openClose = Just True - , _change = Just TdSyncIncremental - , _willSave = Nothing - , _willSaveWaitUntil = Nothing - , _save = Just (InR $ SaveOptions {_includeText = Nothing})})) - - chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree - chk title getActual expected = - testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir - - che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree - che title getActual expected = testCase title doTest - where - doTest = do - ir <- getInitializeResponse - let Just ExecuteCommandOptions {_commands = List commands} = getActual $ innerCaps ir - zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) expected commands - - innerCaps :: ResponseMessage Initialize -> ServerCapabilities - innerCaps (ResponseMessage _ _ (Right (InitializeResult c _))) = c - innerCaps (ResponseMessage _ _ (Left _)) = error "Initialization error" - - acquire :: IO (ResponseMessage Initialize) - acquire = run initializeResponse - - release :: ResponseMessage Initialize -> IO () - release = const $ pure () - - -diagnosticTests :: TestTree -diagnosticTests = testGroup "diagnostics" - [ testSessionWait "fix syntax error" $ do - let content = T.unlines [ "module Testing wher" ] - doc <- createDoc "Testing.hs" "haskell" content - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])] - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 15) (Position 0 19)) - , _rangeLength = Nothing - , _text = "where" - } - changeDoc doc [change] - expectDiagnostics [("Testing.hs", [])] - , testSessionWait "introduce syntax error" $ do - let content = T.unlines [ "module Testing where" ] - doc <- createDoc "Testing.hs" "haskell" content - void $ skipManyTill anyMessage (message SWindowWorkDoneProgressCreate) - waitForProgressBegin - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 15) (Position 0 18)) - , _rangeLength = Nothing - , _text = "wher" - } - changeDoc doc [change] - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])] - , testSessionWait "update syntax error" $ do - let content = T.unlines [ "module Testing(missing) where" ] - doc <- createDoc "Testing.hs" "haskell" content - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'missing'")])] - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 15) (Position 0 16)) - , _rangeLength = Nothing - , _text = "l" - } - changeDoc doc [change] - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'lissing'")])] - , testSessionWait "variable not in scope" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> Int -> Int" - , "foo a _b = a + ab" - , "bar :: Int -> Int -> Int" - , "bar _a b = cd + b" - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs" - , [ (DsError, (2, 15), "Variable not in scope: ab") - , (DsError, (4, 11), "Variable not in scope: cd") - ] - ) - ] - , testSessionWait "type error" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> String -> Int" - , "foo a b = a + b" - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs" - , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")] - ) - ] - , testSessionWait "typed hole" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> String" - , "foo a = _ a" - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs" - , [(DsError, (2, 8), "Found hole: _ :: Int -> String")] - ) - ] - - , testGroup "deferral" $ - let sourceA a = T.unlines - [ "module A where" - , "a :: Int" - , "a = " <> a] - sourceB = T.unlines - [ "module B where" - , "import A ()" - , "b :: Float" - , "b = True"] - bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'" - expectedDs aMessage = - [ ("A.hs", [(DsError, (2,4), aMessage)]) - , ("B.hs", [(DsError, (3,4), bMessage)])] - deferralTest title binding msg = testSessionWait title $ do - _ <- createDoc "A.hs" "haskell" $ sourceA binding - _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics $ expectedDs msg - in - [ deferralTest "type error" "True" "Couldn't match expected type" - , deferralTest "typed hole" "_" "Found hole" - , deferralTest "out of scope var" "unbound" "Variable not in scope" - ] - - , testSessionWait "remove required module" $ do - let contentA = T.unlines [ "module ModuleA where" ] - docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA" - ] - _ <- createDoc "ModuleB.hs" "haskell" contentB - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 0) (Position 0 20)) - , _rangeLength = Nothing - , _text = "" - } - changeDoc docA [change] - expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])] - , testSessionWait "add missing module" $ do - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA ()" - ] - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] - let contentA = T.unlines [ "module ModuleA where" ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - expectDiagnostics [("ModuleB.hs", [])] - , ignoreInWindowsBecause "Broken in windows" $ testSessionWait "add missing module (non workspace)" $ do - -- need to canonicalize in Mac Os - tmpDir <- liftIO $ canonicalizePath =<< getTemporaryDirectory - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA ()" - ] - _ <- createDoc (tmpDir "ModuleB.hs") "haskell" contentB - expectDiagnostics [(tmpDir "ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] - let contentA = T.unlines [ "module ModuleA where" ] - _ <- createDoc (tmpDir "ModuleA.hs") "haskell" contentA - expectDiagnostics [(tmpDir "ModuleB.hs", [])] - , testSessionWait "cyclic module dependency" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "import ModuleB" - ] - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics - [ ( "ModuleA.hs" - , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] - ) - , ( "ModuleB.hs" - , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] - ) - ] - , testSessionWait "cyclic module dependency with hs-boot" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "import {-# SOURCE #-} ModuleB" - ] - let contentB = T.unlines - [ "{-# OPTIONS -Wmissing-signatures#-}" - , "module ModuleB where" - , "import ModuleA" - -- introduce an artificial diagnostic - , "foo = ()" - ] - let contentBboot = T.unlines - [ "module ModuleB where" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot - expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])] - , testSessionWait "correct reference used with hs-boot" $ do - let contentB = T.unlines - [ "module ModuleB where" - , "import {-# SOURCE #-} ModuleA()" - ] - let contentA = T.unlines - [ "module ModuleA where" - , "import ModuleB()" - , "x = 5" - ] - let contentAboot = T.unlines - [ "module ModuleA where" - ] - let contentC = T.unlines - [ "{-# OPTIONS -Wmissing-signatures #-}" - , "module ModuleC where" - , "import ModuleA" - -- this reference will fail if it gets incorrectly - -- resolved to the hs-boot file - , "y = x" - ] - _ <- createDoc "ModuleB.hs" "haskell" contentB - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot - _ <- createDoc "ModuleC.hs" "haskell" contentC - expectDiagnostics [("ModuleC.hs", [(DsWarning, (3,0), "Top-level binding")])] - , testSessionWait "redundant import" $ do - let contentA = T.unlines ["module ModuleA where"] - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnosticsWithTags - [ ( "ModuleB.hs" - , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant", Just DtUnnecessary)] - ) - ] - , testSessionWait "redundant import even without warning" $ do - let contentA = T.unlines ["module ModuleA where"] - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wno-unused-imports -Wmissing-signatures #-}" - , "module ModuleB where" - , "import ModuleA" - -- introduce an artificial warning for testing purposes - , "foo = ()" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])] - , testSessionWait "package imports" $ do - let thisDataListContent = T.unlines - [ "module Data.List where" - , "x :: Integer" - , "x = 123" - ] - let mainContent = T.unlines - [ "{-# LANGUAGE PackageImports #-}" - , "module Main where" - , "import qualified \"this\" Data.List as ThisList" - , "import qualified \"base\" Data.List as BaseList" - , "useThis = ThisList.x" - , "useBase = BaseList.map" - , "wrong1 = ThisList.map" - , "wrong2 = BaseList.x" - ] - _ <- createDoc "Data/List.hs" "haskell" thisDataListContent - _ <- createDoc "Main.hs" "haskell" mainContent - expectDiagnostics - [ ( "Main.hs" - , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217") - ,(DsError, (7, 9), "Not in scope: \8216BaseList.x\8217") - ] - ) - ] - , testSessionWait "unqualified warnings" $ do - let fooContent = T.unlines - [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" - , "module Foo where" - , "foo :: Ord a => a -> Int" - , "foo _a = 1" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics - [ ( "Foo.hs" - -- The test is to make sure that warnings contain unqualified names - -- where appropriate. The warning should use an unqualified name 'Ord', not - -- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to - -- test this is fairly arbitrary. - , [(DsWarning, (2, 0), "Redundant constraint: Ord a") - ] - ) - ] - , testSessionWait "lower-case drive" $ do - let aContent = T.unlines - [ "module A.A where" - , "import A.B ()" - ] - bContent = T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A.B where" - , "import Data.List" - ] - uriB <- getDocUri "A/B.hs" - Just pathB <- pure $ uriToFilePath uriB - uriB <- pure $ - let (drive, suffix) = splitDrive pathB - in filePathToUri (joinDrive (lower drive) suffix) - liftIO $ createDirectoryIfMissing True (takeDirectory pathB) - liftIO $ writeFileUTF8 pathB $ T.unpack bContent - uriA <- getDocUri "A/A.hs" - Just pathA <- pure $ uriToFilePath uriA - uriA <- pure $ - let (drive, suffix) = splitDrive pathA - in filePathToUri (joinDrive (lower drive) suffix) - let itemA = TextDocumentItem uriA "haskell" 0 aContent - let a = TextDocumentIdentifier uriA - sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams itemA) - NotificationMessage{_params = PublishDiagnosticsParams fileUri _ diags} <- skipManyTill anyMessage diagnostic - -- Check that if we put a lower-case drive in for A.A - -- the diagnostics for A.B will also be lower-case. - liftIO $ fileUri @?= uriB - let msg = _message (head (toList diags) :: Diagnostic) - liftIO $ unless ("redundant" `T.isInfixOf` msg) $ - assertFailure ("Expected redundant import but got " <> T.unpack msg) - closeDoc a - , testSessionWait "haddock parse error" $ do - let fooContent = T.unlines - [ "module Foo where" - , "foo :: Int" - , "foo = 1 {-|-}" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics - [ ( "Foo.hs" - , [(DsWarning, (2, 8), "Haddock parse error on input") - ] - ) - ] - , testSessionWait "strip file path" $ do - let - name = "Testing" - content = T.unlines - [ "module " <> name <> " where" - , "value :: Maybe ()" - , "value = [()]" - ] - _ <- createDoc (T.unpack name <> ".hs") "haskell" content - notification <- skipManyTill anyMessage diagnostic - let - offenders = - Lsp.params . - Lsp.diagnostics . - Lens.folded . - Lsp.message . - Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:")) - failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg - Lens.mapMOf_ offenders failure notification - , testSession' "-Werror in cradle is ignored" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wall\", \"-Werror\"]}}" - let fooContent = T.unlines - [ "module Foo where" - , "foo = ()" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics - [ ( "Foo.hs" - , [(DsWarning, (1, 0), "Top-level binding with no type signature:") - ] - ) - ] - , testSessionWait "-Werror in pragma is ignored" $ do - let fooContent = T.unlines - [ "{-# OPTIONS_GHC -Wall -Werror #-}" - , "module Foo() where" - , "foo :: Int" - , "foo = 1" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics - [ ( "Foo.hs" - , [(DsWarning, (3, 0), "Defined but not used:") - ] - ) - ] - , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do - let bPath = dir "B.hs" - pPath = dir "P.hs" - aPath = dir "A.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - aSource <- liftIO $ readFileUtf8 aPath -- x = y :: Int - - bdoc <- createDoc bPath "haskell" bSource - _pdoc <- createDoc pPath "haskell" pSource - expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded - - -- Change y from Int to B which introduces a type error in A (imported from P) - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ - T.unlines ["module B where", "y :: Bool", "y = undefined"]] - expectDiagnostics - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ] - - -- Open A and edit to fix the type error - adoc <- createDoc aPath "haskell" aSource - changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing $ - T.unlines ["module A where", "import B", "x :: Bool", "x = y"]] - - expectDiagnostics - [ ( "P.hs", - [ (DsError, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"), - (DsWarning, (4, 0), "Top-level binding") - ] - ), - ("A.hs", []) - ] - expectNoMoreDiagnostics 1 - - , testSessionWait "deduplicate missing module diagnostics" $ do - let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ] - doc <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])] - - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module Foo() where" ] - expectDiagnostics [] - - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines - [ "module Foo() where" , "import MissingModule" ] ] - expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])] - - , testGroup "Cancellation" - [ cancellationTestGroup "edit header" editHeader yesDepends yesSession noParse noTc - , cancellationTestGroup "edit import" editImport noDepends noSession yesParse noTc - , cancellationTestGroup "edit body" editBody yesDepends yesSession yesParse yesTc - ] - ] - where - editPair x y = let p = Position x y ; p' = Position x (y+2) in - (TextDocumentContentChangeEvent {_range=Just (Range p p), _rangeLength=Nothing, _text="fd"} - ,TextDocumentContentChangeEvent {_range=Just (Range p p'), _rangeLength=Nothing, _text=""}) - editHeader = editPair 0 0 - editImport = editPair 2 10 - editBody = editPair 3 10 - - noParse = False - yesParse = True - - noDepends = False - yesDepends = True - - noSession = False - yesSession = True - - noTc = False - yesTc = True - -cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> Bool -> TestTree -cancellationTestGroup name edits dependsOutcome sessionDepsOutcome parseOutcome tcOutcome = testGroup name - [ cancellationTemplate edits Nothing - , cancellationTemplate edits $ Just ("GetFileContents", True) - , cancellationTemplate edits $ Just ("GhcSession", True) - -- the outcome for GetModSummary is always True because parseModuleHeader never fails (!) - , cancellationTemplate edits $ Just ("GetModSummary", True) - , cancellationTemplate edits $ Just ("GetModSummaryWithoutTimestamps", True) - -- getLocatedImports never fails - , cancellationTemplate edits $ Just ("GetLocatedImports", True) - , cancellationTemplate edits $ Just ("GetDependencies", dependsOutcome) - , cancellationTemplate edits $ Just ("GhcSessionDeps", sessionDepsOutcome) - , cancellationTemplate edits $ Just ("GetParsedModule", parseOutcome) - , cancellationTemplate edits $ Just ("TypeCheck", tcOutcome) - , cancellationTemplate edits $ Just ("GetHieAst", tcOutcome) - ] - -cancellationTemplate :: (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Maybe (String, Bool) -> TestTree -cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ runTestNoKick $ do - doc <- createDoc "Foo.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module Foo where" - , "import Data.List()" - , "f0 x = (x,x)" - ] - - -- for the example above we expect one warning - let missingSigDiags = [(DsWarning, (3, 0), "Top-level binding") ] - typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags - - -- Now we edit the document and wait for the given key (if any) - changeDoc doc [edit] - whenJust mbKey $ \(key, expectedResult) -> do - Right WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc - liftIO $ ideResultSuccess @?= expectedResult - - -- The 2nd edit cancels the active session and unbreaks the file - -- wait for typecheck and check that the current diagnostics are accurate - changeDoc doc [undoEdit] - typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags - - expectNoMoreDiagnostics 0.5 - where - -- similar to run except it disables kick - runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s - - typeCheck doc = do - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc - liftIO $ assertBool "The file should typecheck" ideResultSuccess - -- wait for the debouncer to publish diagnostics if the rule runs - liftIO $ sleep 0.2 - -- flush messages to ensure current diagnostics state is updated - flushMessages - -codeActionTests :: TestTree -codeActionTests = testGroup "code actions" - [ renameActionTests - , typeWildCardActionTests - , removeImportTests - , extendImportTests - , suggestImportTests - , suggestHideShadowTests - , suggestImportDisambiguationTests - , fixConstructorImportTests - , importRenameActionTests - , fillTypedHoleTests - , addSigActionTests - , insertNewDefinitionTests - , deleteUnusedDefinitionTests - , addInstanceConstraintTests - , addFunctionConstraintTests - , removeRedundantConstraintsTests - , addTypeAnnotationsToLiteralsTest - , exportUnusedTests - , addImplicitParamsConstraintTests - , removeExportTests - ] - -codeActionHelperFunctionTests :: TestTree -codeActionHelperFunctionTests = testGroup "code action helpers" - [ - extendImportTestsRegEx - ] - - -codeLensesTests :: TestTree -codeLensesTests = testGroup "code lenses" - [ addSigLensesTests - ] - -watchedFilesTests :: TestTree -watchedFilesTests = testGroup "watched files" - [ testSession' "workspace files" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}" - _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule" - watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics - - -- Expect 1 subscription: we only ever send one - liftIO $ length watchedFileRegs @?= 1 - - , testSession' "non workspace file" $ \sessionDir -> do - tmpDir <- liftIO getTemporaryDirectory - liftIO $ writeFile (sessionDir "hie.yaml") ("cradle: {direct: {arguments: [\"-i" <> tmpDir <> "\", \"A\", \"WatchedFilesMissingModule\"]}}") - _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule" - watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics - - -- Expect 1 subscription: we only ever send one - liftIO $ length watchedFileRegs @?= 1 - - -- TODO add a test for didChangeWorkspaceFolder - ] - -renameActionTests :: TestTree -renameActionTests = testGroup "rename actions" - [ testSession "change to local variable name" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> Int" - , "foo argName = argNme" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’" - executeCodeAction action - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "foo :: Int -> Int" - , "foo argName = argName" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "change to name of imported function" $ do - let content = T.unlines - [ "module Testing where" - , "import Data.Maybe (maybeToList)" - , "foo :: Maybe a -> [a]" - , "foo = maybToList" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’" - executeCodeAction action - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "import Data.Maybe (maybeToList)" - , "foo :: Maybe a -> [a]" - , "foo = maybeToList" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "suggest multiple local variable names" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Char -> Char -> Char -> Char" - , "foo argument1 argument2 argument3 = argumentX" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45)) - ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"] - return() - , testSession "change infix function" $ do - let content = T.unlines - [ "module Testing where" - , "monus :: Int -> Int" - , "monus x y = max 0 (x - y)" - , "foo x y = x `monnus` y" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20)) - [fixTypo] <- pure [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ] - executeCodeAction fixTypo - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "monus :: Int -> Int" - , "monus x y = max 0 (x - y)" - , "foo x y = x `monus` y" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - ] - -typeWildCardActionTests :: TestTree -typeWildCardActionTests = testGroup "type wildcard actions" - [ testSession "global signature" $ do - let content = T.unlines - [ "module Testing where" - , "func :: _" - , "func x = x" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10)) - let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands - , "Use type signature" `T.isInfixOf` actionTitle - ] - executeCodeAction addSignature - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "func :: (p -> p)" - , "func x = x" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "multi-line message" $ do - let content = T.unlines - [ "module Testing where" - , "func :: _" - , "func x y = x + y" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10)) - let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands - , "Use type signature" `T.isInfixOf` actionTitle - ] - executeCodeAction addSignature - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "func :: (Integer -> Integer -> Integer)" - , "func x y = x + y" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "local signature" $ do - let content = T.unlines - [ "module Testing where" - , "func :: Int -> Int" - , "func x =" - , " let y :: _" - , " y = x * 2" - , " in y" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10)) - let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands - , "Use type signature" `T.isInfixOf` actionTitle - ] - executeCodeAction addSignature - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "func :: Int -> Int" - , "func x =" - , " let y :: (Int)" - , " y = x * 2" - , " in y" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - ] - -removeImportTests :: TestTree -removeImportTests = testGroup "remove import actions" - [ testSession "redundant" $ do - let contentA = T.unlines - [ "module ModuleA where" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA" - , "stuffB :: Integer" - , "stuffB = 123" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "stuffB :: Integer" - , "stuffB = 123" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "qualified redundant" $ do - let contentA = T.unlines - [ "module ModuleA where" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import qualified ModuleA" - , "stuffB :: Integer" - , "stuffB = 123" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "stuffB :: Integer" - , "stuffB = 123" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "redundant binding" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "stuffA = False" - , "stuffB :: Integer" - , "stuffB = 123" - , "stuffC = ()" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (stuffA, stuffB, stuffC, stuffA)" - , "main = print stuffB" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove stuffA, stuffC from import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (stuffB)" - , "main = print stuffB" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "redundant operator" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "a !! _b = a" - , "a _b = a" - , "stuffB :: Integer" - , "stuffB = 123" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import qualified ModuleA as A ((), stuffB, (!!))" - , "main = print A.stuffB" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove !!, from import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import qualified ModuleA as A (stuffB)" - , "main = print A.stuffB" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "redundant all import" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "data A = A" - , "stuffB :: Integer" - , "stuffB = 123" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (A(..), stuffB)" - , "main = print stuffB" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove A from import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (stuffB)" - , "main = print stuffB" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "redundant constructor import" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "data D = A | B" - , "data E = F" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (D(A,B), E(F))" - , "main = B" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove A, E, F from import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (D(B))" - , "main = B" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "import containing the identifier Strict" $ do - let contentA = T.unlines - [ "module Strict where" - ] - _docA <- createDoc "Strict.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import Strict" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "remove all" $ do - let content = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleA where" - , "import Data.Function (fix, (&))" - , "import qualified Data.Functor.Const" - , "import Data.Functor.Identity" - , "import Data.Functor.Sum (Sum (InL, InR))" - , "import qualified Data.Kind as K (Constraint, Type)" - , "x = InL (Identity 123)" - , "y = fix id" - , "type T = K.Type" - ] - doc <- createDoc "ModuleC.hs" "haskell" content - _ <- waitForDiagnostics - [_, _, _, _, InR action@CodeAction { _title = actionTitle }] - <- getCodeActions doc (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove all redundant imports" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleA where" - , "import Data.Function (fix)" - , "import Data.Functor.Identity" - , "import Data.Functor.Sum (Sum (InL))" - , "import qualified Data.Kind as K (Type)" - , "x = InL (Identity 123)" - , "y = fix id" - , "type T = K.Type" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - ] - -extendImportTests :: TestTree -extendImportTests = testGroup "extend import actions" - [ testGroup "with checkAll" $ tests True - , testGroup "without checkAll" $ tests False - ] - where - tests overrideCheckProject = - [ testSession "extend single line import with value" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "stuffA :: Double" - , "stuffA = 0.00750" - , "stuffB :: Integer" - , "stuffB = 123" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA as A (stuffB)" - , "main = print (stuffA, stuffB)" - ]) - (Range (Position 3 17) (Position 3 18)) - ["Add stuffA to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA as A (stuffB, stuffA)" - , "main = print (stuffA, stuffB)" - ]) - , testSession "extend single line import with operator" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "(.*) :: Integer -> Integer -> Integer" - , "x .* y = x * y" - , "stuffB :: Integer" - , "stuffB = 123" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA as A (stuffB)" - , "main = print (stuffB .* stuffB)" - ]) - (Range (Position 3 17) (Position 3 18)) - ["Add (.*) to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA as A (stuffB, (.*))" - , "main = print (stuffB .* stuffB)" - ]) - , testSession "extend single line import with type" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "type A = Double" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA ()" - , "b :: A" - , "b = 0" - ]) - (Range (Position 2 5) (Position 2 5)) - ["Add A to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (A)" - , "b :: A" - , "b = 0" - ]) - , testSession "extend single line import with constructor" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "data A = Constructor" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (A)" - , "b :: A" - , "b = Constructor" - ]) - (Range (Position 2 5) (Position 2 5)) - ["Add A(Constructor) to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (A (Constructor))" - , "b :: A" - , "b = Constructor" - ]) - , testSession "extend single line import with constructor (with comments)" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "data A = Constructor" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (A ({-Constructor-}))" - , "b :: A" - , "b = Constructor" - ]) - (Range (Position 2 5) (Position 2 5)) - ["Add A(Constructor) to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (A (Constructor{-Constructor-}))" - , "b :: A" - , "b = Constructor" - ]) - , testSession "extend single line import with mixed constructors" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "data A = ConstructorFoo | ConstructorBar" - , "a = 1" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (A (ConstructorBar), a)" - , "b :: A" - , "b = ConstructorFoo" - ]) - (Range (Position 2 5) (Position 2 5)) - ["Add A(ConstructorFoo) to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (A (ConstructorBar, ConstructorFoo), a)" - , "b :: A" - , "b = ConstructorFoo" - ]) - , testSession "extend single line qualified import with value" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "stuffA :: Double" - , "stuffA = 0.00750" - , "stuffB :: Integer" - , "stuffB = 123" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import qualified ModuleA as A (stuffB)" - , "main = print (A.stuffA, A.stuffB)" - ]) - (Range (Position 3 17) (Position 3 18)) - ["Add stuffA to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import qualified ModuleA as A (stuffB, stuffA)" - , "main = print (A.stuffA, A.stuffB)" - ]) - , testSession "extend multi line import with value" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "stuffA :: Double" - , "stuffA = 0.00750" - , "stuffB :: Integer" - , "stuffB = 123" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (stuffB" - , " )" - , "main = print (stuffA, stuffB)" - ]) - (Range (Position 3 17) (Position 3 18)) - ["Add stuffA to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (stuffB, stuffA" - , " )" - , "main = print (stuffA, stuffB)" - ]) - , testSession "extend single line import with method within class" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "class C a where" - , " m1 :: a -> a" - , " m2 :: a -> a" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (C(m1))" - , "b = m2" - ]) - (Range (Position 2 5) (Position 2 5)) - ["Add C(m2) to the import list of ModuleA", - "Add m2 to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (C(m1, m2))" - , "b = m2" - ]) - , testSession "extend single line import with method without class" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "class C a where" - , " m1 :: a -> a" - , " m2 :: a -> a" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (C(m1))" - , "b = m2" - ]) - (Range (Position 2 5) (Position 2 5)) - ["Add m2 to the import list of ModuleA", - "Add C(m2) to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (C(m1), m2)" - , "b = m2" - ]) - , testSession "extend import list with multiple choices" $ template - [("ModuleA.hs", T.unlines - -- this is just a dummy module to help the arguments needed for this test - [ "module ModuleA (bar) where" - , "bar = 10" - ]), - ("ModuleB.hs", T.unlines - -- this is just a dummy module to help the arguments needed for this test - [ "module ModuleB (bar) where" - , "bar = 10" - ])] - ("ModuleC.hs", T.unlines - [ "module ModuleC where" - , "import ModuleB ()" - , "import ModuleA ()" - , "foo = bar" - ]) - (Range (Position 3 17) (Position 3 18)) - ["Add bar to the import list of ModuleA", - "Add bar to the import list of ModuleB"] - (T.unlines - [ "module ModuleC where" - , "import ModuleB ()" - , "import ModuleA (bar)" - , "foo = bar" - ]) - , testSession "extend import list with constructor of type operator" $ template - [] - ("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "import Data.Type.Equality ((:~:))" - , "x :: (:~:) [] []" - , "x = Refl" - ]) - (Range (Position 3 17) (Position 3 18)) - ["Add (:~:)(Refl) to the import list of Data.Type.Equality"] - (T.unlines - [ "module ModuleA where" - , "import Data.Type.Equality ((:~:) (Refl))" - , "x :: (:~:) [] []" - , "x = Refl" - ]) - ] - where - codeActionTitle CodeAction{_title=x} = x - - template setUpModules moduleUnderTest range expectedTitles expectedContentB = do - sendNotification SWorkspaceDidChangeConfiguration - (DidChangeConfigurationParams $ toJSON - def{checkProject = overrideCheckProject}) - - - mapM_ (\x -> createDoc (fst x) "haskell" (snd x)) setUpModules - docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest) - _ <- waitForDiagnostics - waitForProgressDone - actionsOrCommands <- getCodeActions docB range - let codeActions = - filter - (T.isPrefixOf "Add" . codeActionTitle) - [ca | InR ca <- actionsOrCommands] - actualTitles = codeActionTitle <$> codeActions - -- Note that we are not testing the order of the actions, as the - -- order of the expected actions indicates which one we'll execute - -- in this test, i.e., the first one. - liftIO $ sort expectedTitles @=? sort actualTitles - - -- Execute the action with the same title as the first expected one. - -- Since we tested that both lists have the same elements (possibly - -- in a different order), this search cannot fail. - let firstTitle:_ = expectedTitles - action = fromJust $ - find ((firstTitle ==) . codeActionTitle) codeActions - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ expectedContentB @=? contentAfterAction - -extendImportTestsRegEx :: TestTree -extendImportTestsRegEx = testGroup "regex parsing" - [ - testCase "parse invalid multiple imports" $ template "foo bar foo" Nothing - , testCase "parse malformed import list" $ template - "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n \8216Data.Map\8217)" - Nothing - , testCase "parse multiple imports" $ template - "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n \8216Data.Map\8217 (app/testlsp.hs:7:1-18)\n \8216Data.HashMap.Strict\8217 (app/testlsp.hs:8:1-29)" - $ Just ("fromList",[("Data.Map","app/testlsp.hs:7:1-18"),("Data.HashMap.Strict","app/testlsp.hs:8:1-29")]) - ] - where - template message expected = do - liftIO $ matchRegExMultipleImports message @=? expected - - - -suggestImportTests :: TestTree -suggestImportTests = testGroup "suggest import actions" - [ testGroup "Dont want suggestion" - [ -- extend import - test False ["Data.List.NonEmpty ()"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" - -- data constructor - , test False [] "f = First" [] "import Data.Monoid (First)" - -- internal module - , test False [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable.Internal (Typeable)" - -- package not in scope - , test False [] "f = quickCheck" [] "import Test.QuickCheck (quickCheck)" - -- don't omit the parent data type of a constructor - , test False [] "f ExitSuccess = ()" [] "import System.Exit (ExitSuccess)" - ] - , testGroup "want suggestion" - [ wantWait [] "f = foo" [] "import Foo (foo)" - , wantWait [] "f = Bar" [] "import Bar (Bar(Bar))" - , wantWait [] "f :: Bar" [] "import Bar (Bar)" - , test True [] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" - , test True [] "f = (:|)" [] "import Data.List.NonEmpty (NonEmpty((:|)))" - , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural (Natural)" - , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural" - , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty (NonEmpty)" - , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty" - , test True [] "f = First" [] "import Data.Monoid (First(First))" - , test True [] "f = Endo" [] "import Data.Monoid (Endo(Endo))" - , test True [] "f = Version" [] "import Data.Version (Version(Version))" - , test True [] "f ExitSuccess = ()" [] "import System.Exit (ExitCode(ExitSuccess))" - , test True [] "f = AssertionFailed" [] "import Control.Exception (AssertionFailed(AssertionFailed))" - , test True ["Prelude"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" - , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative (Alternative)" - , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative" - , test True [] "f = empty" [] "import Control.Applicative (Alternative(empty))" - , test True [] "f = empty" [] "import Control.Applicative (empty)" - , test True [] "f = empty" [] "import Control.Applicative" - , test True [] "f = (&)" [] "import Data.Function ((&))" - , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE" - , test True [] "f = Data.List.NonEmpty.nonEmpty" [] "import qualified Data.List.NonEmpty" - , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)" - , test True [] "f = pack" [] "import Data.Text (pack)" - , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)" - , test True [] "f = [] & id" [] "import Data.Function ((&))" - , test True [] "f = (&) [] id" [] "import Data.Function ((&))" - , test True [] "f = (.|.)" [] "import Data.Bits (Bits((.|.)))" - , test True [] "f = (.|.)" [] "import Data.Bits ((.|.))" - ] - ] - where - test = test' False - wantWait = test' True True - test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do - let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other - after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other - cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo]}}" - liftIO $ writeFileUTF8 (dir "hie.yaml") cradle - doc <- createDoc "Test.hs" "haskell" before - waitForProgressDone - _diags <- waitForDiagnostics - -- there isn't a good way to wait until the whole project is checked atm - when waitForCheckProject $ liftIO $ sleep 0.5 - let defLine = length imps + 1 - range = Range (Position defLine 0) (Position defLine maxBound) - actions <- getCodeActions doc range - if wanted - then do - action <- liftIO $ pickActionWithTitle newImp actions - executeCodeAction action - contentAfterAction <- documentContents doc - liftIO $ after @=? contentAfterAction - else - liftIO $ [_title | InR CodeAction{_title} <- actions, _title == newImp ] @?= [] - -suggestImportDisambiguationTests :: TestTree -suggestImportDisambiguationTests = testGroup "suggest import disambiguation actions" - [ testGroup "Hiding strategy works" - [ testGroup "fromList" - [ testCase "AVec" $ - compareHideFunctionTo [(8,9),(10,8)] - "Use AVec for fromList, hiding other imports" - "HideFunction.expected.fromList.A.hs" - , testCase "BVec" $ - compareHideFunctionTo [(8,9),(10,8)] - "Use BVec for fromList, hiding other imports" - "HideFunction.expected.fromList.B.hs" - ] - , testGroup "(++)" - [ testCase "EVec" $ - compareHideFunctionTo [(8,9),(10,8)] - "Use EVec for ++, hiding other imports" - "HideFunction.expected.append.E.hs" - , testCase "Prelude" $ - compareHideFunctionTo [(8,9),(10,8)] - "Use Prelude for ++, hiding other imports" - "HideFunction.expected.append.Prelude.hs" - , testCase "AVec, indented" $ - compareTwo "HidePreludeIndented.hs" [(3,8)] - "Use AVec for ++, hiding other imports" - "HidePreludeIndented.expected.hs" - - ] - , testGroup "Vec (type)" - [ testCase "AVec" $ - compareTwo - "HideType.hs" [(8,15)] - "Use AVec for Vec, hiding other imports" - "HideType.expected.A.hs" - , testCase "EVec" $ - compareTwo - "HideType.hs" [(8,15)] - "Use EVec for Vec, hiding other imports" - "HideType.expected.E.hs" - ] - ] - , testGroup "Qualify strategy" - [ testCase "won't suggest full name for qualified module" $ - withHideFunction [(8,9),(10,8)] $ \_ actions -> do - liftIO $ - assertBool "EVec.fromList must not be suggested" $ - "Replace with qualified: EVec.fromList" `notElem` - [ actionTitle - | InR CodeAction { _title = actionTitle } <- actions - ] - liftIO $ - assertBool "EVec.++ must not be suggested" $ - "Replace with qualified: EVec.++" `notElem` - [ actionTitle - | InR CodeAction { _title = actionTitle } <- actions - ] - , testGroup "fromList" - [ testCase "EVec" $ - compareHideFunctionTo [(8,9),(10,8)] - "Replace with qualified: E.fromList" - "HideFunction.expected.qualified.fromList.E.hs" - ] - , testGroup "(++)" - [ testCase "Prelude, parensed" $ - compareHideFunctionTo [(8,9),(10,8)] - "Replace with qualified: Prelude.++" - "HideFunction.expected.qualified.append.Prelude.hs" - , testCase "Prelude, infix" $ - compareTwo - "HideQualifyInfix.hs" [(4,19)] - "Replace with qualified: Prelude.++" - "HideQualifyInfix.expected.hs" - , testCase "Prelude, left section" $ - compareTwo - "HideQualifySectionLeft.hs" [(4,15)] - "Replace with qualified: Prelude.++" - "HideQualifySectionLeft.expected.hs" - , testCase "Prelude, right section" $ - compareTwo - "HideQualifySectionRight.hs" [(4,18)] - "Replace with qualified: Prelude.++" - "HideQualifySectionRight.expected.hs" - ] - ] - ] - where - hidingDir = "test/data/hiding" - compareTwo original locs cmd expected = - withTarget original locs $ \doc actions -> do - expected <- liftIO $ - readFileUtf8 (hidingDir expected) - action <- liftIO $ pickActionWithTitle cmd actions - executeCodeAction action - contentAfterAction <- documentContents doc - liftIO $ T.replace "\r\n" "\n" expected @=? contentAfterAction - compareHideFunctionTo = compareTwo "HideFunction.hs" - auxFiles = ["AVec.hs", "BVec.hs", "CVec.hs", "DVec.hs", "EVec.hs"] - withTarget file locs k = withTempDir $ \dir -> runInDir dir $ do - liftIO $ mapM_ (\fp -> copyFile (hidingDir fp) $ dir fp) - $ file : auxFiles - doc <- openDoc file "haskell" - waitForProgressDone - void $ expectDiagnostics [(file, [(DsError, loc, "Ambiguous occurrence") | loc <- locs])] - contents <- documentContents doc - let range = Range (Position 0 0) (Position (length $ T.lines contents) 0) - actions <- getCodeActions doc range - k doc actions - withHideFunction = withTarget ("HideFunction" <.> "hs") - -suggestHideShadowTests :: TestTree -suggestHideShadowTests = - testGroup - "suggest hide shadow" - [ testGroup - "single" - [ testOneCodeAction - "hide unsued" - "Hide on from Data.Function" - (1, 2) - (1, 4) - [ "import Data.Function" - , "f on = on" - , "g on = on" - ] - [ "import Data.Function hiding (on)" - , "f on = on" - , "g on = on" - ] - , testOneCodeAction - "extend hiding unsued" - "Hide on from Data.Function" - (1, 2) - (1, 4) - [ "import Data.Function hiding ((&))" - , "f on = on" - ] - [ "import Data.Function hiding (on, (&))" - , "f on = on" - ] - , testOneCodeAction - "delete unsued" - "Hide on from Data.Function" - (1, 2) - (1, 4) - [ "import Data.Function ((&), on)" - , "f on = on" - ] - [ "import Data.Function ((&))" - , "f on = on" - ] - , testOneCodeAction - "hide operator" - "Hide & from Data.Function" - (1, 2) - (1, 5) - [ "import Data.Function" - , "f (&) = (&)" - ] - [ "import Data.Function hiding ((&))" - , "f (&) = (&)" - ] - , testOneCodeAction - "remove operator" - "Hide & from Data.Function" - (1, 2) - (1, 5) - [ "import Data.Function ((&), on)" - , "f (&) = (&)" - ] - [ "import Data.Function ( on)" - , "f (&) = (&)" - ] - , noCodeAction - "don't remove already used" - (2, 2) - (2, 4) - [ "import Data.Function" - , "g = on" - , "f on = on" - ] - ] - , testGroup - "multi" - [ testOneCodeAction - "hide from B" - "Hide ++ from B" - (2, 2) - (2, 6) - [ "import B" - , "import C" - , "f (++) = (++)" - ] - [ "import B hiding ((++))" - , "import C" - , "f (++) = (++)" - ] - , testOneCodeAction - "hide from C" - "Hide ++ from C" - (2, 2) - (2, 6) - [ "import B" - , "import C" - , "f (++) = (++)" - ] - [ "import B" - , "import C hiding ((++))" - , "f (++) = (++)" - ] - , testOneCodeAction - "hide from Prelude" - "Hide ++ from Prelude" - (2, 2) - (2, 6) - [ "import B" - , "import C" - , "f (++) = (++)" - ] - [ "import B" - , "import C" - , "import Prelude hiding ((++))" - , "f (++) = (++)" - ] - , testMultiCodeActions - "manual hide all" - [ "Hide ++ from Prelude" - , "Hide ++ from C" - , "Hide ++ from B" - ] - (2, 2) - (2, 6) - [ "import B" - , "import C" - , "f (++) = (++)" - ] - [ "import B hiding ((++))" - , "import C hiding ((++))" - , "import Prelude hiding ((++))" - , "f (++) = (++)" - ] - , testOneCodeAction - "auto hide all" - "Hide ++ from all occurence imports" - (2, 2) - (2, 6) - [ "import B" - , "import C" - , "f (++) = (++)" - ] - [ "import B hiding ((++))" - , "import C hiding ((++))" - , "import Prelude hiding ((++))" - , "f (++) = (++)" - ] - ] - ] - where - testOneCodeAction testName actionName start end origin expected = - helper testName start end origin expected $ \cas -> do - action <- liftIO $ pickActionWithTitle actionName cas - executeCodeAction action - noCodeAction testName start end origin = - helper testName start end origin origin $ \cas -> do - liftIO $ cas @?= [] - testMultiCodeActions testName actionNames start end origin expected = - helper testName start end origin expected $ \cas -> do - let r = [ca | (InR ca) <- cas, ca ^. L.title `elem` actionNames] - liftIO $ - (length r == length actionNames) - @? "Expected " <> show actionNames <> ", but got " <> show cas <> " which is not its superset" - forM_ r executeCodeAction - helper testName (line1, col1) (line2, col2) origin expected k = testSession testName $ do - void $ createDoc "B.hs" "haskell" $ T.unlines docB - void $ createDoc "C.hs" "haskell" $ T.unlines docC - doc <- createDoc "A.hs" "haskell" $ T.unlines (header <> origin) - void waitForDiagnostics - waitForProgressDone - cas <- getCodeActions doc (Range (Position (line1 + length header) col1) (Position (line2 + length header) col2)) - void $ k [x | x@(InR ca) <- cas, "Hide" `T.isPrefixOf` (ca ^. L.title)] - contentAfter <- documentContents doc - liftIO $ contentAfter @?= T.unlines (header <> expected) - header = - [ "{-# OPTIONS_GHC -Wname-shadowing #-}" - , "module A where" - , "" - ] - -- for multi group - docB = - [ "module B where" - , "(++) = id" - ] - docC = - [ "module C where" - , "(++) = id" - ] - -insertNewDefinitionTests :: TestTree -insertNewDefinitionTests = testGroup "insert new definition actions" - [ testSession "insert new function definition" $ do - let txtB = - ["foo True = select [True]" - , "" - ,"foo False = False" - ] - txtB' = - ["" - ,"someOtherCode = ()" - ] - docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') - _ <- waitForDiagnostics - InR action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> - getCodeActions docB (R 1 0 1 50) - liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines (txtB ++ - [ "" - , "select :: [Bool] -> Bool" - , "select = error \"not implemented\"" - ] - ++ txtB') - , testSession "define a hole" $ do - let txtB = - ["foo True = _select [True]" - , "" - ,"foo False = False" - ] - txtB' = - ["" - ,"someOtherCode = ()" - ] - docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') - _ <- waitForDiagnostics - InR action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> - getCodeActions docB (R 1 0 1 50) - liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines ( - ["foo True = select [True]" - , "" - ,"foo False = False" - , "" - , "select :: [Bool] -> Bool" - , "select = error \"not implemented\"" - ] - ++ txtB') - ] - - -deleteUnusedDefinitionTests :: TestTree -deleteUnusedDefinitionTests = testGroup "delete unused definition action" - [ testSession "delete unused top level binding" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (some) where" - , "" - , "f :: Int -> Int" - , "f 1 = let a = 1" - , " in a" - , "f 2 = 2" - , "" - , "some = ()" - ]) - (4, 0) - "Delete ‘f’" - (T.unlines [ - "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (some) where" - , "" - , "some = ()" - ]) - - , testSession "delete unused top level binding defined in infix form" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (some) where" - , "" - , "myPlus :: Int -> Int -> Int" - , "a `myPlus` b = a + b" - , "" - , "some = ()" - ]) - (4, 2) - "Delete ‘myPlus’" - (T.unlines [ - "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (some) where" - , "" - , "some = ()" - ]) - , testSession "delete unused binding in where clause" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (h, g) where" - , "" - , "h :: Int" - , "h = 3" - , "" - , "g :: Int" - , "g = 6" - , " where" - , " h :: Int" - , " h = 4" - , "" - ]) - (10, 4) - "Delete ‘h’" - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (h, g) where" - , "" - , "h :: Int" - , "h = 3" - , "" - , "g :: Int" - , "g = 6" - , " where" - , "" - ]) - , testSession "delete unused binding with multi-oneline signatures front" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (b, c) where" - , "" - , "a, b, c :: Int" - , "a = 3" - , "b = 4" - , "c = 5" - ]) - (4, 0) - "Delete ‘a’" - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (b, c) where" - , "" - , "b, c :: Int" - , "b = 4" - , "c = 5" - ]) - , testSession "delete unused binding with multi-oneline signatures mid" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (a, c) where" - , "" - , "a, b, c :: Int" - , "a = 3" - , "b = 4" - , "c = 5" - ]) - (5, 0) - "Delete ‘b’" - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (a, c) where" - , "" - , "a, c :: Int" - , "a = 3" - , "c = 5" - ]) - , testSession "delete unused binding with multi-oneline signatures end" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (a, b) where" - , "" - , "a, b, c :: Int" - , "a = 3" - , "b = 4" - , "c = 5" - ]) - (6, 0) - "Delete ‘c’" - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (a, b) where" - , "" - , "a, b :: Int" - , "a = 3" - , "b = 4" - ]) - ] - where - testFor source pos expectedTitle expectedResult = do - docId <- createDoc "A.hs" "haskell" source - expectDiagnostics [ ("A.hs", [(DsWarning, pos, "not used")]) ] - - (action, title) <- extractCodeAction docId "Delete" - - liftIO $ title @?= expectedTitle - executeCodeAction action - contentAfterAction <- documentContents docId - liftIO $ contentAfterAction @?= expectedResult - - extractCodeAction docId actionPrefix = do - [action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R 0 0 0 0) [actionPrefix] - return (action, actionTitle) - -addTypeAnnotationsToLiteralsTest :: TestTree -addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals to satisfy contraints" - [ - testSession "add default type to satisfy one contraint" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A (f) where" - , "" - , "f = 1" - ]) - [ (DsWarning, (3, 4), "Defaulting the following constraint") ] - "Add type annotation ‘Integer’ to ‘1’" - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A (f) where" - , "" - , "f = (1 :: Integer)" - ]) - - , testSession "add default type to satisfy one contraint in nested expressions" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A where" - , "" - , "f =" - , " let x = 3" - , " in x" - ]) - [ (DsWarning, (4, 12), "Defaulting the following constraint") ] - "Add type annotation ‘Integer’ to ‘3’" - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A where" - , "" - , "f =" - , " let x = (3 :: Integer)" - , " in x" - ]) - , testSession "add default type to satisfy one contraint in more nested expressions" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A where" - , "" - , "f =" - , " let x = let y = 5 in y" - , " in x" - ]) - [ (DsWarning, (4, 20), "Defaulting the following constraint") ] - "Add type annotation ‘Integer’ to ‘5’" - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A where" - , "" - , "f =" - , " let x = let y = (5 :: Integer) in y" - , " in x" - ]) - , testSession "add default type to satisfy one contraint with duplicate literals" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "module A (f) where" - , "" - , "import Debug.Trace" - , "" - , "f = seq \"debug\" traceShow \"debug\"" - ]) - [ (DsWarning, (6, 8), "Defaulting the following constraint") - , (DsWarning, (6, 16), "Defaulting the following constraint") - ] - "Add type annotation ‘[Char]’ to ‘\"debug\"’" - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "module A (f) where" - , "" - , "import Debug.Trace" - , "" - , "f = seq (\"debug\" :: [Char]) traceShow \"debug\"" - ]) - , testSession "add default type to satisfy two contraints" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "module A (f) where" - , "" - , "import Debug.Trace" - , "" - , "f a = traceShow \"debug\" a" - ]) - [ (DsWarning, (6, 6), "Defaulting the following constraint") ] - "Add type annotation ‘[Char]’ to ‘\"debug\"’" - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "module A (f) where" - , "" - , "import Debug.Trace" - , "" - , "f a = traceShow (\"debug\" :: [Char]) a" - ]) - , testSession "add default type to satisfy two contraints with duplicate literals" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "module A (f) where" - , "" - , "import Debug.Trace" - , "" - , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))" - ]) - [ (DsWarning, (6, 54), "Defaulting the following constraint") ] - "Add type annotation ‘[Char]’ to ‘\"debug\"’" - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "module A (f) where" - , "" - , "import Debug.Trace" - , "" - , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: [Char])))" - ]) - ] - where - testFor source diag expectedTitle expectedResult = do - docId <- createDoc "A.hs" "haskell" source - expectDiagnostics [ ("A.hs", diag) ] - - (action, title) <- extractCodeAction docId "Add type annotation" - - liftIO $ title @?= expectedTitle - executeCodeAction action - contentAfterAction <- documentContents docId - liftIO $ contentAfterAction @?= expectedResult - - extractCodeAction docId actionPrefix = do - [action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R 0 0 0 0) [actionPrefix] - return (action, actionTitle) - - -fixConstructorImportTests :: TestTree -fixConstructorImportTests = testGroup "fix import actions" - [ testSession "fix constructor import" $ template - (T.unlines - [ "module ModuleA where" - , "data A = Constructor" - ]) - (T.unlines - [ "module ModuleB where" - , "import ModuleA(Constructor)" - ]) - (Range (Position 1 10) (Position 1 11)) - "Fix import of A(Constructor)" - (T.unlines - [ "module ModuleB where" - , "import ModuleA(A(Constructor))" - ]) - ] - where - template contentA contentB range expectedAction expectedContentB = do - _docA <- createDoc "ModuleA.hs" "haskell" contentA - docB <- createDoc "ModuleB.hs" "haskell" contentB - _diags <- waitForDiagnostics - InR action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> - getCodeActions docB range - liftIO $ expectedAction @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ expectedContentB @=? contentAfterAction - -importRenameActionTests :: TestTree -importRenameActionTests = testGroup "import rename actions" - [ testSession "Data.Mape -> Data.Map" $ check "Map" - , testSession "Data.Mape -> Data.Maybe" $ check "Maybe" ] where - check modname = do - let content = T.unlines - [ "module Testing where" - , "import Data.Mape" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16)) - let [changeToMap] = [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ] - executeCodeAction changeToMap - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "import Data." <> modname - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - -fillTypedHoleTests :: TestTree -fillTypedHoleTests = let - - sourceCode :: T.Text -> T.Text -> T.Text -> T.Text - sourceCode a b c = T.unlines - [ "module Testing where" - , "" - , "globalConvert :: Int -> String" - , "globalConvert = undefined" - , "" - , "globalInt :: Int" - , "globalInt = 3" - , "" - , "bar :: Int -> Int -> String" - , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ") where" - , " localConvert = (flip replicate) 'x'" - , "" - , "foo :: () -> Int -> String" - , "foo = undefined" - - ] - - check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree - check actionTitle - oldA oldB oldC - newA newB newC = testSession (T.unpack actionTitle) $ do - let originalCode = sourceCode oldA oldB oldC - let expectedCode = sourceCode newA newB newC - doc <- createDoc "Testing.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound)) - chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands - executeCodeAction chosenAction - modifiedCode <- documentContents doc - liftIO $ expectedCode @=? modifiedCode - in - testGroup "fill typed holes" - [ check "replace _ with show" - "_" "n" "n" - "show" "n" "n" - - , check "replace _ with globalConvert" - "_" "n" "n" - "globalConvert" "n" "n" - - , check "replace _convertme with localConvert" - "_convertme" "n" "n" - "localConvert" "n" "n" - - , check "replace _b with globalInt" - "_a" "_b" "_c" - "_a" "globalInt" "_c" - - , check "replace _c with globalInt" - "_a" "_b" "_c" - "_a" "_b" "globalInt" - - , check "replace _c with parameterInt" - "_a" "_b" "_c" - "_a" "_b" "parameterInt" - , check "replace _ with foo _" - "_" "n" "n" - "(foo _)" "n" "n" - , testSession "replace _toException with E.toException" $ do - let mkDoc x = T.unlines - [ "module Testing where" - , "import qualified Control.Exception as E" - , "ioToSome :: E.IOException -> E.SomeException" - , "ioToSome = " <> x ] - doc <- createDoc "Test.hs" "haskell" $ mkDoc "_toException" - _ <- waitForDiagnostics - actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBound)) - chosen <- liftIO $ pickActionWithTitle "replace _toException with E.toException" actions - executeCodeAction chosen - modifiedCode <- documentContents doc - liftIO $ mkDoc "E.toException" @=? modifiedCode - ] - -addInstanceConstraintTests :: TestTree -addInstanceConstraintTests = let - missingConstraintSourceCode :: Maybe T.Text -> T.Text - missingConstraintSourceCode mConstraint = - let constraint = maybe "" (<> " => ") mConstraint - in T.unlines - [ "module Testing where" - , "" - , "data Wrap a = Wrap a" - , "" - , "instance " <> constraint <> "Eq (Wrap a) where" - , " (Wrap x) == (Wrap y) = x == y" - ] - - incompleteConstraintSourceCode :: Maybe T.Text -> T.Text - incompleteConstraintSourceCode mConstraint = - let constraint = maybe "Eq a" (\c -> "(Eq a, " <> c <> ")") mConstraint - in T.unlines - [ "module Testing where" - , "" - , "data Pair a b = Pair a b" - , "" - , "instance " <> constraint <> " => Eq (Pair a b) where" - , " (Pair x y) == (Pair x' y') = x == x' && y == y'" - ] - - incompleteConstraintSourceCode2 :: Maybe T.Text -> T.Text - incompleteConstraintSourceCode2 mConstraint = - let constraint = maybe "(Eq a, Eq b)" (\c -> "(Eq a, Eq b, " <> c <> ")") mConstraint - in T.unlines - [ "module Testing where" - , "" - , "data Three a b c = Three a b c" - , "" - , "instance " <> constraint <> " => Eq (Three a b c) where" - , " (Three x y z) == (Three x' y' z') = x == x' && y == y' && z == z'" - ] - - check :: T.Text -> T.Text -> T.Text -> TestTree - check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do - doc <- createDoc "Testing.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 6 0) (Position 6 68)) - chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands - executeCodeAction chosenAction - modifiedCode <- documentContents doc - liftIO $ expectedCode @=? modifiedCode - - in testGroup "add instance constraint" - [ check - "Add `Eq a` to the context of the instance declaration" - (missingConstraintSourceCode Nothing) - (missingConstraintSourceCode $ Just "Eq a") - , check - "Add `Eq b` to the context of the instance declaration" - (incompleteConstraintSourceCode Nothing) - (incompleteConstraintSourceCode $ Just "Eq b") - , check - "Add `Eq c` to the context of the instance declaration" - (incompleteConstraintSourceCode2 Nothing) - (incompleteConstraintSourceCode2 $ Just "Eq c") - ] - -addFunctionConstraintTests :: TestTree -addFunctionConstraintTests = let - missingConstraintSourceCode :: T.Text -> T.Text - missingConstraintSourceCode constraint = - T.unlines - [ "module Testing where" - , "" - , "eq :: " <> constraint <> "a -> a -> Bool" - , "eq x y = x == y" - ] - - missingConstraintWithForAllSourceCode :: T.Text -> T.Text - missingConstraintWithForAllSourceCode constraint = - T.unlines - [ "{-# LANGUAGE ExplicitForAll #-}" - , "module Testing where" - , "" - , "eq :: forall a. " <> constraint <> "a -> a -> Bool" - , "eq x y = x == y" - ] - - incompleteConstraintWithForAllSourceCode :: T.Text -> T.Text - incompleteConstraintWithForAllSourceCode constraint = - T.unlines - [ "{-# LANGUAGE ExplicitForAll #-}" - , "module Testing where" - , "" - , "data Pair a b = Pair a b" - , "" - , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool" - , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" - ] - - incompleteConstraintSourceCode :: T.Text -> T.Text - incompleteConstraintSourceCode constraint = - T.unlines - [ "module Testing where" - , "" - , "data Pair a b = Pair a b" - , "" - , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool" - , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" - ] - - incompleteConstraintSourceCode2 :: T.Text -> T.Text - incompleteConstraintSourceCode2 constraint = - T.unlines - [ "module Testing where" - , "" - , "data Three a b c = Three a b c" - , "" - , "eq :: " <> constraint <> " => Three a b c -> Three a b c -> Bool" - , "eq (Three x y z) (Three x' y' z') = x == x' && y == y' && z == z'" - ] - - incompleteConstraintSourceCodeWithExtraCharsInContext :: T.Text -> T.Text - incompleteConstraintSourceCodeWithExtraCharsInContext constraint = - T.unlines - [ "module Testing where" - , "" - , "data Pair a b = Pair a b" - , "" - , "eq :: ( " <> constraint <> " ) => Pair a b -> Pair a b -> Bool" - , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" - ] - - incompleteConstraintSourceCodeWithNewlinesInTypeSignature :: T.Text -> T.Text - incompleteConstraintSourceCodeWithNewlinesInTypeSignature constraint = - T.unlines - [ "module Testing where" - , "data Pair a b = Pair a b" - , "eq " - , " :: (" <> constraint <> ")" - , " => Pair a b -> Pair a b -> Bool" - , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" - ] - - missingMonadConstraint constraint = T.unlines - [ "module Testing where" - , "f :: " <> constraint <> "m ()" - , "f = do " - , " return ()" - ] - - in testGroup "add function constraint" - [ checkCodeAction - "no preexisting constraint" - "Add `Eq a` to the context of the type signature for `eq`" - (missingConstraintSourceCode "") - (missingConstraintSourceCode "Eq a => ") - , checkCodeAction - "no preexisting constraint, with forall" - "Add `Eq a` to the context of the type signature for `eq`" - (missingConstraintWithForAllSourceCode "") - (missingConstraintWithForAllSourceCode "Eq a => ") - , checkCodeAction - "preexisting constraint, no parenthesis" - "Add `Eq b` to the context of the type signature for `eq`" - (incompleteConstraintSourceCode "Eq a") - (incompleteConstraintSourceCode "(Eq a, Eq b)") - , checkCodeAction - "preexisting constraints in parenthesis" - "Add `Eq c` to the context of the type signature for `eq`" - (incompleteConstraintSourceCode2 "(Eq a, Eq b)") - (incompleteConstraintSourceCode2 "(Eq a, Eq b, Eq c)") - , checkCodeAction - "preexisting constraints with forall" - "Add `Eq b` to the context of the type signature for `eq`" - (incompleteConstraintWithForAllSourceCode "Eq a") - (incompleteConstraintWithForAllSourceCode "(Eq a, Eq b)") - , checkCodeAction - "preexisting constraint, with extra spaces in context" - "Add `Eq b` to the context of the type signature for `eq`" - (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a") - (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a, Eq b") - , checkCodeAction - "preexisting constraint, with newlines in type signature" - "Add `Eq b` to the context of the type signature for `eq`" - (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a") - (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a, Eq b") - , checkCodeAction - "missing Monad constraint" - "Add `Monad m` to the context of the type signature for `f`" - (missingMonadConstraint "") - (missingMonadConstraint "Monad m => ") - ] - -checkCodeAction :: String -> T.Text -> T.Text -> T.Text -> TestTree -checkCodeAction testName actionTitle originalCode expectedCode = testSession testName $ do - doc <- createDoc "Testing.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 6 0) (Position 6 maxBound)) - chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands - executeCodeAction chosenAction - modifiedCode <- documentContents doc - liftIO $ expectedCode @=? modifiedCode - -addImplicitParamsConstraintTests :: TestTree -addImplicitParamsConstraintTests = - testGroup - "add missing implicit params constraints" - [ testGroup - "introduced" - [ let ex ctxtA = exampleCode "?a" ctxtA "" - in checkCodeAction "at top level" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()"), - let ex ctxA = exampleCode "x where x = ?a" ctxA "" - in checkCodeAction "in nested def" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()") - ], - testGroup - "inherited" - [ let ex = exampleCode "()" "?a::()" - in checkCodeAction - "with preexisting context" - "Add `?a::()` to the context of the type signature for `fCaller`" - (ex "Eq ()") - (ex "Eq (), ?a::()"), - let ex = exampleCode "()" "?a::()" - in checkCodeAction "without preexisting context" "Add ?a::() to the context of fCaller" (ex "") (ex "?a::()") - ] - ] - where - mkContext "" = "" - mkContext contents = "(" <> contents <> ") => " - - exampleCode bodyBase contextBase contextCaller = - T.unlines - [ "{-# LANGUAGE FlexibleContexts, ImplicitParams #-}", - "module Testing where", - "fBase :: " <> mkContext contextBase <> "()", - "fBase = " <> bodyBase, - "fCaller :: " <> mkContext contextCaller <> "()", - "fCaller = fBase" - ] -removeRedundantConstraintsTests :: TestTree -removeRedundantConstraintsTests = let - header = - [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" - , "module Testing where" - , "" - ] - - redundantConstraintsCode :: Maybe T.Text -> T.Text - redundantConstraintsCode mConstraint = - let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint - in T.unlines $ header <> - [ "foo :: " <> constraint <> "a -> a" - , "foo = id" - ] - - redundantMixedConstraintsCode :: Maybe T.Text -> T.Text - redundantMixedConstraintsCode mConstraint = - let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint - in T.unlines $ header <> - [ "foo :: " <> constraint <> " => a -> Bool" - , "foo x = x == 1" - ] - - typeSignatureSpaces :: T.Text - typeSignatureSpaces = T.unlines $ header <> - [ "foo :: (Num a, Eq a, Monoid a) => a -> Bool" - , "foo x = x == 1" - ] - - typeSignatureMultipleLines :: T.Text - typeSignatureMultipleLines = T.unlines $ header <> - [ "foo :: (Num a, Eq a, Monoid a)" - , "=> a -> Bool" - , "foo x = x == 1" - ] - - check :: T.Text -> T.Text -> T.Text -> TestTree - check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do - doc <- createDoc "Testing.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 4 0) (Position 4 maxBound)) - chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands - executeCodeAction chosenAction - modifiedCode <- documentContents doc - liftIO $ expectedCode @=? modifiedCode - - checkPeculiarFormatting :: String -> T.Text -> TestTree - checkPeculiarFormatting title code = testSession title $ do - doc <- createDoc "Testing.hs" "haskell" code - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 4 0) (Position 4 maxBound)) - liftIO $ assertBool "Found some actions" (null actionsOrCommands) - - in testGroup "remove redundant function constraints" - [ check - "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" - (redundantConstraintsCode $ Just "Eq a") - (redundantConstraintsCode Nothing) - , check - "Remove redundant constraints `(Eq a, Monoid a)` from the context of the type signature for `foo`" - (redundantConstraintsCode $ Just "(Eq a, Monoid a)") - (redundantConstraintsCode Nothing) - , check - "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`" - (redundantMixedConstraintsCode $ Just "Monoid a, Show a") - (redundantMixedConstraintsCode Nothing) - , checkPeculiarFormatting - "should do nothing when constraints contain an arbitrary number of spaces" - typeSignatureSpaces - , checkPeculiarFormatting - "should do nothing when constraints contain line feeds" - typeSignatureMultipleLines - ] - -addSigActionTests :: TestTree -addSigActionTests = let - header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" - moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where" - before def = T.unlines [header, moduleH, def] - after' def sig = T.unlines [header, moduleH, sig, def] - - def >:: sig = testSession (T.unpack def) $ do - let originalCode = before def - let expectedCode = after' def sig - doc <- createDoc "Sigs.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound)) - chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands - executeCodeAction chosenAction - modifiedCode <- documentContents doc - liftIO $ expectedCode @=? modifiedCode - in - testGroup "add signature" - [ "abc = True" >:: "abc :: Bool" - , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a" - , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String" - , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool" - , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a" - , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2" - , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a" - ] - -exportUnusedTests :: TestTree -exportUnusedTests = testGroup "export unused actions" - [ testGroup "don't want suggestion" - [ testSession "implicit exports" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# OPTIONS_GHC -Wmissing-signatures #-}" - , "module A where" - , "foo = id"]) - (R 3 0 3 3) - "Export ‘foo’" - Nothing -- codeaction should not be available - , testSession "not top-level" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (foo,bar) where" - , "foo = ()" - , " where bar = ()" - , "bar = ()"]) - (R 2 0 2 11) - "Export ‘bar’" - Nothing - , testSession "type is exported but not the constructor of same name" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (Foo) where" - , "data Foo = Foo"]) - (R 2 0 2 8) - "Export ‘Foo’" - Nothing -- codeaction should not be available - , testSession "unused data field" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (Foo(Foo)) where" - , "data Foo = Foo {foo :: ()}"]) - (R 2 0 2 20) - "Export ‘foo’" - Nothing -- codeaction should not be available - ] - , testGroup "want suggestion" - [ testSession "empty exports" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (" - , ") where" - , "foo = id"]) - (R 3 0 3 3) - "Export ‘foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (" - , "foo) where" - , "foo = id"]) - , testSession "single line explicit exports" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (foo) where" - , "foo = id" - , "bar = foo"]) - (R 3 0 3 3) - "Export ‘bar’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (foo,bar) where" - , "foo = id" - , "bar = foo"]) - , testSession "multi line explicit exports" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A" - , " (" - , " foo) where" - , "foo = id" - , "bar = foo"]) - (R 5 0 5 3) - "Export ‘bar’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A" - , " (" - , " foo,bar) where" - , "foo = id" - , "bar = foo"]) - , testSession "export list ends in comma" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A" - , " (foo," - , " ) where" - , "foo = id" - , "bar = foo"]) - (R 4 0 4 3) - "Export ‘bar’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A" - , " (foo," - , " bar) where" - , "foo = id" - , "bar = foo"]) - , testSession "unused pattern synonym" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE PatternSynonyms #-}" - , "module A () where" - , "pattern Foo a <- (a, _)"]) - (R 3 0 3 10) - "Export ‘Foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE PatternSynonyms #-}" - , "module A (pattern Foo) where" - , "pattern Foo a <- (a, _)"]) - , testSession "unused data type" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A () where" - , "data Foo = Foo"]) - (R 2 0 2 7) - "Export ‘Foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (Foo(..)) where" - , "data Foo = Foo"]) - , testSession "unused newtype" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A () where" - , "newtype Foo = Foo ()"]) - (R 2 0 2 10) - "Export ‘Foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (Foo(..)) where" - , "newtype Foo = Foo ()"]) - , testSession "unused type synonym" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A () where" - , "type Foo = ()"]) - (R 2 0 2 7) - "Export ‘Foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (Foo) where" - , "type Foo = ()"]) - , testSession "unused type family" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeFamilies #-}" - , "module A () where" - , "type family Foo p"]) - (R 3 0 3 15) - "Export ‘Foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeFamilies #-}" - , "module A (Foo(..)) where" - , "type family Foo p"]) - , testSession "unused typeclass" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A () where" - , "class Foo a"]) - (R 2 0 2 8) - "Export ‘Foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (Foo(..)) where" - , "class Foo a"]) - , testSession "infix" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A () where" - , "a `f` b = ()"]) - (R 2 0 2 11) - "Export ‘f’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (f) where" - , "a `f` b = ()"]) - , testSession "function operator" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A () where" - , "(<|) = ($)"]) - (R 2 0 2 9) - "Export ‘<|’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A ((<|)) where" - , "(<|) = ($)"]) - , testSession "type synonym operator" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A () where" - , "type (:<) = ()"]) - (R 3 0 3 13) - "Export ‘:<’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A ((:<)) where" - , "type (:<) = ()"]) - , testSession "type family operator" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeFamilies #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A () where" - , "type family (:<)"]) - (R 4 0 4 15) - "Export ‘:<’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeFamilies #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A (type (:<)(..)) where" - , "type family (:<)"]) - , testSession "typeclass operator" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A () where" - , "class (:<) a"]) - (R 3 0 3 11) - "Export ‘:<’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A (type (:<)(..)) where" - , "class (:<) a"]) - , testSession "newtype operator" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A () where" - , "newtype (:<) = Foo ()"]) - (R 3 0 3 20) - "Export ‘:<’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A (type (:<)(..)) where" - , "newtype (:<) = Foo ()"]) - , testSession "data type operator" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A () where" - , "data (:<) = Foo ()"]) - (R 3 0 3 17) - "Export ‘:<’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A (type (:<)(..)) where" - , "data (:<) = Foo ()"]) - ] - ] - where - template doc range = exportTemplate (Just range) doc - -exportTemplate :: Maybe Range -> T.Text -> T.Text -> Maybe T.Text -> Session () -exportTemplate mRange initialContent expectedAction expectedContents = do - doc <- createDoc "A.hs" "haskell" initialContent - _ <- waitForDiagnostics - actions <- case mRange of - Nothing -> getAllCodeActions doc - Just range -> getCodeActions doc range - case expectedContents of - Just content -> do - action <- liftIO $ pickActionWithTitle expectedAction actions - executeCodeAction action - contentAfterAction <- documentContents doc - liftIO $ content @=? contentAfterAction - Nothing -> - liftIO $ [_title | InR CodeAction{_title} <- actions, _title == expectedAction ] @?= [] - -removeExportTests :: TestTree -removeExportTests = testGroup "remove export actions" - [ testSession "single export" $ template - (T.unlines - [ "module A ( a ) where" - , "b :: ()" - , "b = ()"]) - "Remove ‘a’ from export" - (Just $ T.unlines - [ "module A ( ) where" - , "b :: ()" - , "b = ()"]) - , testSession "ending comma" $ template - (T.unlines - [ "module A ( a, ) where" - , "b :: ()" - , "b = ()"]) - "Remove ‘a’ from export" - (Just $ T.unlines - [ "module A ( ) where" - , "b :: ()" - , "b = ()"]) - , testSession "multiple exports" $ template - (T.unlines - [ "module A (a , c, b ) where" - , "a, c :: ()" - , "a = ()" - , "c = ()"]) - "Remove ‘b’ from export" - (Just $ T.unlines - [ "module A (a , c ) where" - , "a, c :: ()" - , "a = ()" - , "c = ()"]) - , testSession "not in scope constructor" $ template - (T.unlines - [ "module A (A (X,Y,Z,(:<)), ab) where" - , "data A = X Int | Y | (:<) Int" - , "ab :: ()" - , "ab = ()" - ]) - "Remove ‘Z’ from export" - (Just $ T.unlines - [ "module A (A (X,Y,(:<)), ab) where" - , "data A = X Int | Y | (:<) Int" - , "ab :: ()" - , "ab = ()"]) - , testSession "multiline export" $ template - (T.unlines - [ "module A (a" - , " , b" - , " , (:*:)" - , " , ) where" - , "a,b :: ()" - , "a = ()" - , "b = ()"]) - "Remove ‘:*:’ from export" - (Just $ T.unlines - [ "module A (a" - , " , b" - , " " - , " , ) where" - , "a,b :: ()" - , "a = ()" - , "b = ()"]) - , testSession "qualified re-export" $ template - (T.unlines - [ "module A (M.x,a) where" - , "import qualified Data.List as M" - , "a :: ()" - , "a = ()"]) - "Remove ‘M.x’ from export" - (Just $ T.unlines - [ "module A (a) where" - , "import qualified Data.List as M" - , "a :: ()" - , "a = ()"]) - , testSession "export module" $ template - (T.unlines - [ "module A (module B) where" - , "a :: ()" - , "a = ()"]) - "Remove ‘module B’ from export" - (Just $ T.unlines - [ "module A () where" - , "a :: ()" - , "a = ()"]) - , testSession "dodgy export" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A (A (..)) where" - , "data X = X" - , "type A = X"]) - "Remove ‘A(..)’ from export" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A () where" - , "data X = X" - , "type A = X"]) - , testSession "dodgy export" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A (A (..)) where" - , "data X = X" - , "type A = X"]) - "Remove ‘A(..)’ from export" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A () where" - , "data X = X" - , "type A = X"]) - , testSession "duplicate module export" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A (module L,module L) where" - , "import Data.List as L" - , "a :: ()" - , "a = ()"]) - "Remove ‘Module L’ from export" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A (module L) where" - , "import Data.List as L" - , "a :: ()" - , "a = ()"]) - , testSession "remove all exports single" $ template - (T.unlines - [ "module A (x) where" - , "a :: ()" - , "a = ()"]) - "Remove all redundant exports" - (Just $ T.unlines - [ "module A () where" - , "a :: ()" - , "a = ()"]) - , testSession "remove all exports two" $ template - (T.unlines - [ "module A (x,y) where" - , "a :: ()" - , "a = ()"]) - "Remove all redundant exports" - (Just $ T.unlines - [ "module A () where" - , "a :: ()" - , "a = ()"]) - , testSession "remove all exports three" $ template - (T.unlines - [ "module A (a,x,y) where" - , "a :: ()" - , "a = ()"]) - "Remove all redundant exports" - (Just $ T.unlines - [ "module A (a) where" - , "a :: ()" - , "a = ()"]) - , testSession "remove all exports composite" $ template - (T.unlines - [ "module A (x,y,b, module Ls, a, A(X,getW, Y, Z,(:-),getV), (-+), B(B)) where" - , "data A = X {getV :: Int} | Y {getV :: Int}" - , "data B = B" - , "a,b :: ()" - , "a = ()" - , "b = ()"]) - "Remove all redundant exports" - (Just $ T.unlines - [ "module A (b, a, A(X, Y,getV), B(B)) where" - , "data A = X {getV :: Int} | Y {getV :: Int}" - , "data B = B" - , "a,b :: ()" - , "a = ()" - , "b = ()"]) - ] - where - template = exportTemplate Nothing - -addSigLensesTests :: TestTree -addSigLensesTests = let - missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}" - notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}" - moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where\nimport qualified Data.Complex as C" - other = T.unlines ["f :: Integer -> Integer", "f x = 3"] - before withMissing def - = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other] - after' withMissing def sig - = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, sig, def, other] - - sigSession withMissing def sig = testSession (T.unpack def) $ do - let originalCode = before withMissing def - let expectedCode = after' withMissing def sig - doc <- createDoc "Sigs.hs" "haskell" originalCode - [CodeLens {_command = Just c}] <- getCodeLenses doc - executeCommand c - modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc) - liftIO $ expectedCode @=? modifiedCode - in - testGroup "add signature" - [ testGroup title - [ sigSession enableWarnings "abc = True" "abc :: Bool" - , sigSession enableWarnings "foo a b = a + b" "foo :: Num a => a -> a -> a" - , sigSession enableWarnings "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String" - , sigSession enableWarnings "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool" - , sigSession enableWarnings "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a" - , sigSession enableWarnings "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2" - , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a" - , sigSession enableWarnings "qualifiedSigTest= C.realPart" "qualifiedSigTest :: C.Complex a -> a" - ] - | (title, enableWarnings) <- - [("with warnings enabled", True) - ,("with warnings disabled", False) - ] - ] - -linkToLocation :: [LocationLink] -> [Location] -linkToLocation = map (\LocationLink{_targetUri,_targetRange} -> Location _targetUri _targetRange) - -checkDefs :: [Location] |? [LocationLink] -> Session [Expect] -> Session () -checkDefs (either id linkToLocation . toEither -> defs) mkExpectations = traverse_ check =<< mkExpectations where - check (ExpectRange expectedRange) = do - assertNDefinitionsFound 1 defs - assertRangeCorrect (head defs) expectedRange - check (ExpectLocation expectedLocation) = do - assertNDefinitionsFound 1 defs - liftIO $ do - canonActualLoc <- canonicalizeLocation (head defs) - canonExpectedLoc <- canonicalizeLocation expectedLocation - canonActualLoc @?= canonExpectedLoc - check ExpectNoDefinitions = do - assertNDefinitionsFound 0 defs - check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file" - check _ = pure () -- all other expectations not relevant to getDefinition - - assertNDefinitionsFound :: Int -> [a] -> Session () - assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs) - - assertRangeCorrect Location{_range = foundRange} expectedRange = - liftIO $ expectedRange @=? foundRange - -canonicalizeLocation :: Location -> IO Location -canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range - -findDefinitionAndHoverTests :: TestTree -findDefinitionAndHoverTests = let - - tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> Session [Expect] -> String -> TestTree - tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do - - -- Dirty the cache to check that definitions work even in the presence of iface files - liftIO $ runInDir dir $ do - let fooPath = dir "Foo.hs" - fooSource <- liftIO $ readFileUtf8 fooPath - fooDoc <- createDoc fooPath "haskell" fooSource - _ <- getHover fooDoc $ Position 4 3 - closeDoc fooDoc - - doc <- openTestDataDoc (dir sourceFilePath) - waitForProgressDone - found <- get doc pos - check found targetRange - - - - checkHover :: Maybe Hover -> Session [Expect] -> Session () - checkHover hover expectations = traverse_ check =<< expectations where - - check expected = - case hover of - Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" - Just Hover{_contents = (HoverContents MarkupContent{_value = standardizeQuotes -> msg}) - ,_range = rangeInHover } -> - case expected of - ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg - ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg - ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets - ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover - _ -> pure () -- all other expectations not relevant to hover - _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover - - extractLineColFromHoverMsg :: T.Text -> [T.Text] - extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":") - - checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () - checkHoverRange expectedRange rangeInHover msg = - let - lineCol = extractLineColFromHoverMsg msg - -- looks like hovers use 1-based numbering while definitions use 0-based - -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. - adjust Position{_line = l, _character = c} = - Position{_line = l + 1, _character = c + 1} - in - case map (read . T.unpack) lineCol of - [l,c] -> liftIO $ adjust (_start expectedRange) @=? Position l c - _ -> liftIO $ assertFailure $ - "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> - "\n but got: " <> show (msg, rangeInHover) - - assertFoundIn :: T.Text -> T.Text -> Assertion - assertFoundIn part whole = assertBool - (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole) - (part `T.isInfixOf` whole) - - sourceFilePath = T.unpack sourceFileName - sourceFileName = "GotoHover.hs" - - mkFindTests tests = testGroup "get" - [ testGroup "definition" $ mapMaybe fst tests - , testGroup "hover" $ mapMaybe snd tests - , checkFileCompiles sourceFilePath $ - expectDiagnostics - [ ( "GotoHover.hs", [(DsError, (62, 7), "Found hole: _")]) ] - , testGroup "type-definition" typeDefinitionTests ] - - typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 (pure tcData) "Saturated data con" - , tst (getTypeDefinitions, checkDefs) aL20 (pure [ExpectNoDefinitions]) "Polymorphic variable"] - - test runDef runHover look expect = testM runDef runHover look (return expect) - - testM runDef runHover look expect title = - ( runDef $ tst def look expect title - , runHover $ tst hover look expect title ) where - def = (getDefinitions, checkDefs) - hover = (getHover , checkHover) - - -- search locations expectations on results - fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR] - fffL8 = Position 12 4 ; - fffL14 = Position 18 7 ; - aL20 = Position 19 15 - aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3] - dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16] - dcL12 = Position 16 11 ; - xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ", "GHC.Types"]] - tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]] - vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6] - opL16 = Position 20 15 ; op = [mkR 21 2 21 4] - opL18 = Position 22 22 ; opp = [mkR 22 13 22 17] - aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11] - b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7] - xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["pack", ":: String -> Text", "Data.Text"]] - clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]] - clL25 = Position 29 9 - eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num"]] - dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21] - dnbL30 = Position 34 23 - lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27] - lclL33 = Position 37 22 - mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14] - mclL37 = Position 41 1 - spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]] - docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]] - ; constr = [ExpectHoverText ["Monad m"]] - eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]] - intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]] - tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]] - intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]] - chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]] - txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]] - lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]] - outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5] - innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7] - holeL60 = Position 62 7 ; hleInfo = [ExpectHoverText ["_ ::"]] - cccL17 = Position 17 16 ; docLink = [ExpectHoverText ["[Documentation](file:///"]] - imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3] - reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 0 3 14] - thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]] - in - mkFindTests - -- def hover look expect - [ test yes yes fffL4 fff "field in record definition" - , test yes yes fffL8 fff "field in record construction #1102" - , test yes yes fffL14 fff "field name used as accessor" -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs - , test yes yes aaaL14 aaa "top-level name" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes dcL7 tcDC "data constructor record #1029" - , test yes yes dcL12 tcDC "data constructor plain" -- https://github.com/haskell/ghcide/pull/121 - , test yes yes tcL6 tcData "type constructor #1028" -- https://github.com/haskell/ghcide/pull/147 - , test broken yes xtcL5 xtc "type constructor external #717,1028" - , test broken yes xvL20 xvMsg "value external package #717" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes vvL16 vv "plain parameter" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes aL18 apmp "pattern match name" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes opL16 op "top-level operator #713" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes opL18 opp "parameter operator" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes b'L19 bp "name in backticks" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes clL23 cls "class in instance declaration #1027" - , test yes yes clL25 cls "class in signature #1027" -- https://github.com/haskell/ghcide/pull/147 - , test broken yes eclL15 ecls "external class in signature #717,1027" - , test yes yes dnbL29 dnb "do-notation bind #1073" - , test yes yes dnbL30 dnb "do-notation lookup" - , test yes yes lcbL33 lcb "listcomp bind #1073" - , test yes yes lclL33 lcb "listcomp lookup" - , test yes yes mclL36 mcl "top-level fn 1st clause" - , test yes yes mclL37 mcl "top-level fn 2nd clause #1030" -#if MIN_GHC_API_VERSION(8,10,0) - , test yes yes spaceL37 space "top-level fn on space #1002" -#else - , test yes broken spaceL37 space "top-level fn on space #1002" -#endif - , test no yes docL41 doc "documentation #1129" - , test no yes eitL40 kindE "kind of Either #1017" - , test no yes intL40 kindI "kind of Int #1017" - , test no broken tvrL40 kindV "kind of (* -> *) type variable #1017" - , test no broken intL41 litI "literal Int in hover info #1016" - , test no broken chrL36 litC "literal Char in hover info #1016" - , test no broken txtL8 litT "literal Text in hover info #1016" - , test no broken lstL43 litL "literal List in hover info #1016" - , test no broken docL41 constr "type constraint in hover info #1012" - , test broken broken outL45 outSig "top-level signature #767" - , test broken broken innL48 innSig "inner signature #767" - , test no yes holeL60 hleInfo "hole without internal name #831" - , test no skip cccL17 docLink "Haddock html links" - , testM yes yes imported importedSig "Imported symbol" - , testM yes yes reexported reexportedSig "Imported symbol (reexported)" - , test no yes thLocL57 thLoc "TH Splice Hover" - ] - where yes, broken :: (TestTree -> Maybe TestTree) - yes = Just -- test should run and pass - broken = Just . (`xfail` "known broken") - no = const Nothing -- don't run this test at all - skip = const Nothing -- unreliable, don't run - -checkFileCompiles :: FilePath -> Session () -> TestTree -checkFileCompiles fp diag = - testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do - void (openTestDataDoc (dir fp)) - diag - -pluginSimpleTests :: TestTree -pluginSimpleTests = - ignoreInWindowsForGHC88And810 $ - testSessionWithExtraFiles "plugin" "simple plugin" $ \dir -> do - _ <- openDoc (dir "KnownNat.hs") "haskell" - liftIO $ writeFile (dir"hie.yaml") - "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}" - - expectDiagnostics - [ ( "KnownNat.hs", - [(DsError, (9, 15), "Variable not in scope: c")] - ) - ] - -pluginParsedResultTests :: TestTree -pluginParsedResultTests = - ignoreInWindowsForGHC88And810 $ - testSessionWithExtraFiles "plugin" "parsedResultAction plugin" $ \dir -> do - _ <- openDoc (dir "RecordDot.hs") "haskell" - expectNoMoreDiagnostics 2 - -cppTests :: TestTree -cppTests = - testGroup "cpp" - [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do - let content = - T.unlines - [ "{-# LANGUAGE CPP #-}", - "module Testing where", - "#ifdef FOO", - "foo = 42" - ] - -- The error locations differ depending on which C-preprocessor is used. - -- Some give the column number and others don't (hence -1). Assert either - -- of them. - (run $ expectError content (2, -1)) - `catch` ( \e -> do - let _ = e :: HUnitFailure - run $ expectError content (2, 1) - ) - , testSessionWait "cpp-ghcide" $ do - _ <- createDoc "A.hs" "haskell" $ T.unlines - ["{-# LANGUAGE CPP #-}" - ,"main =" - ,"#ifdef __GHCIDE__" - ," worked" - ,"#else" - ," failed" - ,"#endif" - ] - expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])] - ] - where - expectError :: T.Text -> Cursor -> Session () - expectError content cursor = do - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs", - [(DsError, cursor, "error: unterminated")] - ) - ] - expectNoMoreDiagnostics 0.5 - -preprocessorTests :: TestTree -preprocessorTests = testSessionWait "preprocessor" $ do - let content = - T.unlines - [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}" - , "module Testing where" - , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs", - [(DsError, (2, 8), "Variable not in scope: z")] - ) - ] - - -safeTests :: TestTree -safeTests = - testGroup - "SafeHaskell" - [ -- Test for https://github.com/haskell/ghcide/issues/424 - testSessionWait "load" $ do - let sourceA = - T.unlines - ["{-# LANGUAGE Trustworthy #-}" - ,"module A where" - ,"import System.IO.Unsafe" - ,"import System.IO ()" - ,"trustWorthyId :: a -> a" - ,"trustWorthyId i = unsafePerformIO $ do" - ," putStrLn \"I'm safe\"" - ," return i"] - sourceB = - T.unlines - ["{-# LANGUAGE Safe #-}" - ,"module B where" - ,"import A" - ,"safeId :: a -> a" - ,"safeId = trustWorthyId" - ] - - _ <- createDoc "A.hs" "haskell" sourceA - _ <- createDoc "B.hs" "haskell" sourceB - expectNoMoreDiagnostics 1 ] - -thTests :: TestTree -thTests = - testGroup - "TemplateHaskell" - [ -- Test for https://github.com/haskell/ghcide/pull/212 - testSessionWait "load" $ do - let sourceA = - T.unlines - [ "{-# LANGUAGE PackageImports #-}", - "{-# LANGUAGE TemplateHaskell #-}", - "module A where", - "import \"template-haskell\" Language.Haskell.TH", - "a :: Integer", - "a = $(litE $ IntegerL 3)" - ] - sourceB = - T.unlines - [ "{-# LANGUAGE PackageImports #-}", - "{-# LANGUAGE TemplateHaskell #-}", - "module B where", - "import A", - "import \"template-haskell\" Language.Haskell.TH", - "b :: Integer", - "b = $(litE $ IntegerL $ a) + n" - ] - _ <- createDoc "A.hs" "haskell" sourceA - _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ] - , testSessionWait "newtype-closure" $ do - let sourceA = - T.unlines - [ "{-# LANGUAGE DeriveDataTypeable #-}" - ,"{-# LANGUAGE TemplateHaskell #-}" - ,"module A (a) where" - ,"import Data.Data" - ,"import Language.Haskell.TH" - ,"newtype A = A () deriving (Data)" - ,"a :: ExpQ" - ,"a = [| 0 |]"] - let sourceB = - T.unlines - [ "{-# LANGUAGE TemplateHaskell #-}" - ,"module B where" - ,"import A" - ,"b :: Int" - ,"b = $( a )" ] - _ <- createDoc "A.hs" "haskell" sourceA - _ <- createDoc "B.hs" "haskell" sourceB - return () - , thReloadingTest False - , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True - -- Regression test for https://github.com/haskell/haskell-language-server/issues/891 - , thLinkingTest False - , ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True - , testSessionWait "findsTHIdentifiers" $ do - let sourceA = - T.unlines - [ "{-# LANGUAGE TemplateHaskell #-}" - , "module A (a) where" - , "a = [| glorifiedID |]" - , "glorifiedID :: a -> a" - , "glorifiedID = id" ] - let sourceB = - T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "{-# LANGUAGE TemplateHaskell #-}" - , "module B where" - , "import A" - , "main = $a (putStrLn \"success!\")"] - _ <- createDoc "A.hs" "haskell" sourceA - _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics [ ( "B.hs", [(DsWarning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ] - , ignoreInWindowsForGHC88 $ testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do - - -- This test defines a TH value with the meaning "data A = A" in A.hs - -- Loads and export the template in B.hs - -- And checks wether the constructor A can be loaded in C.hs - -- This test does not fail when either A and B get manually loaded before C.hs - -- or when we remove the seemingly unnecessary TH pragma from C.hs - - let cPath = dir "C.hs" - _ <- openDoc cPath "haskell" - expectDiagnostics [ ( cPath, [(DsWarning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ] - ] - --- | test that TH is reevaluated on typecheck -thReloadingTest :: Bool -> TestTree -thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do - - let aPath = dir "THA.hs" - bPath = dir "THB.hs" - cPath = dir "THC.hs" - - aSource <- liftIO $ readFileUtf8 aPath -- th = [d|a = ()|] - bSource <- liftIO $ readFileUtf8 bPath -- $th - cSource <- liftIO $ readFileUtf8 cPath -- c = a :: () - - adoc <- createDoc aPath "haskell" aSource - bdoc <- createDoc bPath "haskell" bSource - cdoc <- createDoc cPath "haskell" cSource - - expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])] - - -- Change th from () to Bool - let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"] - changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource'] - -- generate an artificial warning to avoid timing out if the TH change does not propagate - changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing $ cSource <> "\nfoo=()"] - - -- Check that the change propagates to C - expectDiagnostics - [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) - ,("THC.hs", [(DsWarning, (6,0), "Top-level binding")]) - ,("THB.hs", [(DsWarning, (4,0), "Top-level binding")]) - ] - - closeDoc adoc - closeDoc bdoc - closeDoc cdoc - where - name = "reloading-th-test" <> if unboxed then "-unboxed" else "" - dir | unboxed = "THUnboxed" - | otherwise = "TH" - -thLinkingTest :: Bool -> TestTree -thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do - - let aPath = dir "THA.hs" - bPath = dir "THB.hs" - - aSource <- liftIO $ readFileUtf8 aPath -- th_a = [d|a :: ()|] - bSource <- liftIO $ readFileUtf8 bPath -- $th_a - - adoc <- createDoc aPath "haskell" aSource - bdoc <- createDoc bPath "haskell" bSource - - expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])] - - let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"] - changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource'] - - -- modify b too - let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"] - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing bSource'] - - expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])] - - closeDoc adoc - closeDoc bdoc - where - name = "th-linking-test" <> if unboxed then "-unboxed" else "" - dir | unboxed = "THUnboxed" - | otherwise = "TH" - -completionTests :: TestTree -completionTests - = testGroup "completion" - [ testGroup "non local" nonLocalCompletionTests - , testGroup "topLevel" topLevelCompletionTests - , testGroup "local" localCompletionTests - , testGroup "other" otherCompletionTests - ] - -completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe (List TextEdit))] -> TestTree -completionTest name src pos expected = testSessionWait name $ do - docId <- createDoc "A.hs" "haskell" (T.unlines src) - _ <- waitForDiagnostics - compls <- getCompletions docId pos - let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] - liftIO $ do - let emptyToMaybe x = if T.null x then Nothing else Just x - sortOn (Lens.view Lens._1) compls' @?= - sortOn (Lens.view Lens._1) [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] - forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs, _)) -> do - when expectedSig $ - assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) - when expectedDocs $ - assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) - -completionCommandTest :: - String -> - [T.Text] -> - Position -> - T.Text -> - [T.Text] -> - TestTree -completionCommandTest name src pos wanted expected = testSession name $ do - docId <- createDoc "A.hs" "haskell" (T.unlines src) - _ <- waitForDiagnostics - compls <- skipManyTill anyMessage (getCompletions docId pos) - let wantedC = find ( \case - CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x - _ -> False - ) compls - case wantedC of - Nothing -> - liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls] - Just CompletionItem {..} -> do - c <- assertJust "Expected a command" _command - executeCommand c - if src /= expected - then do - void $ skipManyTill anyMessage loggingNotification - modifiedCode <- skipManyTill anyMessage (getDocumentEdit docId) - liftIO $ modifiedCode @?= T.unlines expected - else do - expectMessages SWorkspaceApplyEdit 1 $ \edit -> - liftIO $ assertFailure $ "Expected no edit but got: " <> show edit - -completionNoCommandTest :: - String -> - [T.Text] -> - Position -> - T.Text -> - TestTree -completionNoCommandTest name src pos wanted = testSession name $ do - docId <- createDoc "A.hs" "haskell" (T.unlines src) - _ <- waitForDiagnostics - compls <- getCompletions docId pos - let wantedC = find ( \case - CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x - _ -> False - ) compls - case wantedC of - Nothing -> - liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls] - Just CompletionItem{..} -> liftIO . assertBool ("Expected no command but got: " <> show _command) $ null _command - - -topLevelCompletionTests :: [TestTree] -topLevelCompletionTests = [ - completionTest - "variable" - ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] - (Position 0 8) - [("xxx", CiFunction, "xxx", True, True, Nothing), - ("XxxCon", CiConstructor, "XxxCon", False, True, Nothing) - ], - completionTest - "constructor" - ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] - (Position 0 8) - [("xxx", CiFunction, "xxx", True, True, Nothing), - ("XxxCon", CiConstructor, "XxxCon", False, True, Nothing) - ], - completionTest - "class method" - ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"] - (Position 0 8) - [("xxx", CiFunction, "xxx", True, True, Nothing)], - completionTest - "type" - ["bar :: Xx", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] - (Position 0 9) - [("Xxx", CiStruct, "Xxx", False, True, Nothing)], - completionTest - "class" - ["bar :: Xx", "xxx = ()", "-- | haddock", "class Xxx a"] - (Position 0 9) - [("Xxx", CiClass, "Xxx", False, True, Nothing)], - completionTest - "records" - ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ] - (Position 1 19) - [("_personName", CiFunction, "_personName", False, True, Nothing), - ("_personAge", CiFunction, "_personAge", False, True, Nothing)], - completionTest - "recordsConstructor" - ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ] - (Position 1 19) - [("XyRecord", CiConstructor, "XyRecord", False, True, Nothing), - ("XyRecord", CiSnippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)] - ] - -localCompletionTests :: [TestTree] -localCompletionTests = [ - completionTest - "argument" - ["bar (Just abcdef) abcdefg = abcd"] - (Position 0 32) - [("abcdef", CiFunction, "abcdef", True, False, Nothing), - ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) - ], - completionTest - "let" - ["bar = let (Just abcdef) = undefined" - ," abcdefg = let abcd = undefined in undefined" - ," in abcd" - ] - (Position 2 15) - [("abcdef", CiFunction, "abcdef", True, False, Nothing), - ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) - ], - completionTest - "where" - ["bar = abcd" - ," where (Just abcdef) = undefined" - ," abcdefg = let abcd = undefined in undefined" - ] - (Position 0 10) - [("abcdef", CiFunction, "abcdef", True, False, Nothing), - ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) - ], - completionTest - "do/1" - ["bar = do" - ," Just abcdef <- undefined" - ," abcd" - ," abcdefg <- undefined" - ," pure ()" - ] - (Position 2 6) - [("abcdef", CiFunction, "abcdef", True, False, Nothing) - ], - completionTest - "do/2" - ["bar abcde = do" - ," Just [(abcdef,_)] <- undefined" - ," abcdefg <- undefined" - ," let abcdefgh = undefined" - ," (Just [abcdefghi]) = undefined" - ," abcd" - ," where" - ," abcdefghij = undefined" - ] - (Position 5 8) - [("abcde", CiFunction, "abcde", True, False, Nothing) - ,("abcdefghij", CiFunction, "abcdefghij", True, False, Nothing) - ,("abcdef", CiFunction, "abcdef", True, False, Nothing) - ,("abcdefg", CiFunction, "abcdefg", True, False, Nothing) - ,("abcdefgh", CiFunction, "abcdefgh", True, False, Nothing) - ,("abcdefghi", CiFunction, "abcdefghi", True, False, Nothing) - ] - ] - -nonLocalCompletionTests :: [TestTree] -nonLocalCompletionTests = - [ completionTest - "variable" - ["module A where", "f = hea"] - (Position 1 7) - [("head", CiFunction, "head ${1:[a]}", True, True, Nothing)], - completionTest - "constructor" - ["module A where", "f = Tru"] - (Position 1 7) - [ ("True", CiConstructor, "True ", True, True, Nothing), - ("truncate", CiFunction, "truncate ${1:a}", True, True, Nothing) - ], - completionTest - "type" - ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"] - (Position 2 7) - [ ("Bounded", CiClass, "Bounded ${1:*}", True, True, Nothing), - ("Bool", CiStruct, "Bool ", True, True, Nothing) - ], - completionTest - "qualified" - ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"] - (Position 2 15) - [ ("head", CiFunction, "head ${1:[a]}", True, True, Nothing) - ], - completionTest - "duplicate import" - ["module A where", "import Data.List", "import Data.List", "f = perm"] - (Position 3 8) - [ ("permutations", CiFunction, "permutations ${1:[a]}", False, False, Nothing) - ], - completionTest - "dont show hidden items" - [ "{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", - "import Control.Monad hiding (join)", - "f = joi" - ] - (Position 3 6) - [], - testGroup "auto import snippets" - [ completionCommandTest - "show imports not in list - simple" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad (msum)", "f = joi"] - (Position 3 6) - "join" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad (msum, join)", "f = joi"] - , completionCommandTest - "show imports not in list - multi-line" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad (\n msum)", "f = joi"] - (Position 4 6) - "join" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad (\n msum, join)", "f = joi"] - , completionCommandTest - "show imports not in list - names with _" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M (msum)", "f = M.mapM_"] - (Position 3 11) - "mapM_" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M (msum, mapM_)", "f = M.mapM_"] - , completionCommandTest - "show imports not in list - initial empty list" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M ()", "f = M.joi"] - (Position 3 10) - "join" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M (join)", "f = M.joi"] - , testGroup "qualified imports" - [ completionCommandTest - "single" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad ()", "f = Control.Monad.joi"] - (Position 3 22) - "join" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad (join)", "f = Control.Monad.joi"] - , completionCommandTest - "as" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M ()", "f = M.joi"] - (Position 3 10) - "join" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M (join)", "f = M.joi"] - , completionCommandTest - "multiple" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M ()", "import Control.Monad as N ()", "f = N.joi"] - (Position 4 10) - "join" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M ()", "import Control.Monad as N (join)", "f = N.joi"] - ] - , testGroup "Data constructor" - [ completionCommandTest - "not imported" - ["module A where", "import Text.Printf ()", "ZeroPad"] - (Position 2 4) - "ZeroPad" - ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] - , completionCommandTest - "parent imported abs" - ["module A where", "import Text.Printf (FormatAdjustment)", "ZeroPad"] - (Position 2 4) - "ZeroPad" - ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] - , completionNoCommandTest - "parent imported all" - ["module A where", "import Text.Printf (FormatAdjustment (..))", "ZeroPad"] - (Position 2 4) - "ZeroPad" - , completionNoCommandTest - "already imported" - ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] - (Position 2 4) - "ZeroPad" - , completionNoCommandTest - "function from Prelude" - ["module A where", "import Data.Maybe ()", "Nothing"] - (Position 2 4) - "Nothing" - ] - , testGroup "Record completion" - [ completionCommandTest - "not imported" - ["module A where", "import Text.Printf ()", "FormatParse"] - (Position 2 10) - "FormatParse {" - ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] - , completionCommandTest - "parent imported" - ["module A where", "import Text.Printf (FormatParse)", "FormatParse"] - (Position 2 10) - "FormatParse {" - ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] - , completionNoCommandTest - "already imported" - ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] - (Position 2 10) - "FormatParse {" - ] - ], - -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls - completionTest - "do not show pragma completions" - [ "{-# LANGUAGE ", - "{module A where}", - "main = return ()" - ] - (Position 0 13) - [] - ] - -otherCompletionTests :: [TestTree] -otherCompletionTests = [ - completionTest - "keyword" - ["module A where", "f = newty"] - (Position 1 9) - [("newtype", CiKeyword, "", False, False, Nothing)], - completionTest - "type context" - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "f = f", - "g :: Intege" - ] - -- At this point the module parses but does not typecheck. - -- This should be sufficient to detect that we are in a - -- type context and only show the completion to the type. - (Position 3 11) - [("Integer", CiStruct, "Integer ", True, True, Nothing)], - - testSession "duplicate record fields" $ do - void $ - createDoc "B.hs" "haskell" $ - T.unlines - [ "{-# LANGUAGE DuplicateRecordFields #-}", - "module B where", - "newtype Foo = Foo { member :: () }", - "newtype Bar = Bar { member :: () }" - ] - docA <- - createDoc "A.hs" "haskell" $ - T.unlines - [ "module A where", - "import B", - "memb" - ] - _ <- waitForDiagnostics - compls <- getCompletions docA $ Position 2 4 - let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"] - liftIO $ compls' @?= ["member ${1:Foo}", "member ${1:Bar}"], - - testSessionWait "maxCompletions" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "a = Prelude." - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 3 13) - liftIO $ length compls @?= maxCompletions def - ] - -highlightTests :: TestTree -highlightTests = testGroup "highlight" - [ testSessionWait "value" $ do - doc <- createDoc "A.hs" "haskell" source - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 3 2) - liftIO $ highlights @?= List - [ DocumentHighlight (R 2 0 2 3) (Just HkRead) - , DocumentHighlight (R 3 0 3 3) (Just HkWrite) - , DocumentHighlight (R 4 6 4 9) (Just HkRead) - , DocumentHighlight (R 5 22 5 25) (Just HkRead) - ] - , testSessionWait "type" $ do - doc <- createDoc "A.hs" "haskell" source - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 2 8) - liftIO $ highlights @?= List - [ DocumentHighlight (R 2 7 2 10) (Just HkRead) - , DocumentHighlight (R 3 11 3 14) (Just HkRead) - ] - , testSessionWait "local" $ do - doc <- createDoc "A.hs" "haskell" source - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 6 5) - liftIO $ highlights @?= List - [ DocumentHighlight (R 6 4 6 7) (Just HkWrite) - , DocumentHighlight (R 6 10 6 13) (Just HkRead) - , DocumentHighlight (R 7 12 7 15) (Just HkRead) - ] - , testSessionWait "record" $ do - doc <- createDoc "A.hs" "haskell" recsource - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 4 15) - liftIO $ highlights @?= List - -- Span is just the .. on 8.10, but Rec{..} before -#if MIN_GHC_API_VERSION(8,10,0) - [ DocumentHighlight (R 4 8 4 10) (Just HkWrite) -#else - [ DocumentHighlight (R 4 4 4 11) (Just HkWrite) -#endif - , DocumentHighlight (R 4 14 4 20) (Just HkRead) - ] - highlights <- getHighlights doc (Position 3 17) - liftIO $ highlights @?= List - [ DocumentHighlight (R 3 17 3 23) (Just HkWrite) - -- Span is just the .. on 8.10, but Rec{..} before -#if MIN_GHC_API_VERSION(8,10,0) - , DocumentHighlight (R 4 8 4 10) (Just HkRead) -#else - , DocumentHighlight (R 4 4 4 11) (Just HkRead) -#endif - ] - ] - where - source = T.unlines - ["{-# OPTIONS_GHC -Wunused-binds #-}" - ,"module Highlight () where" - ,"foo :: Int" - ,"foo = 3 :: Int" - ,"bar = foo" - ," where baz = let x = foo in x" - ,"baz arg = arg + x" - ," where x = arg" - ] - recsource = T.unlines - ["{-# LANGUAGE RecordWildCards #-}" - ,"{-# OPTIONS_GHC -Wunused-binds #-}" - ,"module Highlight () where" - ,"data Rec = Rec { field1 :: Int, field2 :: Char }" - ,"foo Rec{..} = field2 + field1" - ] - -outlineTests :: TestTree -outlineTests = testGroup - "outline" - [ testSessionWait "type class" $ do - let source = T.unlines ["module A where", "class A a where a :: a -> Bool"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ moduleSymbol - "A" - (R 0 7 0 8) - [ classSymbol "A a" - (R 1 0 1 30) - [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)] - ] - ] - , testSessionWait "type class instance " $ do - let source = T.unlines ["class A a where", "instance A () where"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ classSymbol "A a" (R 0 0 0 15) [] - , docSymbol "A ()" SkInterface (R 1 0 1 19) - ] - , testSessionWait "type family" $ do - let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)] - , testSessionWait "type family instance " $ do - let source = T.unlines - [ "{-# language TypeFamilies #-}" - , "type family A a" - , "type instance A () = ()" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15) - , docSymbol "A ()" SkInterface (R 2 0 2 23) - ] - , testSessionWait "data family" $ do - let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)] - , testSessionWait "data family instance " $ do - let source = T.unlines - [ "{-# language TypeFamilies #-}" - , "data family A a" - , "data instance A () = A ()" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11) - , docSymbol "A ()" SkInterface (R 2 0 2 25) - ] - , testSessionWait "constant" $ do - let source = T.unlines ["a = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol "a" SkFunction (R 0 0 0 6)] - , testSessionWait "pattern" $ do - let source = T.unlines ["Just foo = Just 21"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol "Just foo" SkFunction (R 0 0 0 18)] - , testSessionWait "pattern with type signature" $ do - let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol "a :: ()" SkFunction (R 1 0 1 12)] - , testSessionWait "function" $ do - let source = T.unlines ["a _x = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 9)] - , testSessionWait "type synonym" $ do - let source = T.unlines ["type A = Bool"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)] - , testSessionWait "datatype" $ do - let source = T.unlines ["data A = C"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolWithChildren "A" - SkStruct - (R 0 0 0 10) - [docSymbol "C" SkConstructor (R 0 9 0 10)] - ] - , testSessionWait "record fields" $ do - let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @=? Left - [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13) - [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10) - [ docSymbol "x" SkField (R 1 2 1 3) - , docSymbol "y" SkField (R 2 4 2 5) - ] - ] - ] - , testSessionWait "import" $ do - let source = T.unlines ["import Data.Maybe ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbolWithChildren "imports" - SkModule - (R 0 0 0 20) - [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 20) - ] - ] - , testSessionWait "multiple import" $ do - let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbolWithChildren "imports" - SkModule - (R 1 0 3 27) - [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 20) - , docSymbol "import Control.Exception" SkModule (R 3 0 3 27) - ] - ] - , testSessionWait "foreign import" $ do - let source = T.unlines - [ "{-# language ForeignFunctionInterface #-}" - , "foreign import ccall \"a\" a :: Int" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)] - , testSessionWait "foreign export" $ do - let source = T.unlines - [ "{-# language ForeignFunctionInterface #-}" - , "foreign export ccall odd :: Int -> Bool" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)] - ] - where - docSymbol name kind loc = - DocumentSymbol name Nothing kind Nothing loc loc Nothing - docSymbol' name kind loc selectionLoc = - DocumentSymbol name Nothing kind Nothing loc selectionLoc Nothing - docSymbolD name detail kind loc = - DocumentSymbol name (Just detail) kind Nothing loc loc Nothing - docSymbolWithChildren name kind loc cc = - DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc) - docSymbolWithChildren' name kind loc selectionLoc cc = - DocumentSymbol name Nothing kind Nothing loc selectionLoc (Just $ List cc) - moduleSymbol name loc cc = DocumentSymbol name - Nothing - SkFile - Nothing - (R 0 0 maxBound 0) - loc - (Just $ List cc) - classSymbol name loc cc = DocumentSymbol name - (Just "class") - SkClass - Nothing - loc - loc - (Just $ List cc) - -pattern R :: Int -> Int -> Int -> Int -> Range -pattern R x y x' y' = Range (Position x y) (Position x' y') - -xfail :: TestTree -> String -> TestTree -xfail = flip expectFailBecause - -ignoreInWindowsBecause :: String -> TestTree -> TestTree -ignoreInWindowsBecause = if isWindows then ignoreTestBecause else (\_ x -> x) - -ignoreInWindowsForGHC88And810 :: TestTree -> TestTree -#if MIN_GHC_API_VERSION(8,8,1) && !MIN_GHC_API_VERSION(9,0,0) -ignoreInWindowsForGHC88And810 = - ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8 and 8.10" -#else -ignoreInWindowsForGHC88And810 = id -#endif - -ignoreInWindowsForGHC88 :: TestTree -> TestTree -#if MIN_GHC_API_VERSION(8,8,1) && !MIN_GHC_API_VERSION(8,10,1) -ignoreInWindowsForGHC88 = - ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8" -#else -ignoreInWindowsForGHC88 = id -#endif - -data Expect - = ExpectRange Range -- Both gotoDef and hover should report this range - | ExpectLocation Location --- | ExpectDefRange Range -- Only gotoDef should report this range - | ExpectHoverRange Range -- Only hover should report this range - | ExpectHoverText [T.Text] -- the hover message must contain these snippets - | ExpectExternFail -- definition lookup in other file expected to fail - | ExpectNoDefinitions - | ExpectNoHover --- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples - deriving Eq - -mkR :: Int -> Int -> Int -> Int -> Expect -mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn - -mkL :: Uri -> Int -> Int -> Int -> Int -> Expect -mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn - -haddockTests :: TestTree -haddockTests - = testGroup "haddock" - [ testCase "Num" $ checkHaddock - (unlines - [ "However, '(+)' and '(*)' are" - , "customarily expected to define a ring and have the following properties:" - , "" - , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@" - , "[__Commutativity of (+)__]: @x + y@ = @y + x@" - , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@" - ] - ) - (unlines - [ "" - , "" - , "However, `(+)` and `(*)` are" - , "customarily expected to define a ring and have the following properties: " - , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`" - , "+ ****Commutativity of (+)****: `x + y` = `y + x`" - , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`" - ] - ) - , testCase "unsafePerformIO" $ checkHaddock - (unlines - [ "may require" - , "different precautions:" - , "" - , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" - , " that calls 'unsafePerformIO'. If the call is inlined," - , " the I\\/O may be performed more than once." - , "" - , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - (unlines - [ "" - , "" - , "may require" - , "different precautions: " - , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " - , " that calls `unsafePerformIO` . If the call is inlined," - , " the I/O may be performed more than once." - , "" - , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - ] - where - checkHaddock s txt = spanDocToMarkdownForTest s @?= txt - -cradleTests :: TestTree -cradleTests = testGroup "cradle" - [testGroup "dependencies" [sessionDepsArePickedUp] - ,testGroup "ignore-fatal" [ignoreFatalWarning] - ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] - ,testGroup "multi" [simpleMultiTest, simpleMultiTest2, simpleMultiDefTest] - ,testGroup "sub-directory" [simpleSubDirectoryTest] - ] - -loadCradleOnlyonce :: TestTree -loadCradleOnlyonce = testGroup "load cradle only once" - [ testSession' "implicit" implicit - , testSession' "direct" direct - ] - where - direct dir = do - liftIO $ writeFileUTF8 (dir "hie.yaml") - "cradle: {direct: {arguments: []}}" - test dir - implicit dir = test dir - test _dir = do - doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo" - msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) - liftIO $ length msgs @?= 1 - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"] - msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) - liftIO $ length msgs @?= 0 - _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar" - msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) - liftIO $ length msgs @?= 0 - -retryFailedCradle :: TestTree -retryFailedCradle = testSession' "retry failed" $ \dir -> do - -- The false cradle always fails - let hieContents = "cradle: {bios: {shell: \"false\"}}" - hiePath = dir "hie.yaml" - liftIO $ writeFile hiePath hieContents - hieDoc <- createDoc hiePath "yaml" $ T.pack hieContents - let aPath = dir "A.hs" - doc <- createDoc aPath "haskell" "main = return ()" - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc - liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess - - -- Fix the cradle and typecheck again - let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}" - liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle - changeDoc - hieDoc - [ TextDocumentContentChangeEvent - { _range = Nothing, - _rangeLength = Nothing, - _text = validCradle - } - ] - - -- Force a session restart by making an edit, just to dirty the typecheck node - changeDoc - doc - [ TextDocumentContentChangeEvent - { _range = Just Range {_start = Position 0 0, _end = Position 0 0}, - _rangeLength = Nothing, - _text = "\n" - } - ] - - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc - liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess - - -dependentFileTest :: TestTree -dependentFileTest = testGroup "addDependentFile" - [testGroup "file-changed" [ignoreInWindowsForGHC88 $ testSession' "test" test] - ] - where - test dir = do - -- If the file contains B then no type error - -- otherwise type error - liftIO $ writeFile (dir "dep-file.txt") "A" - let fooContent = T.unlines - [ "{-# LANGUAGE TemplateHaskell #-}" - , "module Foo where" - , "import Language.Haskell.TH.Syntax" - , "foo :: Int" - , "foo = 1 + $(do" - , " qAddDependentFile \"dep-file.txt\"" - , " f <- qRunIO (readFile \"dep-file.txt\")" - , " if f == \"B\" then [| 1 |] else lift f)" - ] - let bazContent = T.unlines ["module Baz where", "import Foo ()"] - _ <-createDoc "Foo.hs" "haskell" fooContent - doc <- createDoc "Baz.hs" "haskell" bazContent - expectDiagnostics - [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])] - -- Now modify the dependent file - liftIO $ writeFile (dir "dep-file.txt") "B" - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 2 0) (Position 2 6)) - , _rangeLength = Nothing - , _text = "f = ()" - } - -- Modifying Baz will now trigger Foo to be rebuilt as well - changeDoc doc [change] - expectDiagnostics [("Foo.hs", [])] - - -cradleLoadedMessage :: Session FromServerMessage -cradleLoadedMessage = satisfy $ \case - FromServerMess (SCustomMethod m) (NotMess _) -> m == cradleLoadedMethod - _ -> False - -cradleLoadedMethod :: T.Text -cradleLoadedMethod = "ghcide/cradle/loaded" - -ignoreFatalWarning :: TestTree -ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do - let srcPath = dir "IgnoreFatal.hs" - src <- liftIO $ readFileUtf8 srcPath - _ <- createDoc srcPath "haskell" src - expectNoMoreDiagnostics 5 - -simpleSubDirectoryTest :: TestTree -simpleSubDirectoryTest = - testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do - let mainPath = dir "a/src/Main.hs" - mainSource <- liftIO $ readFileUtf8 mainPath - _mdoc <- createDoc mainPath "haskell" mainSource - expectDiagnosticsWithTags - [("a/src/Main.hs", [(DsWarning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded - ] - expectNoMoreDiagnostics 0.5 - -simpleMultiTest :: TestTree -simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - aSource <- liftIO $ readFileUtf8 aPath - adoc <- createDoc aPath "haskell" aSource - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc - liftIO $ assertBool "A should typecheck" ideResultSuccess - bSource <- liftIO $ readFileUtf8 bPath - bdoc <- createDoc bPath "haskell" bSource - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc - liftIO $ assertBool "B should typecheck" ideResultSuccess - locs <- getDefinitions bdoc (Position 2 7) - let fooL = mkL (adoc ^. L.uri) 2 0 2 3 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - --- Like simpleMultiTest but open the files in the other order -simpleMultiTest2 :: TestTree -simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - bSource <- liftIO $ readFileUtf8 bPath - bdoc <- createDoc bPath "haskell" bSource - expectNoMoreDiagnostics 10 - aSource <- liftIO $ readFileUtf8 aPath - (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource - -- Need to have some delay here or the test fails - expectNoMoreDiagnostics 10 - locs <- getDefinitions bdoc (Position 2 7) - let fooL = mkL adoc 2 0 2 3 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - --- Like simpleMultiTest but open the files in component 'a' in a seperate session -simpleMultiDefTest :: TestTree -simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - adoc <- liftIO $ runInDir dir $ do - aSource <- liftIO $ readFileUtf8 aPath - adoc <- createDoc aPath "haskell" aSource - ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do - A.Success fp' <- pure $ fromJSON fp - if equalFilePath fp' aPath then pure () else Nothing - _ -> Nothing - closeDoc adoc - pure adoc - bSource <- liftIO $ readFileUtf8 bPath - bdoc <- createDoc bPath "haskell" bSource - locs <- getDefinitions bdoc (Position 2 7) - let fooL = mkL (adoc ^. L.uri) 2 0 2 3 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - -ifaceTests :: TestTree -ifaceTests = testGroup "Interface loading tests" - [ -- https://github.com/haskell/ghcide/pull/645/ - ifaceErrorTest - , ifaceErrorTest2 - , ifaceErrorTest3 - , ifaceTHTest - ] - -bootTests :: TestTree -bootTests = testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do - let cPath = dir "C.hs" - cSource <- liftIO $ readFileUtf8 cPath - - -- Dirty the cache - liftIO $ runInDir dir $ do - cDoc <- createDoc cPath "haskell" cSource - _ <- getHover cDoc $ Position 4 3 - closeDoc cDoc - - cdoc <- createDoc cPath "haskell" cSource - locs <- getDefinitions cdoc (Position 7 4) - let floc = mkR 9 0 9 1 - checkDefs locs (pure [floc]) - --- | test that TH reevaluates across interfaces -ifaceTHTest :: TestTree -ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do - let aPath = dir "THA.hs" - bPath = dir "THB.hs" - cPath = dir "THC.hs" - - aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: () - _bSource <- liftIO $ readFileUtf8 bPath -- a :: () - cSource <- liftIO $ readFileUtf8 cPath -- c = a :: () - - cdoc <- createDoc cPath "haskell" cSource - - -- Change [TH]a from () to Bool - liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"]) - - -- Check that the change propogates to C - changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing cSource] - expectDiagnostics - [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) - ,("THB.hs", [(DsWarning, (4,0), "Top-level binding")])] - closeDoc cdoc - -ifaceErrorTest :: TestTree -ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do - let bPath = dir "B.hs" - pPath = dir "P.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - - bdoc <- createDoc bPath "haskell" bSource - expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So what we know P has been loaded - - -- Change y from Int to B - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] - -- save so that we can that the error propogates to A - sendNotification STextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing) - - -- Check that the error propogates to A - expectDiagnostics - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])] - - - -- Check that we wrote the interfaces for B when we saved - let m = SCustomMethod "test" - lid <- sendRequest m $ toJSON $ GetInterfaceFilesDir bPath - res <- skipManyTill anyMessage $ responseForId m lid - liftIO $ case res of - ResponseMessage{_result=Right (A.fromJSON -> A.Success hidir)} -> do - hi_exists <- doesFileExist $ hidir "B.hi" - assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists - _ -> assertFailure $ "Got malformed response for CustomMessage hidir: " ++ show res - - pdoc <- createDoc pPath "haskell" pSource - changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ] - -- Now in P we have - -- bar = x :: Int - -- foo = y :: Bool - -- HOWEVER, in A... - -- x = y :: Int - -- This is clearly inconsistent, and the expected outcome a bit surprising: - -- - The diagnostic for A has already been received. Ghcide does not repeat diagnostics - -- - P is being typechecked with the last successful artifacts for A. - expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")]) - ,("P.hs", [(DsWarning,(6,0), "Top-level binding")]) - ] - expectNoMoreDiagnostics 2 - -ifaceErrorTest2 :: TestTree -ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \dir -> do - let bPath = dir "B.hs" - pPath = dir "P.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - - bdoc <- createDoc bPath "haskell" bSource - pdoc <- createDoc pPath "haskell" pSource - expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded - - -- Change y from Int to B - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] - - -- Add a new definition to P - changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ] - -- Now in P we have - -- bar = x :: Int - -- foo = y :: Bool - -- HOWEVER, in A... - -- x = y :: Int - expectDiagnostics - -- As in the other test, P is being typechecked with the last successful artifacts for A - -- (ot thanks to -fdeferred-type-errors) - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ,("P.hs", [(DsWarning, (4, 0), "Top-level binding")]) - ,("P.hs", [(DsWarning, (6, 0), "Top-level binding")]) - ] - - expectNoMoreDiagnostics 2 - -ifaceErrorTest3 :: TestTree -ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \dir -> do - let bPath = dir "B.hs" - pPath = dir "P.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - - bdoc <- createDoc bPath "haskell" bSource - - -- Change y from Int to B - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] - - -- P should not typecheck, as there are no last valid artifacts for A - _pdoc <- createDoc pPath "haskell" pSource - - -- In this example the interface file for A should not exist (modulo the cache folder) - -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors - expectDiagnostics - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ,("P.hs", [(DsWarning,(4,0), "Top-level binding")]) - ] - expectNoMoreDiagnostics 2 - -sessionDepsArePickedUp :: TestTree -sessionDepsArePickedUp = testSession' - "session-deps-are-picked-up" - $ \dir -> do - liftIO $ - writeFileUTF8 - (dir "hie.yaml") - "cradle: {direct: {arguments: []}}" - -- Open without OverloadedStrings and expect an error. - doc <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics - [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])] - -- Update hie.yaml to enable OverloadedStrings. - liftIO $ - writeFileUTF8 - (dir "hie.yaml") - "cradle: {direct: {arguments: [-XOverloadedStrings]}}" - -- Send change event. - let change = - TextDocumentContentChangeEvent - { _range = Just (Range (Position 4 0) (Position 4 0)), - _rangeLength = Nothing, - _text = "\n" - } - changeDoc doc [change] - -- Now no errors. - expectDiagnostics [("Foo.hs", [])] - where - fooContent = - T.unlines - [ "module Foo where", - "import Data.Text", - "foo :: Text", - "foo = \"hello\"" - ] - --- A test to ensure that the command line ghcide workflow stays working -nonLspCommandLine :: TestTree -nonLspCommandLine = testGroup "ghcide command line" - [ testCase "works" $ withTempDir $ \dir -> do - ghcide <- locateGhcideExecutable - copyTestDataFiles dir "multi" - let cmd = (proc ghcide ["a/A.hs"]){cwd = Just dir} - - setEnv "HOME" "/homeless-shelter" False - - (ec, _, _) <- readCreateProcessWithExitCode cmd "" - - ec @=? ExitSuccess - ] - -benchmarkTests :: TestTree -benchmarkTests = - let ?config = Bench.defConfig - { Bench.verbosity = Bench.Quiet - , Bench.repetitions = Just 3 - , Bench.buildTool = Bench.Cabal - } in - withResource Bench.setup Bench.cleanUp $ \getResource -> testGroup "benchmark experiments" - [ testCase (Bench.name e) $ do - Bench.SetupResult{Bench.benchDir} <- getResource - res <- Bench.runBench (runInDir benchDir) e - assertBool "did not successfully complete 5 repetitions" $ Bench.success res - | e <- Bench.experiments - , Bench.name e /= "edit" -- the edit experiment does not ever fail - -- the cradle experiments are way too slow - , not ("cradle" `isInfixOf` Bench.name e) - ] - --- | checks if we use InitializeParams.rootUri for loading session -rootUriTests :: TestTree -rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do - let bPath = dir "dirB/Foo.hs" - liftIO $ copyTestDataFiles dir "rootUri" - bSource <- liftIO $ readFileUtf8 bPath - _ <- createDoc "Foo.hs" "haskell" bSource - expectNoMoreDiagnostics 0.5 - where - -- similar to run' except we can configure where to start ghcide and session - runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO () - runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir) - --- | Test if ghcide asynchronously handles Commands and user Requests -asyncTests :: TestTree -asyncTests = testGroup "async" - [ - testSession "command" $ do - -- Execute a command that will block forever - let req = ExecuteCommandParams Nothing blockCommandId Nothing - void $ sendRequest SWorkspaceExecuteCommand req - -- Load a file and check for code actions. Will only work if the command is run asynchronously - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS -Wmissing-signatures #-}" - , "foo = id" - ] - void waitForDiagnostics - actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0)) - liftIO $ [ _title | InR CodeAction{_title} <- actions] @=? - [ "add signature: foo :: a -> a" ] - , testSession "request" $ do - -- Execute a custom request that will block for 1000 seconds - void $ sendRequest (SCustomMethod "test") $ toJSON $ BlockSeconds 1000 - -- Load a file and check for code actions. Will only work if the request is run asynchronously - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS -Wmissing-signatures #-}" - , "foo = id" - ] - void waitForDiagnostics - actions <- getCodeActions doc (Range (Position 0 0) (Position 0 0)) - liftIO $ [ _title | InR CodeAction{_title} <- actions] @=? - [ "add signature: foo :: a -> a" ] - ] - - -clientSettingsTest :: TestTree -clientSettingsTest = testGroup "client settings handling" - [ testSession "ghcide restarts shake session on config changes" $ do - void $ skipManyTill anyMessage $ message SClientRegisterCapability - sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String))) - nots <- skipManyTill anyMessage $ count 3 loggingNotification - isMessagePresent "Restarting build session" (map getLogMessage nots) - - ] - where getLogMessage :: FromServerMessage -> T.Text - getLogMessage (FromServerMess SWindowLogMessage (NotificationMessage _ _ (LogMessageParams _ msg))) = msg - getLogMessage _ = "" - - isMessagePresent expectedMsg actualMsgs = liftIO $ - assertBool ("\"" ++ expectedMsg ++ "\" is not present in: " ++ show actualMsgs) - (any ((expectedMsg `isSubsequenceOf`) . show) actualMsgs) - -referenceTests :: TestTree -referenceTests = testGroup "references" - [ testGroup "can get references to FOIs" - [ referenceTest "can get references to symbols" - ("References.hs", 4, 7) - YesIncludeDeclaration - [ ("References.hs", 4, 6) - , ("References.hs", 6, 0) - , ("References.hs", 6, 14) - , ("References.hs", 9, 7) - , ("References.hs", 10, 11) - ] - - , referenceTest "can get references to data constructor" - ("References.hs", 13, 2) - YesIncludeDeclaration - [ ("References.hs", 13, 2) - , ("References.hs", 16, 14) - , ("References.hs", 19, 21) - ] - - , referenceTest "getting references works in the other module" - ("OtherModule.hs", 6, 0) - YesIncludeDeclaration - [ ("OtherModule.hs", 6, 0) - , ("OtherModule.hs", 8, 16) - ] - - , referenceTest "getting references works in the Main module" - ("Main.hs", 9, 0) - YesIncludeDeclaration - [ ("Main.hs", 9, 0) - , ("Main.hs", 10, 4) - ] - - , referenceTest "getting references to main works" - ("Main.hs", 5, 0) - YesIncludeDeclaration - [ ("Main.hs", 4, 0) - , ("Main.hs", 5, 0) - ] - - , referenceTest "can get type references" - ("Main.hs", 9, 9) - YesIncludeDeclaration - [ ("Main.hs", 9, 0) - , ("Main.hs", 9, 9) - , ("Main.hs", 10, 0) - ] - - , expectFailBecause "references provider does not respect includeDeclaration parameter" $ - referenceTest "works when we ask to exclude declarations" - ("References.hs", 4, 7) - NoExcludeDeclaration - [ ("References.hs", 6, 0) - , ("References.hs", 6, 14) - , ("References.hs", 9, 7) - , ("References.hs", 10, 11) - ] - - , referenceTest "INCORRECTLY returns declarations when we ask to exclude them" - ("References.hs", 4, 7) - NoExcludeDeclaration - [ ("References.hs", 4, 6) - , ("References.hs", 6, 0) - , ("References.hs", 6, 14) - , ("References.hs", 9, 7) - , ("References.hs", 10, 11) - ] - ] - - , testGroup "can get references to non FOIs" - [ referenceTest "can get references to symbol defined in a module we import" - ("References.hs", 22, 4) - YesIncludeDeclaration - [ ("References.hs", 22, 4) - , ("OtherModule.hs", 0, 20) - , ("OtherModule.hs", 4, 0) - ] - - , referenceTest "can get references in modules that import us to symbols we define" - ("OtherModule.hs", 4, 0) - YesIncludeDeclaration - [ ("References.hs", 22, 4) - , ("OtherModule.hs", 0, 20) - , ("OtherModule.hs", 4, 0) - ] - - , referenceTest "can get references to symbol defined in a module we import transitively" - ("References.hs", 24, 4) - YesIncludeDeclaration - [ ("References.hs", 24, 4) - , ("OtherModule.hs", 0, 48) - , ("OtherOtherModule.hs", 2, 0) - ] - - , referenceTest "can get references in modules that import us transitively to symbols we define" - ("OtherOtherModule.hs", 2, 0) - YesIncludeDeclaration - [ ("References.hs", 24, 4) - , ("OtherModule.hs", 0, 48) - , ("OtherOtherModule.hs", 2, 0) - ] - - , referenceTest "can get type references to other modules" - ("Main.hs", 12, 10) - YesIncludeDeclaration - [ ("Main.hs", 12, 7) - , ("Main.hs", 13, 0) - , ("References.hs", 12, 5) - , ("References.hs", 16, 0) - ] - ] - ] - --- | When we ask for all references to symbol "foo", should the declaration "foo --- = 2" be among the references returned? -data IncludeDeclaration = - YesIncludeDeclaration - | NoExcludeDeclaration - -getReferences' :: SymbolLocation -> IncludeDeclaration -> Session (List Location) -getReferences' (file, l, c) includeDeclaration = do - doc <- openDoc file "haskell" - getReferences doc (Position l c) $ toBool includeDeclaration - where toBool YesIncludeDeclaration = True - toBool NoExcludeDeclaration = False - -referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree -referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do - let docs = map (dir ) $ delete thisDoc $ nubOrd docs' - -- Initial Index - docid <- openDoc thisDoc "haskell" - let - loop :: [FilePath] -> Session () - loop [] = pure () - loop docs = do - doc <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do - A.Success fp' <- pure $ fromJSON fp - find (fp' ==) docs - _ -> Nothing - loop (delete doc docs) - loop docs - f dir - closeDoc docid - --- | Given a location, lookup the symbol and all references to it. Make sure --- they are the ones we expect. -referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree -referenceTest name loc includeDeclaration expected = - referenceTestSession name (fst3 loc) docs $ \dir -> do - List actual <- getReferences' loc includeDeclaration - liftIO $ actual `expectSameLocations` map (first3 (dir )) expected - where - docs = map fst3 expected - -type SymbolLocation = (FilePath, Int, Int) - -expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion -expectSameLocations actual expected = do - let actual' = - Set.map (\location -> (location ^. L.uri - , location ^. L.range . L.start . L.line - , location ^. L.range . L.start . L.character)) - $ Set.fromList actual - expected' <- Set.fromList <$> - (forM expected $ \(file, l, c) -> do - fp <- canonicalizePath file - return (filePathToUri fp, l, c)) - actual' @?= expected' - ----------------------------------------------------------------------- --- Utils ----------------------------------------------------------------------- - -testSession :: String -> Session () -> TestTree -testSession name = testCase name . run - -testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree -testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix - -testSession' :: String -> (FilePath -> Session ()) -> TestTree -testSession' name = testCase name . run' - -testSessionWait :: String -> Session () -> TestTree -testSessionWait name = testSession name . - -- Check that any diagnostics produced were already consumed by the test case. - -- - -- If in future we add test cases where we don't care about checking the diagnostics, - -- this could move elsewhere. - -- - -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear. - ( >> expectNoMoreDiagnostics 0.5) - -pickActionWithTitle :: T.Text -> [Command |? CodeAction] -> IO CodeAction -pickActionWithTitle title actions = do - assertBool ("Found no matching actions for " <> show title <> " in " <> show titles) (not $ null matches) - return $ head matches - where - titles = - [ actionTitle - | InR CodeAction { _title = actionTitle } <- actions - ] - matches = - [ action - | InR action@CodeAction { _title = actionTitle } <- actions - , title == actionTitle - ] - -mkRange :: Int -> Int -> Int -> Int -> Range -mkRange a b c d = Range (Position a b) (Position c d) - -run :: Session a -> IO a -run s = run' (const s) - -runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a -runWithExtraFiles prefix s = withTempDir $ \dir -> do - copyTestDataFiles dir prefix - runInDir dir (s dir) - -copyTestDataFiles :: FilePath -> FilePath -> IO () -copyTestDataFiles dir prefix = do - -- Copy all the test data files to the temporary workspace - testDataFiles <- getDirectoryFilesIO ("test/data" prefix) ["//*"] - for_ testDataFiles $ \f -> do - createDirectoryIfMissing True $ dir takeDirectory f - copyFile ("test/data" prefix f) (dir f) - -run' :: (FilePath -> Session a) -> IO a -run' s = withTempDir $ \dir -> runInDir dir (s dir) - -runInDir :: FilePath -> Session a -> IO a -runInDir dir = runInDir' dir "." "." [] - -withLongTimeout :: IO a -> IO a -withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") - --- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root. -runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a -runInDir' dir startExeIn startSessionIn extraOptions s = do - ghcideExe <- locateGhcideExecutable - let startDir = dir startExeIn - let projDir = dir startSessionIn - - createDirectoryIfMissing True startDir - createDirectoryIfMissing True projDir - -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56 - -- since the package import test creates "Data/List.hs", which otherwise has no physical home - createDirectoryIfMissing True $ projDir ++ "/Data" - - let cmd = unwords $ - [ghcideExe, "--lsp", "--test", "--verbose", "-j2", "--cwd", startDir] ++ extraOptions - -- HIE calls getXgdDirectory which assumes that HOME is set. - -- Only sets HOME if it wasn't already set. - setEnv "HOME" "/homeless-shelter" False - let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True } - logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR" - timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT" - let conf = defaultConfig{messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride} - -- uncomment this or set LSP_TEST_LOG_STDERR=1 to see all logging - -- { logStdErr = True } - -- uncomment this or set LSP_TEST_LOG_MESSAGES=1 to see all messages - -- { logMessages = True } - runSessionWithConfig conf{logColor} cmd lspTestCaps projDir s - where - checkEnv :: String -> IO (Maybe Bool) - checkEnv s = fmap convertVal <$> getEnv s - convertVal "0" = False - convertVal _ = True - -openTestDataDoc :: FilePath -> Session TextDocumentIdentifier -openTestDataDoc path = do - source <- liftIO $ readFileUtf8 $ "test/data" path - createDoc path "haskell" source - -findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] -findCodeActions = findCodeActions' (==) "is not a superset of" - -findCodeActionsByPrefix :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] -findCodeActionsByPrefix = findCodeActions' T.isPrefixOf "is not prefix of" - -findCodeActions' :: (T.Text -> T.Text -> Bool) -> String -> TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] -findCodeActions' op errMsg doc range expectedTitles = do - actions <- getCodeActions doc range - let matches = sequence - [ listToMaybe - [ action - | InR action@CodeAction { _title = actionTitle } <- actions - , expectedTitle `op` actionTitle] - | expectedTitle <- expectedTitles] - let msg = show - [ actionTitle - | InR CodeAction { _title = actionTitle } <- actions - ] - ++ " " <> errMsg <> " " - ++ show expectedTitles - liftIO $ case matches of - Nothing -> assertFailure msg - Just _ -> pure () - return (fromJust matches) - -findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction -findCodeAction doc range t = head <$> findCodeActions doc range [t] - -unitTests :: TestTree -unitTests = do - testGroup "Unit" - [ testCase "empty file path does NOT work with the empty String literal" $ - uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "." - , testCase "empty file path works using toNormalizedFilePath'" $ - uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just "" - , testCase "empty path URI" $ do - Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri) - uriScheme @?= "file:" - uriPath @?= "" - , testCase "from empty path URI" $ do - let uri = Uri "file://" - uriToFilePath' uri @?= Just "" - , testCase "Key with empty file path roundtrips via Binary" $ - Binary.decode (Binary.encode (Q ((), emptyFilePath))) @?= Q ((), emptyFilePath) - , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do - let diag = ("", Diagnostics.ShowDiag, Diagnostic - { _range = Range - { _start = Position{_line = 0, _character = 1} - , _end = Position{_line = 2, _character = 3} - } - , _severity = Nothing - , _code = Nothing - , _source = Nothing - , _message = "" - , _relatedInformation = Nothing - , _tags = Nothing - }) - let shown = T.unpack (Diagnostics.showDiagnostics [diag]) - let expected = "1:2-3:4" - assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $ - expected `isInfixOf` shown - ] - -positionMappingTests :: TestTree -positionMappingTests = - testGroup "position mapping" - [ testGroup "toCurrent" - [ testCase "before" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 0) @?= PositionExact (Position 0 0) - , testCase "after, same line, same length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 3) @?= PositionExact (Position 0 3) - , testCase "after, same line, increased length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 0 3) @?= PositionExact (Position 0 4) - , testCase "after, same line, decreased length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "a" - (Position 0 3) @?= PositionExact (Position 0 2) - , testCase "after, next line, no newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 1 3) @?= PositionExact (Position 1 3) - , testCase "after, next line, newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\ndef" - (Position 1 0) @?= PositionExact (Position 2 0) - , testCase "after, same line, newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd" - (Position 0 4) @?= PositionExact (Position 1 2) - , testCase "after, same line, newline + newline at end" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd\n" - (Position 0 4) @?= PositionExact (Position 2 1) - , testCase "after, same line, newline + newline at end" $ - toCurrent - (Range (Position 0 1) (Position 0 1)) - "abc" - (Position 0 1) @?= PositionExact (Position 0 4) - ] - , testGroup "fromCurrent" - [ testCase "before" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 0) @?= PositionExact (Position 0 0) - , testCase "after, same line, same length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 3) @?= PositionExact (Position 0 3) - , testCase "after, same line, increased length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 0 4) @?= PositionExact (Position 0 3) - , testCase "after, same line, decreased length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "a" - (Position 0 2) @?= PositionExact (Position 0 3) - , testCase "after, next line, no newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 1 3) @?= PositionExact (Position 1 3) - , testCase "after, next line, newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\ndef" - (Position 2 0) @?= PositionExact (Position 1 0) - , testCase "after, same line, newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd" - (Position 1 2) @?= PositionExact (Position 0 4) - , testCase "after, same line, newline + newline at end" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd\n" - (Position 2 1) @?= PositionExact (Position 0 4) - , testCase "after, same line, newline + newline at end" $ - fromCurrent - (Range (Position 0 1) (Position 0 1)) - "abc" - (Position 0 4) @?= PositionExact (Position 0 1) - ] - , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties" - [ testProperty "fromCurrent r t <=< toCurrent r t" $ do - -- Note that it is important to use suchThatMap on all values at once - -- instead of only using it on the position. Otherwise you can get - -- into situations where there is no position that can be mapped back - -- for the edit which will result in QuickCheck looping forever. - let gen = do - rope <- genRope - range <- genRange rope - PrintableText replacement <- arbitrary - oldPos <- genPosition rope - pure (range, replacement, oldPos) - forAll - (suchThatMap gen - (\(range, replacement, oldPos) -> positionResultToMaybe $ (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $ - \(range, replacement, oldPos, newPos) -> - fromCurrent range replacement newPos === PositionExact oldPos - , testProperty "toCurrent r t <=< fromCurrent r t" $ do - let gen = do - rope <- genRope - range <- genRange rope - PrintableText replacement <- arbitrary - let newRope = applyChange rope (TextDocumentContentChangeEvent (Just range) Nothing replacement) - newPos <- genPosition newRope - pure (range, replacement, newPos) - forAll - (suchThatMap gen - (\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $ - \(range, replacement, newPos, oldPos) -> - toCurrent range replacement oldPos === PositionExact newPos - ] - ] - -newtype PrintableText = PrintableText { getPrintableText :: T.Text } - deriving Show - -instance Arbitrary PrintableText where - arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary - - -genRope :: Gen Rope -genRope = Rope.fromText . getPrintableText <$> arbitrary - -genPosition :: Rope -> Gen Position -genPosition r = do - row <- choose (0, max 0 $ rows - 1) - let columns = Rope.columns (nthLine row r) - column <- choose (0, max 0 $ columns - 1) - pure $ Position row column - where rows = Rope.rows r - -genRange :: Rope -> Gen Range -genRange r = do - startPos@(Position startLine startColumn) <- genPosition r - let maxLineDiff = max 0 $ rows - 1 - startLine - endLine <- choose (startLine, startLine + maxLineDiff) - let columns = Rope.columns (nthLine endLine r) - endColumn <- - if startLine == endLine - then choose (startColumn, columns) - else choose (0, max 0 $ columns - 1) - pure $ Range startPos (Position endLine endColumn) - where rows = Rope.rows r - --- | Get the ith line of a rope, starting from 0. Trailing newline not included. -nthLine :: Int -> Rope -> Rope -nthLine i r - | i < 0 = error $ "Negative line number: " <> show i - | i == 0 && Rope.rows r == 0 = r - | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r) - | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r - -getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions] -getWatchedFilesSubscriptionsUntil m = do - msgs <- manyTill (Just <$> message SClientRegisterCapability <|> Nothing <$ anyMessage) (message m) - return - [ args - | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs - , SomeRegistration (Registration _id SWorkspaceDidChangeWatchedFiles args) <- regs - ] - --- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path --- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or --- @/var@ -withTempDir :: (FilePath -> IO a) -> IO a -withTempDir f = System.IO.Extra.withTempDir $ \dir -> do - dir' <- canonicalizePath dir - f dir' - --- | Assert that a value is not 'Nothing', and extract the value. -assertJust :: MonadIO m => String -> Maybe a -> m a -assertJust s = \case - Nothing -> liftIO $ assertFailure s - Just x -> pure x +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} +#include "ghc-api-version.h" + +module Main (main) where + +import Control.Applicative.Combinators +import Control.Exception (bracket_, catch) +import qualified Control.Lens as Lens +import Control.Monad +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (fromJSON, toJSON) +import qualified Data.Aeson as A +import qualified Data.Binary as Binary +import Data.Default +import Data.Foldable +import Data.List.Extra +import Data.Maybe +import Data.Rope.UTF16 (Rope) +import qualified Data.Rope.UTF16 as Rope +import qualified Data.Set as Set +import qualified Data.Text as T +import Development.IDE.Core.PositionMapping (PositionResult (..), + fromCurrent, + positionResultToMaybe, + toCurrent) +import Development.IDE.Core.Shake (Q (..)) +import Development.IDE.GHC.Util +import Development.IDE.Plugin.Completions.Types (extendImportCommandId) +import Development.IDE.Plugin.TypeLenses (typeLensCommandId) +import Development.IDE.Spans.Common +import Development.IDE.Test (Cursor, + canonicalizeUri, + diagnostic, + expectCurrentDiagnostics, + expectDiagnostics, + expectDiagnosticsWithTags, + expectMessages, + expectNoMoreDiagnostics, + flushMessages, + standardizeQuotes, + waitForAction) +import Development.IDE.Test.Runfiles +import qualified Development.IDE.Types.Diagnostics as Diagnostics +import Development.IDE.Types.Location +import Development.Shake (getDirectoryFilesIO) +import qualified Experiments as Bench +import Ide.Plugin.Config +import Language.LSP.Test +import Language.LSP.Types hiding (mkRange) +import Language.LSP.Types.Capabilities +import qualified Language.LSP.Types.Lens as Lsp (diagnostics, + message, + params) +import Language.LSP.VFS (applyChange) +import Network.URI +import System.Directory +import System.Environment.Blank (getEnv, setEnv, + unsetEnv) +import System.Exit (ExitCode (ExitSuccess)) +import System.FilePath +import System.IO.Extra hiding (withTempDir) +import qualified System.IO.Extra +import System.Info.Extra (isWindows) +import System.Process.Extra (CreateProcess (cwd), + proc, + readCreateProcessWithExitCode) +import Test.QuickCheck +-- import Test.QuickCheck.Instances () +import Control.Lens ((^.)) +import Control.Monad.Extra (whenJust) +import Data.Tuple.Extra +import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports) +import Development.IDE.Plugin.Test (TestRequest (BlockSeconds, GetInterfaceFilesDir), + WaitForIdeRuleResult (..), + blockCommandId) +import qualified Language.LSP.Types.Lens as L +import System.Time.Extra +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import Test.Tasty.Ingredients.Rerun +import Test.Tasty.QuickCheck + +waitForProgressBegin :: Session () +waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (Begin _))) -> Just () + _ -> Nothing + +waitForProgressDone :: Session () +waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + _ -> Nothing + +main :: IO () +main = do + -- We mess with env vars so run single-threaded. + defaultMainWithRerun $ testGroup "ghcide" + [ testSession "open close" $ do + doc <- createDoc "Testing.hs" "haskell" "" + void (skipManyTill anyMessage $ message SWindowWorkDoneProgressCreate) + waitForProgressBegin + closeDoc doc + waitForProgressDone + , initializeResponseTests + , completionTests + , cppTests + , diagnosticTests + , codeActionTests + , codeLensesTests + , outlineTests + , highlightTests + , findDefinitionAndHoverTests + , pluginSimpleTests + , pluginParsedResultTests + , preprocessorTests + , thTests + , safeTests + , unitTests + , haddockTests + , positionMappingTests + , watchedFilesTests + , cradleTests + , dependentFileTest + , nonLspCommandLine + , benchmarkTests + , ifaceTests + , bootTests + , rootUriTests + , asyncTests + , clientSettingsTest + , codeActionHelperFunctionTests + , referenceTests + ] + +initializeResponseTests :: TestTree +initializeResponseTests = withResource acquire release tests where + + -- these tests document and monitor the evolution of the + -- capabilities announced by the server in the initialize + -- response. Currently the server advertises almost no capabilities + -- at all, in some cases failing to announce capabilities that it + -- actually does provide! Hopefully this will change ... + tests :: IO (ResponseMessage Initialize) -> TestTree + tests getInitializeResponse = + testGroup "initialize response capabilities" + [ chk " text doc sync" _textDocumentSync tds + , chk " hover" _hoverProvider (Just $ InL True) + , chk " completion" _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just False)) + , chk "NO signature help" _signatureHelpProvider Nothing + , chk " goto definition" _definitionProvider (Just $ InL True) + , chk " goto type definition" _typeDefinitionProvider (Just $ InL True) + -- BUG in lsp-test, this test fails, just change the accepted response + -- for now + , chk "NO goto implementation" _implementationProvider (Just $ InL False) + , chk " find references" _referencesProvider (Just $ InL True) + , chk " doc highlight" _documentHighlightProvider (Just $ InL True) + , chk " doc symbol" _documentSymbolProvider (Just $ InL True) + , chk " workspace symbol" _workspaceSymbolProvider (Just True) + , chk " code action" _codeActionProvider (Just $ InL True) + , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just False)) + , chk "NO doc formatting" _documentFormattingProvider (Just $ InL False) + , chk "NO doc range formatting" + _documentRangeFormattingProvider (Just $ InL False) + , chk "NO doc formatting on typing" + _documentOnTypeFormattingProvider Nothing + , chk "NO renaming" _renameProvider (Just $ InL False) + , chk "NO doc link" _documentLinkProvider Nothing + , chk "NO color" _colorProvider (Just $ InL False) + , chk "NO folding range" _foldingRangeProvider (Just $ InL False) + , che " execute command" _executeCommandProvider [blockCommandId, extendImportCommandId, typeLensCommandId] + , chk " workspace" _workspace (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )})) + , chk "NO experimental" _experimental Nothing + ] where + + tds = Just (InL (TextDocumentSyncOptions + { _openClose = Just True + , _change = Just TdSyncIncremental + , _willSave = Nothing + , _willSaveWaitUntil = Nothing + , _save = Just (InR $ SaveOptions {_includeText = Nothing})})) + + chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree + chk title getActual expected = + testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir + + che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree + che title getActual expected = testCase title doTest + where + doTest = do + ir <- getInitializeResponse + let Just ExecuteCommandOptions {_commands = List commands} = getActual $ innerCaps ir + zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) expected commands + + innerCaps :: ResponseMessage Initialize -> ServerCapabilities + innerCaps (ResponseMessage _ _ (Right (InitializeResult c _))) = c + innerCaps (ResponseMessage _ _ (Left _)) = error "Initialization error" + + acquire :: IO (ResponseMessage Initialize) + acquire = run initializeResponse + + release :: ResponseMessage Initialize -> IO () + release = const $ pure () + + +diagnosticTests :: TestTree +diagnosticTests = testGroup "diagnostics" + [ testSessionWait "fix syntax error" $ do + let content = T.unlines [ "module Testing wher" ] + doc <- createDoc "Testing.hs" "haskell" content + expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])] + let change = TextDocumentContentChangeEvent + { _range = Just (Range (Position 0 15) (Position 0 19)) + , _rangeLength = Nothing + , _text = "where" + } + changeDoc doc [change] + expectDiagnostics [("Testing.hs", [])] + , testSessionWait "introduce syntax error" $ do + let content = T.unlines [ "module Testing where" ] + doc <- createDoc "Testing.hs" "haskell" content + void $ skipManyTill anyMessage (message SWindowWorkDoneProgressCreate) + waitForProgressBegin + let change = TextDocumentContentChangeEvent + { _range = Just (Range (Position 0 15) (Position 0 18)) + , _rangeLength = Nothing + , _text = "wher" + } + changeDoc doc [change] + expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])] + , testSessionWait "update syntax error" $ do + let content = T.unlines [ "module Testing(missing) where" ] + doc <- createDoc "Testing.hs" "haskell" content + expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'missing'")])] + let change = TextDocumentContentChangeEvent + { _range = Just (Range (Position 0 15) (Position 0 16)) + , _rangeLength = Nothing + , _text = "l" + } + changeDoc doc [change] + expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'lissing'")])] + , testSessionWait "variable not in scope" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> Int -> Int" + , "foo a _b = a + ab" + , "bar :: Int -> Int -> Int" + , "bar _a b = cd + b" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs" + , [ (DsError, (2, 15), "Variable not in scope: ab") + , (DsError, (4, 11), "Variable not in scope: cd") + ] + ) + ] + , testSessionWait "type error" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> String -> Int" + , "foo a b = a + b" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs" + , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")] + ) + ] + , testSessionWait "typed hole" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> String" + , "foo a = _ a" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs" + , [(DsError, (2, 8), "Found hole: _ :: Int -> String")] + ) + ] + + , testGroup "deferral" $ + let sourceA a = T.unlines + [ "module A where" + , "a :: Int" + , "a = " <> a] + sourceB = T.unlines + [ "module B where" + , "import A ()" + , "b :: Float" + , "b = True"] + bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'" + expectedDs aMessage = + [ ("A.hs", [(DsError, (2,4), aMessage)]) + , ("B.hs", [(DsError, (3,4), bMessage)])] + deferralTest title binding msg = testSessionWait title $ do + _ <- createDoc "A.hs" "haskell" $ sourceA binding + _ <- createDoc "B.hs" "haskell" sourceB + expectDiagnostics $ expectedDs msg + in + [ deferralTest "type error" "True" "Couldn't match expected type" + , deferralTest "typed hole" "_" "Found hole" + , deferralTest "out of scope var" "unbound" "Variable not in scope" + ] + + , testSessionWait "remove required module" $ do + let contentA = T.unlines [ "module ModuleA where" ] + docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleB.hs" "haskell" contentB + let change = TextDocumentContentChangeEvent + { _range = Just (Range (Position 0 0) (Position 0 20)) + , _rangeLength = Nothing + , _text = "" + } + changeDoc docA [change] + expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])] + , testSessionWait "add missing module" $ do + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA ()" + ] + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] + let contentA = T.unlines [ "module ModuleA where" ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + expectDiagnostics [("ModuleB.hs", [])] + , ignoreInWindowsBecause "Broken in windows" $ testSessionWait "add missing module (non workspace)" $ do + -- need to canonicalize in Mac Os + tmpDir <- liftIO $ canonicalizePath =<< getTemporaryDirectory + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA ()" + ] + _ <- createDoc (tmpDir "ModuleB.hs") "haskell" contentB + expectDiagnostics [(tmpDir "ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] + let contentA = T.unlines [ "module ModuleA where" ] + _ <- createDoc (tmpDir "ModuleA.hs") "haskell" contentA + expectDiagnostics [(tmpDir "ModuleB.hs", [])] + , testSessionWait "cyclic module dependency" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "import ModuleB" + ] + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnostics + [ ( "ModuleA.hs" + , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + ) + , ( "ModuleB.hs" + , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + ) + ] + , testSessionWait "cyclic module dependency with hs-boot" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "import {-# SOURCE #-} ModuleB" + ] + let contentB = T.unlines + [ "{-# OPTIONS -Wmissing-signatures#-}" + , "module ModuleB where" + , "import ModuleA" + -- introduce an artificial diagnostic + , "foo = ()" + ] + let contentBboot = T.unlines + [ "module ModuleB where" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot + expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])] + , testSessionWait "correct reference used with hs-boot" $ do + let contentB = T.unlines + [ "module ModuleB where" + , "import {-# SOURCE #-} ModuleA()" + ] + let contentA = T.unlines + [ "module ModuleA where" + , "import ModuleB()" + , "x = 5" + ] + let contentAboot = T.unlines + [ "module ModuleA where" + ] + let contentC = T.unlines + [ "{-# OPTIONS -Wmissing-signatures #-}" + , "module ModuleC where" + , "import ModuleA" + -- this reference will fail if it gets incorrectly + -- resolved to the hs-boot file + , "y = x" + ] + _ <- createDoc "ModuleB.hs" "haskell" contentB + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot + _ <- createDoc "ModuleC.hs" "haskell" contentC + expectDiagnostics [("ModuleC.hs", [(DsWarning, (3,0), "Top-level binding")])] + , testSessionWait "redundant import" $ do + let contentA = T.unlines ["module ModuleA where"] + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnosticsWithTags + [ ( "ModuleB.hs" + , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant", Just DtUnnecessary)] + ) + ] + , testSessionWait "redundant import even without warning" $ do + let contentA = T.unlines ["module ModuleA where"] + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wno-unused-imports -Wmissing-signatures #-}" + , "module ModuleB where" + , "import ModuleA" + -- introduce an artificial warning for testing purposes + , "foo = ()" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])] + , testSessionWait "package imports" $ do + let thisDataListContent = T.unlines + [ "module Data.List where" + , "x :: Integer" + , "x = 123" + ] + let mainContent = T.unlines + [ "{-# LANGUAGE PackageImports #-}" + , "module Main where" + , "import qualified \"this\" Data.List as ThisList" + , "import qualified \"base\" Data.List as BaseList" + , "useThis = ThisList.x" + , "useBase = BaseList.map" + , "wrong1 = ThisList.map" + , "wrong2 = BaseList.x" + ] + _ <- createDoc "Data/List.hs" "haskell" thisDataListContent + _ <- createDoc "Main.hs" "haskell" mainContent + expectDiagnostics + [ ( "Main.hs" + , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217") + ,(DsError, (7, 9), "Not in scope: \8216BaseList.x\8217") + ] + ) + ] + , testSessionWait "unqualified warnings" $ do + let fooContent = T.unlines + [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" + , "module Foo where" + , "foo :: Ord a => a -> Int" + , "foo _a = 1" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [ ( "Foo.hs" + -- The test is to make sure that warnings contain unqualified names + -- where appropriate. The warning should use an unqualified name 'Ord', not + -- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to + -- test this is fairly arbitrary. + , [(DsWarning, (2, 0), "Redundant constraint: Ord a") + ] + ) + ] + , testSessionWait "lower-case drive" $ do + let aContent = T.unlines + [ "module A.A where" + , "import A.B ()" + ] + bContent = T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A.B where" + , "import Data.List" + ] + uriB <- getDocUri "A/B.hs" + Just pathB <- pure $ uriToFilePath uriB + uriB <- pure $ + let (drive, suffix) = splitDrive pathB + in filePathToUri (joinDrive (lower drive) suffix) + liftIO $ createDirectoryIfMissing True (takeDirectory pathB) + liftIO $ writeFileUTF8 pathB $ T.unpack bContent + uriA <- getDocUri "A/A.hs" + Just pathA <- pure $ uriToFilePath uriA + uriA <- pure $ + let (drive, suffix) = splitDrive pathA + in filePathToUri (joinDrive (lower drive) suffix) + let itemA = TextDocumentItem uriA "haskell" 0 aContent + let a = TextDocumentIdentifier uriA + sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams itemA) + NotificationMessage{_params = PublishDiagnosticsParams fileUri _ diags} <- skipManyTill anyMessage diagnostic + -- Check that if we put a lower-case drive in for A.A + -- the diagnostics for A.B will also be lower-case. + liftIO $ fileUri @?= uriB + let msg = _message (head (toList diags) :: Diagnostic) + liftIO $ unless ("redundant" `T.isInfixOf` msg) $ + assertFailure ("Expected redundant import but got " <> T.unpack msg) + closeDoc a + , testSessionWait "haddock parse error" $ do + let fooContent = T.unlines + [ "module Foo where" + , "foo :: Int" + , "foo = 1 {-|-}" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [ ( "Foo.hs" + , [(DsWarning, (2, 8), "Haddock parse error on input") + ] + ) + ] + , testSessionWait "strip file path" $ do + let + name = "Testing" + content = T.unlines + [ "module " <> name <> " where" + , "value :: Maybe ()" + , "value = [()]" + ] + _ <- createDoc (T.unpack name <> ".hs") "haskell" content + notification <- skipManyTill anyMessage diagnostic + let + offenders = + Lsp.params . + Lsp.diagnostics . + Lens.folded . + Lsp.message . + Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:")) + failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg + Lens.mapMOf_ offenders failure notification + , testSession' "-Werror in cradle is ignored" $ \sessionDir -> do + liftIO $ writeFile (sessionDir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wall\", \"-Werror\"]}}" + let fooContent = T.unlines + [ "module Foo where" + , "foo = ()" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [ ( "Foo.hs" + , [(DsWarning, (1, 0), "Top-level binding with no type signature:") + ] + ) + ] + , testSessionWait "-Werror in pragma is ignored" $ do + let fooContent = T.unlines + [ "{-# OPTIONS_GHC -Wall -Werror #-}" + , "module Foo() where" + , "foo :: Int" + , "foo = 1" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [ ( "Foo.hs" + , [(DsWarning, (3, 0), "Defined but not used:") + ] + ) + ] + , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do + let bPath = dir "B.hs" + pPath = dir "P.hs" + aPath = dir "A.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + aSource <- liftIO $ readFileUtf8 aPath -- x = y :: Int + + bdoc <- createDoc bPath "haskell" bSource + _pdoc <- createDoc pPath "haskell" pSource + expectDiagnostics + [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded + + -- Change y from Int to B which introduces a type error in A (imported from P) + changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ + T.unlines ["module B where", "y :: Bool", "y = undefined"]] + expectDiagnostics + [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) + ] + + -- Open A and edit to fix the type error + adoc <- createDoc aPath "haskell" aSource + changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing $ + T.unlines ["module A where", "import B", "x :: Bool", "x = y"]] + + expectDiagnostics + [ ( "P.hs", + [ (DsError, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"), + (DsWarning, (4, 0), "Top-level binding") + ] + ), + ("A.hs", []) + ] + expectNoMoreDiagnostics 1 + + , testSessionWait "deduplicate missing module diagnostics" $ do + let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ] + doc <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])] + + changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module Foo() where" ] + expectDiagnostics [] + + changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines + [ "module Foo() where" , "import MissingModule" ] ] + expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])] + + , testGroup "Cancellation" + [ cancellationTestGroup "edit header" editHeader yesDepends yesSession noParse noTc + , cancellationTestGroup "edit import" editImport noDepends noSession yesParse noTc + , cancellationTestGroup "edit body" editBody yesDepends yesSession yesParse yesTc + ] + ] + where + editPair x y = let p = Position x y ; p' = Position x (y+2) in + (TextDocumentContentChangeEvent {_range=Just (Range p p), _rangeLength=Nothing, _text="fd"} + ,TextDocumentContentChangeEvent {_range=Just (Range p p'), _rangeLength=Nothing, _text=""}) + editHeader = editPair 0 0 + editImport = editPair 2 10 + editBody = editPair 3 10 + + noParse = False + yesParse = True + + noDepends = False + yesDepends = True + + noSession = False + yesSession = True + + noTc = False + yesTc = True + +cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> Bool -> TestTree +cancellationTestGroup name edits dependsOutcome sessionDepsOutcome parseOutcome tcOutcome = testGroup name + [ cancellationTemplate edits Nothing + , cancellationTemplate edits $ Just ("GetFileContents", True) + , cancellationTemplate edits $ Just ("GhcSession", True) + -- the outcome for GetModSummary is always True because parseModuleHeader never fails (!) + , cancellationTemplate edits $ Just ("GetModSummary", True) + , cancellationTemplate edits $ Just ("GetModSummaryWithoutTimestamps", True) + -- getLocatedImports never fails + , cancellationTemplate edits $ Just ("GetLocatedImports", True) + , cancellationTemplate edits $ Just ("GetDependencies", dependsOutcome) + , cancellationTemplate edits $ Just ("GhcSessionDeps", sessionDepsOutcome) + , cancellationTemplate edits $ Just ("GetParsedModule", parseOutcome) + , cancellationTemplate edits $ Just ("TypeCheck", tcOutcome) + , cancellationTemplate edits $ Just ("GetHieAst", tcOutcome) + ] + +cancellationTemplate :: (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Maybe (String, Bool) -> TestTree +cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ runTestNoKick $ do + doc <- createDoc "Foo.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module Foo where" + , "import Data.List()" + , "f0 x = (x,x)" + ] + + -- for the example above we expect one warning + let missingSigDiags = [(DsWarning, (3, 0), "Top-level binding") ] + typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags + + -- Now we edit the document and wait for the given key (if any) + changeDoc doc [edit] + whenJust mbKey $ \(key, expectedResult) -> do + Right WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc + liftIO $ ideResultSuccess @?= expectedResult + + -- The 2nd edit cancels the active session and unbreaks the file + -- wait for typecheck and check that the current diagnostics are accurate + changeDoc doc [undoEdit] + typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags + + expectNoMoreDiagnostics 0.5 + where + -- similar to run except it disables kick + runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s + + typeCheck doc = do + Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + liftIO $ assertBool "The file should typecheck" ideResultSuccess + -- wait for the debouncer to publish diagnostics if the rule runs + liftIO $ sleep 0.2 + -- flush messages to ensure current diagnostics state is updated + flushMessages + +codeActionTests :: TestTree +codeActionTests = testGroup "code actions" + [ renameActionTests + , typeWildCardActionTests + , removeImportTests + , extendImportTests + , suggesImportClassMethodTests + , suggestImportTests + , suggestHideShadowTests + , suggestImportDisambiguationTests + , fixConstructorImportTests + , importRenameActionTests + , fillTypedHoleTests + , addSigActionTests + , insertNewDefinitionTests + , deleteUnusedDefinitionTests + , addInstanceConstraintTests + , addFunctionConstraintTests + , removeRedundantConstraintsTests + , addTypeAnnotationsToLiteralsTest + , exportUnusedTests + , addImplicitParamsConstraintTests + , removeExportTests + ] + +codeActionHelperFunctionTests :: TestTree +codeActionHelperFunctionTests = testGroup "code action helpers" + [ + extendImportTestsRegEx + ] + + +codeLensesTests :: TestTree +codeLensesTests = testGroup "code lenses" + [ addSigLensesTests + ] + +watchedFilesTests :: TestTree +watchedFilesTests = testGroup "watched files" + [ testSession' "workspace files" $ \sessionDir -> do + liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}" + _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule" + watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics + + -- Expect 1 subscription: we only ever send one + liftIO $ length watchedFileRegs @?= 1 + + , testSession' "non workspace file" $ \sessionDir -> do + tmpDir <- liftIO getTemporaryDirectory + liftIO $ writeFile (sessionDir "hie.yaml") ("cradle: {direct: {arguments: [\"-i" <> tmpDir <> "\", \"A\", \"WatchedFilesMissingModule\"]}}") + _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule" + watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics + + -- Expect 1 subscription: we only ever send one + liftIO $ length watchedFileRegs @?= 1 + + -- TODO add a test for didChangeWorkspaceFolder + ] + +renameActionTests :: TestTree +renameActionTests = testGroup "rename actions" + [ testSession "change to local variable name" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> Int" + , "foo argName = argNme" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’" + executeCodeAction action + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "foo :: Int -> Int" + , "foo argName = argName" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "change to name of imported function" $ do + let content = T.unlines + [ "module Testing where" + , "import Data.Maybe (maybeToList)" + , "foo :: Maybe a -> [a]" + , "foo = maybToList" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’" + executeCodeAction action + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "import Data.Maybe (maybeToList)" + , "foo :: Maybe a -> [a]" + , "foo = maybeToList" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "suggest multiple local variable names" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Char -> Char -> Char -> Char" + , "foo argument1 argument2 argument3 = argumentX" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45)) + ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"] + return() + , testSession "change infix function" $ do + let content = T.unlines + [ "module Testing where" + , "monus :: Int -> Int" + , "monus x y = max 0 (x - y)" + , "foo x y = x `monnus` y" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20)) + [fixTypo] <- pure [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ] + executeCodeAction fixTypo + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "monus :: Int -> Int" + , "monus x y = max 0 (x - y)" + , "foo x y = x `monus` y" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + ] + +typeWildCardActionTests :: TestTree +typeWildCardActionTests = testGroup "type wildcard actions" + [ testSession "global signature" $ do + let content = T.unlines + [ "module Testing where" + , "func :: _" + , "func x = x" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10)) + let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands + , "Use type signature" `T.isInfixOf` actionTitle + ] + executeCodeAction addSignature + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "func :: (p -> p)" + , "func x = x" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "multi-line message" $ do + let content = T.unlines + [ "module Testing where" + , "func :: _" + , "func x y = x + y" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10)) + let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands + , "Use type signature" `T.isInfixOf` actionTitle + ] + executeCodeAction addSignature + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "func :: (Integer -> Integer -> Integer)" + , "func x y = x + y" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "local signature" $ do + let content = T.unlines + [ "module Testing where" + , "func :: Int -> Int" + , "func x =" + , " let y :: _" + , " y = x * 2" + , " in y" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10)) + let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands + , "Use type signature" `T.isInfixOf` actionTitle + ] + executeCodeAction addSignature + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "func :: Int -> Int" + , "func x =" + , " let y :: (Int)" + , " y = x * 2" + , " in y" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + ] + +removeImportTests :: TestTree +removeImportTests = testGroup "remove import actions" + [ testSession "redundant" $ do + let contentA = T.unlines + [ "module ModuleA where" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA" + , "stuffB :: Integer" + , "stuffB = 123" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "stuffB :: Integer" + , "stuffB = 123" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "qualified redundant" $ do + let contentA = T.unlines + [ "module ModuleA where" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import qualified ModuleA" + , "stuffB :: Integer" + , "stuffB = 123" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "stuffB :: Integer" + , "stuffB = 123" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant binding" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "stuffA = False" + , "stuffB :: Integer" + , "stuffB = 123" + , "stuffC = ()" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (stuffA, stuffB, stuffC, stuffA)" + , "main = print stuffB" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove stuffA, stuffC from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (stuffB)" + , "main = print stuffB" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant operator" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "a !! _b = a" + , "a _b = a" + , "stuffB :: Integer" + , "stuffB = 123" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import qualified ModuleA as A ((), stuffB, (!!))" + , "main = print A.stuffB" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove !!, from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import qualified ModuleA as A (stuffB)" + , "main = print A.stuffB" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant all import" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "data A = A" + , "stuffB :: Integer" + , "stuffB = 123" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (A(..), stuffB)" + , "main = print stuffB" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove A from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (stuffB)" + , "main = print stuffB" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant constructor import" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "data D = A | B" + , "data E = F" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (D(A,B), E(F))" + , "main = B" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove A, E, F from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (D(B))" + , "main = B" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "import containing the identifier Strict" $ do + let contentA = T.unlines + [ "module Strict where" + ] + _docA <- createDoc "Strict.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import Strict" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "remove all" $ do + let content = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleA where" + , "import Data.Function (fix, (&))" + , "import qualified Data.Functor.Const" + , "import Data.Functor.Identity" + , "import Data.Functor.Sum (Sum (InL, InR))" + , "import qualified Data.Kind as K (Constraint, Type)" + , "x = InL (Identity 123)" + , "y = fix id" + , "type T = K.Type" + ] + doc <- createDoc "ModuleC.hs" "haskell" content + _ <- waitForDiagnostics + [_, _, _, _, InR action@CodeAction { _title = actionTitle }] + <- getCodeActions doc (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove all redundant imports" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleA where" + , "import Data.Function (fix)" + , "import Data.Functor.Identity" + , "import Data.Functor.Sum (Sum (InL))" + , "import qualified Data.Kind as K (Type)" + , "x = InL (Identity 123)" + , "y = fix id" + , "type T = K.Type" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + ] + +extendImportTests :: TestTree +extendImportTests = testGroup "extend import actions" + [ testGroup "with checkAll" $ tests True + , testGroup "without checkAll" $ tests False + ] + where + tests overrideCheckProject = + [ testSession "extend single line import with value" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffB)" + , "main = print (stuffA, stuffB)" + ]) + (Range (Position 3 17) (Position 3 18)) + ["Add stuffA to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffB, stuffA)" + , "main = print (stuffA, stuffB)" + ]) + , testSession "extend single line import with operator" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "(.*) :: Integer -> Integer -> Integer" + , "x .* y = x * y" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffB)" + , "main = print (stuffB .* stuffB)" + ]) + (Range (Position 3 17) (Position 3 18)) + ["Add (.*) to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffB, (.*))" + , "main = print (stuffB .* stuffB)" + ]) + , testSession "extend single line import with type" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "type A = Double" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA ()" + , "b :: A" + , "b = 0" + ]) + (Range (Position 2 5) (Position 2 5)) + ["Add A to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A)" + , "b :: A" + , "b = 0" + ]) + , testSession "extend single line import with constructor" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data A = Constructor" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (A)" + , "b :: A" + , "b = Constructor" + ]) + (Range (Position 2 5) (Position 2 5)) + ["Add A(Constructor) to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A (Constructor))" + , "b :: A" + , "b = Constructor" + ]) + , testSession "extend single line import with constructor (with comments)" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data A = Constructor" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (A ({-Constructor-}))" + , "b :: A" + , "b = Constructor" + ]) + (Range (Position 2 5) (Position 2 5)) + ["Add A(Constructor) to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A (Constructor{-Constructor-}))" + , "b :: A" + , "b = Constructor" + ]) + , testSession "extend single line import with mixed constructors" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data A = ConstructorFoo | ConstructorBar" + , "a = 1" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (A (ConstructorBar), a)" + , "b :: A" + , "b = ConstructorFoo" + ]) + (Range (Position 2 5) (Position 2 5)) + ["Add A(ConstructorFoo) to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A (ConstructorBar, ConstructorFoo), a)" + , "b :: A" + , "b = ConstructorFoo" + ]) + , testSession "extend single line qualified import with value" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import qualified ModuleA as A (stuffB)" + , "main = print (A.stuffA, A.stuffB)" + ]) + (Range (Position 3 17) (Position 3 18)) + ["Add stuffA to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import qualified ModuleA as A (stuffB, stuffA)" + , "main = print (A.stuffA, A.stuffB)" + ]) + , testSession "extend multi line import with value" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (stuffB" + , " )" + , "main = print (stuffA, stuffB)" + ]) + (Range (Position 3 17) (Position 3 18)) + ["Add stuffA to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (stuffB, stuffA" + , " )" + , "main = print (stuffA, stuffB)" + ]) + , testSession "extend single line import with method within class" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "class C a where" + , " m1 :: a -> a" + , " m2 :: a -> a" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1))" + , "b = m2" + ]) + (Range (Position 2 5) (Position 2 5)) + ["Add C(m2) to the import list of ModuleA", + "Add m2 to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1, m2))" + , "b = m2" + ]) + , testSession "extend single line import with method without class" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "class C a where" + , " m1 :: a -> a" + , " m2 :: a -> a" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1))" + , "b = m2" + ]) + (Range (Position 2 5) (Position 2 5)) + ["Add m2 to the import list of ModuleA", + "Add C(m2) to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1), m2)" + , "b = m2" + ]) + , testSession "extend import list with multiple choices" $ template + [("ModuleA.hs", T.unlines + -- this is just a dummy module to help the arguments needed for this test + [ "module ModuleA (bar) where" + , "bar = 10" + ]), + ("ModuleB.hs", T.unlines + -- this is just a dummy module to help the arguments needed for this test + [ "module ModuleB (bar) where" + , "bar = 10" + ])] + ("ModuleC.hs", T.unlines + [ "module ModuleC where" + , "import ModuleB ()" + , "import ModuleA ()" + , "foo = bar" + ]) + (Range (Position 3 17) (Position 3 18)) + ["Add bar to the import list of ModuleA", + "Add bar to the import list of ModuleB"] + (T.unlines + [ "module ModuleC where" + , "import ModuleB ()" + , "import ModuleA (bar)" + , "foo = bar" + ]) + , testSession "extend import list with constructor of type operator" $ template + [] + ("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "import Data.Type.Equality ((:~:))" + , "x :: (:~:) [] []" + , "x = Refl" + ]) + (Range (Position 3 17) (Position 3 18)) + ["Add (:~:)(Refl) to the import list of Data.Type.Equality"] + (T.unlines + [ "module ModuleA where" + , "import Data.Type.Equality ((:~:) (Refl))" + , "x :: (:~:) [] []" + , "x = Refl" + ]) + ] + where + codeActionTitle CodeAction{_title=x} = x + + template setUpModules moduleUnderTest range expectedTitles expectedContentB = do + sendNotification SWorkspaceDidChangeConfiguration + (DidChangeConfigurationParams $ toJSON + def{checkProject = overrideCheckProject}) + + + mapM_ (\x -> createDoc (fst x) "haskell" (snd x)) setUpModules + docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest) + _ <- waitForDiagnostics + waitForProgressDone + actionsOrCommands <- getCodeActions docB range + let codeActions = + filter + (T.isPrefixOf "Add" . codeActionTitle) + [ca | InR ca <- actionsOrCommands] + actualTitles = codeActionTitle <$> codeActions + -- Note that we are not testing the order of the actions, as the + -- order of the expected actions indicates which one we'll execute + -- in this test, i.e., the first one. + liftIO $ sort expectedTitles @=? sort actualTitles + + -- Execute the action with the same title as the first expected one. + -- Since we tested that both lists have the same elements (possibly + -- in a different order), this search cannot fail. + let firstTitle:_ = expectedTitles + action = fromJust $ + find ((firstTitle ==) . codeActionTitle) codeActions + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ expectedContentB @=? contentAfterAction + +extendImportTestsRegEx :: TestTree +extendImportTestsRegEx = testGroup "regex parsing" + [ + testCase "parse invalid multiple imports" $ template "foo bar foo" Nothing + , testCase "parse malformed import list" $ template + "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n \8216Data.Map\8217)" + Nothing + , testCase "parse multiple imports" $ template + "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n \8216Data.Map\8217 (app/testlsp.hs:7:1-18)\n \8216Data.HashMap.Strict\8217 (app/testlsp.hs:8:1-29)" + $ Just ("fromList",[("Data.Map","app/testlsp.hs:7:1-18"),("Data.HashMap.Strict","app/testlsp.hs:8:1-29")]) + ] + where + template message expected = do + liftIO $ matchRegExMultipleImports message @=? expected + +suggesImportClassMethodTests :: TestTree +suggesImportClassMethodTests = + testGroup + "suggest import class methods" + [ testGroup + "new" + [ testSession "via parent" $ + template + [ "module A where", + "" + ] + (Range (Position 5 2) (Position 5 8)) + "Import Data.Semigroup with Semigroup(stimes)" + [ "module A where", + "", + "import Data.Semigroup (Semigroup(stimes))" + ], + testSession "top level" $ + template + [ "module A where", + "" + ] + (Range (Position 5 2) (Position 5 8)) + "Import Data.Semigroup with stimes" + [ "module A where", + "", + "import Data.Semigroup (stimes)" + ], + testSession "all" $ + template + [ "module A where", + "" + ] + (Range (Position 5 2) (Position 5 8)) + "Import Data.Semigroup" + [ "module A where", + "", + "import Data.Semigroup" + ] + ], + testGroup + "extend" + [ testSession "via parent" $ + template + [ "module A where", + "", + "import Data.Semigroup ()" + ] + (Range (Position 6 2) (Position 6 8)) + "Add Semigroup(stimes) to the import list of Data.Semigroup" + [ "module A where", + "", + "import Data.Semigroup (Semigroup (stimes))" + ], + testSession "top level" $ + template + [ "module A where", + "", + "import Data.Semigroup ()" + ] + (Range (Position 6 2) (Position 6 8)) + "Add stimes to the import list of Data.Semigroup" + [ "module A where", + "", + "import Data.Semigroup (stimes)" + ] + ] + ] + where + decls = + [ "data X = X", + "instance Semigroup X where", + " (<>) _ _ = X", + " stimes _ _ = X" + ] + template beforeContent range executeTitle expectedContent = do + doc <- createDoc "A.hs" "haskell" $ T.unlines (beforeContent <> decls) + _ <- waitForDiagnostics + waitForProgressDone + actions <- getCodeActions doc range + let actions' = [x | InR x <- actions] + titles = [_title | CodeAction {_title} <- actions'] + liftIO $ executeTitle `elem` titles @? T.unpack executeTitle <> " does not in " <> show titles + executeCodeAction $ fromJust $ find (\CodeAction {_title} -> _title == executeTitle) actions' + content <- documentContents doc + liftIO $ T.unlines (expectedContent <> decls) @=? content + +suggestImportTests :: TestTree +suggestImportTests = testGroup "suggest import actions" + [ testGroup "Dont want suggestion" + [ -- extend import + test False ["Data.List.NonEmpty ()"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" + -- data constructor + , test False [] "f = First" [] "import Data.Monoid (First)" + -- internal module + , test False [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable.Internal (Typeable)" + -- package not in scope + , test False [] "f = quickCheck" [] "import Test.QuickCheck (quickCheck)" + -- don't omit the parent data type of a constructor + , test False [] "f ExitSuccess = ()" [] "import System.Exit (ExitSuccess)" + ] + , testGroup "want suggestion" + [ wantWait [] "f = foo" [] "import Foo (foo)" + , wantWait [] "f = Bar" [] "import Bar (Bar(Bar))" + , wantWait [] "f :: Bar" [] "import Bar (Bar)" + , test True [] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" + , test True [] "f = (:|)" [] "import Data.List.NonEmpty (NonEmpty((:|)))" + , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural (Natural)" + , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural" + , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty (NonEmpty)" + , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty" + , test True [] "f = First" [] "import Data.Monoid (First(First))" + , test True [] "f = Endo" [] "import Data.Monoid (Endo(Endo))" + , test True [] "f = Version" [] "import Data.Version (Version(Version))" + , test True [] "f ExitSuccess = ()" [] "import System.Exit (ExitCode(ExitSuccess))" + , test True [] "f = AssertionFailed" [] "import Control.Exception (AssertionFailed(AssertionFailed))" + , test True ["Prelude"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" + , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative (Alternative)" + , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative" + , test True [] "f = empty" [] "import Control.Applicative (Alternative(empty))" + , test True [] "f = empty" [] "import Control.Applicative (empty)" + , test True [] "f = empty" [] "import Control.Applicative" + , test True [] "f = (&)" [] "import Data.Function ((&))" + , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE" + , test True [] "f = Data.List.NonEmpty.nonEmpty" [] "import qualified Data.List.NonEmpty" + , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)" + , test True [] "f = pack" [] "import Data.Text (pack)" + , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)" + , test True [] "f = [] & id" [] "import Data.Function ((&))" + , test True [] "f = (&) [] id" [] "import Data.Function ((&))" + , test True [] "f = (.|.)" [] "import Data.Bits (Bits((.|.)))" + , test True [] "f = (.|.)" [] "import Data.Bits ((.|.))" + , test True + ["qualified Data.Text as T" + ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" + , test True + [ "qualified Data.Text as T" + , "qualified Data.Function as T" + ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" + , test True + [ "qualified Data.Text as T" + , "qualified Data.Function as T" + , "qualified Data.Functor as T" + , "qualified Data.Data as T" + ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" + ] + ] + where + test = test' False + wantWait = test' True True + test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do + let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other + after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other + cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo]}}" + liftIO $ writeFileUTF8 (dir "hie.yaml") cradle + doc <- createDoc "Test.hs" "haskell" before + waitForProgressDone + _diags <- waitForDiagnostics + -- there isn't a good way to wait until the whole project is checked atm + when waitForCheckProject $ liftIO $ sleep 0.5 + let defLine = length imps + 1 + range = Range (Position defLine 0) (Position defLine maxBound) + actions <- getCodeActions doc range + if wanted + then do + action <- liftIO $ pickActionWithTitle newImp actions + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ after @=? contentAfterAction + else + liftIO $ [_title | InR CodeAction{_title} <- actions, _title == newImp ] @?= [] + +suggestImportDisambiguationTests :: TestTree +suggestImportDisambiguationTests = testGroup "suggest import disambiguation actions" + [ testGroup "Hiding strategy works" + [ testGroup "fromList" + [ testCase "AVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use AVec for fromList, hiding other imports" + "HideFunction.expected.fromList.A.hs" + , testCase "BVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use BVec for fromList, hiding other imports" + "HideFunction.expected.fromList.B.hs" + ] + , testGroup "(++)" + [ testCase "EVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use EVec for ++, hiding other imports" + "HideFunction.expected.append.E.hs" + , testCase "Prelude" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use Prelude for ++, hiding other imports" + "HideFunction.expected.append.Prelude.hs" + , testCase "AVec, indented" $ + compareTwo "HidePreludeIndented.hs" [(3,8)] + "Use AVec for ++, hiding other imports" + "HidePreludeIndented.expected.hs" + + ] + , testGroup "Vec (type)" + [ testCase "AVec" $ + compareTwo + "HideType.hs" [(8,15)] + "Use AVec for Vec, hiding other imports" + "HideType.expected.A.hs" + , testCase "EVec" $ + compareTwo + "HideType.hs" [(8,15)] + "Use EVec for Vec, hiding other imports" + "HideType.expected.E.hs" + ] + ] + , testGroup "Qualify strategy" + [ testCase "won't suggest full name for qualified module" $ + withHideFunction [(8,9),(10,8)] $ \_ actions -> do + liftIO $ + assertBool "EVec.fromList must not be suggested" $ + "Replace with qualified: EVec.fromList" `notElem` + [ actionTitle + | InR CodeAction { _title = actionTitle } <- actions + ] + liftIO $ + assertBool "EVec.++ must not be suggested" $ + "Replace with qualified: EVec.++" `notElem` + [ actionTitle + | InR CodeAction { _title = actionTitle } <- actions + ] + , testGroup "fromList" + [ testCase "EVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Replace with qualified: E.fromList" + "HideFunction.expected.qualified.fromList.E.hs" + ] + , testGroup "(++)" + [ testCase "Prelude, parensed" $ + compareHideFunctionTo [(8,9),(10,8)] + "Replace with qualified: Prelude.++" + "HideFunction.expected.qualified.append.Prelude.hs" + , testCase "Prelude, infix" $ + compareTwo + "HideQualifyInfix.hs" [(4,19)] + "Replace with qualified: Prelude.++" + "HideQualifyInfix.expected.hs" + , testCase "Prelude, left section" $ + compareTwo + "HideQualifySectionLeft.hs" [(4,15)] + "Replace with qualified: Prelude.++" + "HideQualifySectionLeft.expected.hs" + , testCase "Prelude, right section" $ + compareTwo + "HideQualifySectionRight.hs" [(4,18)] + "Replace with qualified: Prelude.++" + "HideQualifySectionRight.expected.hs" + ] + ] + ] + where + hidingDir = "test/data/hiding" + compareTwo original locs cmd expected = + withTarget original locs $ \doc actions -> do + expected <- liftIO $ + readFileUtf8 (hidingDir expected) + action <- liftIO $ pickActionWithTitle cmd actions + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ T.replace "\r\n" "\n" expected @=? contentAfterAction + compareHideFunctionTo = compareTwo "HideFunction.hs" + auxFiles = ["AVec.hs", "BVec.hs", "CVec.hs", "DVec.hs", "EVec.hs"] + withTarget file locs k = withTempDir $ \dir -> runInDir dir $ do + liftIO $ mapM_ (\fp -> copyFile (hidingDir fp) $ dir fp) + $ file : auxFiles + doc <- openDoc file "haskell" + waitForProgressDone + void $ expectDiagnostics [(file, [(DsError, loc, "Ambiguous occurrence") | loc <- locs])] + contents <- documentContents doc + let range = Range (Position 0 0) (Position (length $ T.lines contents) 0) + actions <- getCodeActions doc range + k doc actions + withHideFunction = withTarget ("HideFunction" <.> "hs") + +suggestHideShadowTests :: TestTree +suggestHideShadowTests = + testGroup + "suggest hide shadow" + [ testGroup + "single" + [ testOneCodeAction + "hide unsued" + "Hide on from Data.Function" + (1, 2) + (1, 4) + [ "import Data.Function" + , "f on = on" + , "g on = on" + ] + [ "import Data.Function hiding (on)" + , "f on = on" + , "g on = on" + ] + , testOneCodeAction + "extend hiding unsued" + "Hide on from Data.Function" + (1, 2) + (1, 4) + [ "import Data.Function hiding ((&))" + , "f on = on" + ] + [ "import Data.Function hiding (on, (&))" + , "f on = on" + ] + , testOneCodeAction + "delete unsued" + "Hide on from Data.Function" + (1, 2) + (1, 4) + [ "import Data.Function ((&), on)" + , "f on = on" + ] + [ "import Data.Function ((&))" + , "f on = on" + ] + , testOneCodeAction + "hide operator" + "Hide & from Data.Function" + (1, 2) + (1, 5) + [ "import Data.Function" + , "f (&) = (&)" + ] + [ "import Data.Function hiding ((&))" + , "f (&) = (&)" + ] + , testOneCodeAction + "remove operator" + "Hide & from Data.Function" + (1, 2) + (1, 5) + [ "import Data.Function ((&), on)" + , "f (&) = (&)" + ] + [ "import Data.Function ( on)" + , "f (&) = (&)" + ] + , noCodeAction + "don't remove already used" + (2, 2) + (2, 4) + [ "import Data.Function" + , "g = on" + , "f on = on" + ] + ] + , testGroup + "multi" + [ testOneCodeAction + "hide from B" + "Hide ++ from B" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B hiding ((++))" + , "import C" + , "f (++) = (++)" + ] + , testOneCodeAction + "hide from C" + "Hide ++ from C" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B" + , "import C hiding ((++))" + , "f (++) = (++)" + ] + , testOneCodeAction + "hide from Prelude" + "Hide ++ from Prelude" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B" + , "import C" + , "import Prelude hiding ((++))" + , "f (++) = (++)" + ] + , testMultiCodeActions + "manual hide all" + [ "Hide ++ from Prelude" + , "Hide ++ from C" + , "Hide ++ from B" + ] + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B hiding ((++))" + , "import C hiding ((++))" + , "import Prelude hiding ((++))" + , "f (++) = (++)" + ] + , testOneCodeAction + "auto hide all" + "Hide ++ from all occurence imports" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B hiding ((++))" + , "import C hiding ((++))" + , "import Prelude hiding ((++))" + , "f (++) = (++)" + ] + ] + ] + where + testOneCodeAction testName actionName start end origin expected = + helper testName start end origin expected $ \cas -> do + action <- liftIO $ pickActionWithTitle actionName cas + executeCodeAction action + noCodeAction testName start end origin = + helper testName start end origin origin $ \cas -> do + liftIO $ cas @?= [] + testMultiCodeActions testName actionNames start end origin expected = + helper testName start end origin expected $ \cas -> do + let r = [ca | (InR ca) <- cas, ca ^. L.title `elem` actionNames] + liftIO $ + (length r == length actionNames) + @? "Expected " <> show actionNames <> ", but got " <> show cas <> " which is not its superset" + forM_ r executeCodeAction + helper testName (line1, col1) (line2, col2) origin expected k = testSession testName $ do + void $ createDoc "B.hs" "haskell" $ T.unlines docB + void $ createDoc "C.hs" "haskell" $ T.unlines docC + doc <- createDoc "A.hs" "haskell" $ T.unlines (header <> origin) + void waitForDiagnostics + waitForProgressDone + cas <- getCodeActions doc (Range (Position (line1 + length header) col1) (Position (line2 + length header) col2)) + void $ k [x | x@(InR ca) <- cas, "Hide" `T.isPrefixOf` (ca ^. L.title)] + contentAfter <- documentContents doc + liftIO $ contentAfter @?= T.unlines (header <> expected) + header = + [ "{-# OPTIONS_GHC -Wname-shadowing #-}" + , "module A where" + , "" + ] + -- for multi group + docB = + [ "module B where" + , "(++) = id" + ] + docC = + [ "module C where" + , "(++) = id" + ] + +insertNewDefinitionTests :: TestTree +insertNewDefinitionTests = testGroup "insert new definition actions" + [ testSession "insert new function definition" $ do + let txtB = + ["foo True = select [True]" + , "" + ,"foo False = False" + ] + txtB' = + ["" + ,"someOtherCode = ()" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> + getCodeActions docB (R 1 0 1 50) + liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines (txtB ++ + [ "" + , "select :: [Bool] -> Bool" + , "select = error \"not implemented\"" + ] + ++ txtB') + , testSession "define a hole" $ do + let txtB = + ["foo True = _select [True]" + , "" + ,"foo False = False" + ] + txtB' = + ["" + ,"someOtherCode = ()" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> + getCodeActions docB (R 1 0 1 50) + liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines ( + ["foo True = select [True]" + , "" + ,"foo False = False" + , "" + , "select :: [Bool] -> Bool" + , "select = error \"not implemented\"" + ] + ++ txtB') + ] + + +deleteUnusedDefinitionTests :: TestTree +deleteUnusedDefinitionTests = testGroup "delete unused definition action" + [ testSession "delete unused top level binding" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "f :: Int -> Int" + , "f 1 = let a = 1" + , " in a" + , "f 2 = 2" + , "" + , "some = ()" + ]) + (4, 0) + "Delete ‘f’" + (T.unlines [ + "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "some = ()" + ]) + + , testSession "delete unused top level binding defined in infix form" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "myPlus :: Int -> Int -> Int" + , "a `myPlus` b = a + b" + , "" + , "some = ()" + ]) + (4, 2) + "Delete ‘myPlus’" + (T.unlines [ + "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "some = ()" + ]) + , testSession "delete unused binding in where clause" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (h, g) where" + , "" + , "h :: Int" + , "h = 3" + , "" + , "g :: Int" + , "g = 6" + , " where" + , " h :: Int" + , " h = 4" + , "" + ]) + (10, 4) + "Delete ‘h’" + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (h, g) where" + , "" + , "h :: Int" + , "h = 3" + , "" + , "g :: Int" + , "g = 6" + , " where" + , "" + ]) + , testSession "delete unused binding with multi-oneline signatures front" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (b, c) where" + , "" + , "a, b, c :: Int" + , "a = 3" + , "b = 4" + , "c = 5" + ]) + (4, 0) + "Delete ‘a’" + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (b, c) where" + , "" + , "b, c :: Int" + , "b = 4" + , "c = 5" + ]) + , testSession "delete unused binding with multi-oneline signatures mid" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (a, c) where" + , "" + , "a, b, c :: Int" + , "a = 3" + , "b = 4" + , "c = 5" + ]) + (5, 0) + "Delete ‘b’" + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (a, c) where" + , "" + , "a, c :: Int" + , "a = 3" + , "c = 5" + ]) + , testSession "delete unused binding with multi-oneline signatures end" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (a, b) where" + , "" + , "a, b, c :: Int" + , "a = 3" + , "b = 4" + , "c = 5" + ]) + (6, 0) + "Delete ‘c’" + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (a, b) where" + , "" + , "a, b :: Int" + , "a = 3" + , "b = 4" + ]) + ] + where + testFor source pos expectedTitle expectedResult = do + docId <- createDoc "A.hs" "haskell" source + expectDiagnostics [ ("A.hs", [(DsWarning, pos, "not used")]) ] + + (action, title) <- extractCodeAction docId "Delete" + + liftIO $ title @?= expectedTitle + executeCodeAction action + contentAfterAction <- documentContents docId + liftIO $ contentAfterAction @?= expectedResult + + extractCodeAction docId actionPrefix = do + [action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R 0 0 0 0) [actionPrefix] + return (action, actionTitle) + +addTypeAnnotationsToLiteralsTest :: TestTree +addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals to satisfy contraints" + [ + testSession "add default type to satisfy one contraint" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A (f) where" + , "" + , "f = 1" + ]) + [ (DsWarning, (3, 4), "Defaulting the following constraint") ] + "Add type annotation ‘Integer’ to ‘1’" + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A (f) where" + , "" + , "f = (1 :: Integer)" + ]) + + , testSession "add default type to satisfy one contraint in nested expressions" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A where" + , "" + , "f =" + , " let x = 3" + , " in x" + ]) + [ (DsWarning, (4, 12), "Defaulting the following constraint") ] + "Add type annotation ‘Integer’ to ‘3’" + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A where" + , "" + , "f =" + , " let x = (3 :: Integer)" + , " in x" + ]) + , testSession "add default type to satisfy one contraint in more nested expressions" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A where" + , "" + , "f =" + , " let x = let y = 5 in y" + , " in x" + ]) + [ (DsWarning, (4, 20), "Defaulting the following constraint") ] + "Add type annotation ‘Integer’ to ‘5’" + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A where" + , "" + , "f =" + , " let x = let y = (5 :: Integer) in y" + , " in x" + ]) + , testSession "add default type to satisfy one contraint with duplicate literals" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f = seq \"debug\" traceShow \"debug\"" + ]) + [ (DsWarning, (6, 8), "Defaulting the following constraint") + , (DsWarning, (6, 16), "Defaulting the following constraint") + ] + "Add type annotation ‘[Char]’ to ‘\"debug\"’" + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f = seq (\"debug\" :: [Char]) traceShow \"debug\"" + ]) + , testSession "add default type to satisfy two contraints" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f a = traceShow \"debug\" a" + ]) + [ (DsWarning, (6, 6), "Defaulting the following constraint") ] + "Add type annotation ‘[Char]’ to ‘\"debug\"’" + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f a = traceShow (\"debug\" :: [Char]) a" + ]) + , testSession "add default type to satisfy two contraints with duplicate literals" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))" + ]) + [ (DsWarning, (6, 54), "Defaulting the following constraint") ] + "Add type annotation ‘[Char]’ to ‘\"debug\"’" + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: [Char])))" + ]) + ] + where + testFor source diag expectedTitle expectedResult = do + docId <- createDoc "A.hs" "haskell" source + expectDiagnostics [ ("A.hs", diag) ] + + (action, title) <- extractCodeAction docId "Add type annotation" + + liftIO $ title @?= expectedTitle + executeCodeAction action + contentAfterAction <- documentContents docId + liftIO $ contentAfterAction @?= expectedResult + + extractCodeAction docId actionPrefix = do + [action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R 0 0 0 0) [actionPrefix] + return (action, actionTitle) + + +fixConstructorImportTests :: TestTree +fixConstructorImportTests = testGroup "fix import actions" + [ testSession "fix constructor import" $ template + (T.unlines + [ "module ModuleA where" + , "data A = Constructor" + ]) + (T.unlines + [ "module ModuleB where" + , "import ModuleA(Constructor)" + ]) + (Range (Position 1 10) (Position 1 11)) + "Fix import of A(Constructor)" + (T.unlines + [ "module ModuleB where" + , "import ModuleA(A(Constructor))" + ]) + ] + where + template contentA contentB range expectedAction expectedContentB = do + _docA <- createDoc "ModuleA.hs" "haskell" contentA + docB <- createDoc "ModuleB.hs" "haskell" contentB + _diags <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> + getCodeActions docB range + liftIO $ expectedAction @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ expectedContentB @=? contentAfterAction + +importRenameActionTests :: TestTree +importRenameActionTests = testGroup "import rename actions" + [ testSession "Data.Mape -> Data.Map" $ check "Map" + , testSession "Data.Mape -> Data.Maybe" $ check "Maybe" ] where + check modname = do + let content = T.unlines + [ "module Testing where" + , "import Data.Mape" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16)) + let [changeToMap] = [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ] + executeCodeAction changeToMap + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "import Data." <> modname + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + +fillTypedHoleTests :: TestTree +fillTypedHoleTests = let + + sourceCode :: T.Text -> T.Text -> T.Text -> T.Text + sourceCode a b c = T.unlines + [ "module Testing where" + , "" + , "globalConvert :: Int -> String" + , "globalConvert = undefined" + , "" + , "globalInt :: Int" + , "globalInt = 3" + , "" + , "bar :: Int -> Int -> String" + , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ") where" + , " localConvert = (flip replicate) 'x'" + , "" + , "foo :: () -> Int -> String" + , "foo = undefined" + + ] + + check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree + check actionTitle + oldA oldB oldC + newA newB newC = testSession (T.unpack actionTitle) $ do + let originalCode = sourceCode oldA oldB oldC + let expectedCode = sourceCode newA newB newC + doc <- createDoc "Testing.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound)) + chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + in + testGroup "fill typed holes" + [ check "replace _ with show" + "_" "n" "n" + "show" "n" "n" + + , check "replace _ with globalConvert" + "_" "n" "n" + "globalConvert" "n" "n" + + , check "replace _convertme with localConvert" + "_convertme" "n" "n" + "localConvert" "n" "n" + + , check "replace _b with globalInt" + "_a" "_b" "_c" + "_a" "globalInt" "_c" + + , check "replace _c with globalInt" + "_a" "_b" "_c" + "_a" "_b" "globalInt" + + , check "replace _c with parameterInt" + "_a" "_b" "_c" + "_a" "_b" "parameterInt" + , check "replace _ with foo _" + "_" "n" "n" + "(foo _)" "n" "n" + , testSession "replace _toException with E.toException" $ do + let mkDoc x = T.unlines + [ "module Testing where" + , "import qualified Control.Exception as E" + , "ioToSome :: E.IOException -> E.SomeException" + , "ioToSome = " <> x ] + doc <- createDoc "Test.hs" "haskell" $ mkDoc "_toException" + _ <- waitForDiagnostics + actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBound)) + chosen <- liftIO $ pickActionWithTitle "replace _toException with E.toException" actions + executeCodeAction chosen + modifiedCode <- documentContents doc + liftIO $ mkDoc "E.toException" @=? modifiedCode + ] + +addInstanceConstraintTests :: TestTree +addInstanceConstraintTests = let + missingConstraintSourceCode :: Maybe T.Text -> T.Text + missingConstraintSourceCode mConstraint = + let constraint = maybe "" (<> " => ") mConstraint + in T.unlines + [ "module Testing where" + , "" + , "data Wrap a = Wrap a" + , "" + , "instance " <> constraint <> "Eq (Wrap a) where" + , " (Wrap x) == (Wrap y) = x == y" + ] + + incompleteConstraintSourceCode :: Maybe T.Text -> T.Text + incompleteConstraintSourceCode mConstraint = + let constraint = maybe "Eq a" (\c -> "(Eq a, " <> c <> ")") mConstraint + in T.unlines + [ "module Testing where" + , "" + , "data Pair a b = Pair a b" + , "" + , "instance " <> constraint <> " => Eq (Pair a b) where" + , " (Pair x y) == (Pair x' y') = x == x' && y == y'" + ] + + incompleteConstraintSourceCode2 :: Maybe T.Text -> T.Text + incompleteConstraintSourceCode2 mConstraint = + let constraint = maybe "(Eq a, Eq b)" (\c -> "(Eq a, Eq b, " <> c <> ")") mConstraint + in T.unlines + [ "module Testing where" + , "" + , "data Three a b c = Three a b c" + , "" + , "instance " <> constraint <> " => Eq (Three a b c) where" + , " (Three x y z) == (Three x' y' z') = x == x' && y == y' && z == z'" + ] + + check :: T.Text -> T.Text -> T.Text -> TestTree + check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do + doc <- createDoc "Testing.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 6 0) (Position 6 68)) + chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + + in testGroup "add instance constraint" + [ check + "Add `Eq a` to the context of the instance declaration" + (missingConstraintSourceCode Nothing) + (missingConstraintSourceCode $ Just "Eq a") + , check + "Add `Eq b` to the context of the instance declaration" + (incompleteConstraintSourceCode Nothing) + (incompleteConstraintSourceCode $ Just "Eq b") + , check + "Add `Eq c` to the context of the instance declaration" + (incompleteConstraintSourceCode2 Nothing) + (incompleteConstraintSourceCode2 $ Just "Eq c") + ] + +addFunctionConstraintTests :: TestTree +addFunctionConstraintTests = let + missingConstraintSourceCode :: T.Text -> T.Text + missingConstraintSourceCode constraint = + T.unlines + [ "module Testing where" + , "" + , "eq :: " <> constraint <> "a -> a -> Bool" + , "eq x y = x == y" + ] + + missingConstraintWithForAllSourceCode :: T.Text -> T.Text + missingConstraintWithForAllSourceCode constraint = + T.unlines + [ "{-# LANGUAGE ExplicitForAll #-}" + , "module Testing where" + , "" + , "eq :: forall a. " <> constraint <> "a -> a -> Bool" + , "eq x y = x == y" + ] + + incompleteConstraintWithForAllSourceCode :: T.Text -> T.Text + incompleteConstraintWithForAllSourceCode constraint = + T.unlines + [ "{-# LANGUAGE ExplicitForAll #-}" + , "module Testing where" + , "" + , "data Pair a b = Pair a b" + , "" + , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool" + , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" + ] + + incompleteConstraintSourceCode :: T.Text -> T.Text + incompleteConstraintSourceCode constraint = + T.unlines + [ "module Testing where" + , "" + , "data Pair a b = Pair a b" + , "" + , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool" + , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" + ] + + incompleteConstraintSourceCode2 :: T.Text -> T.Text + incompleteConstraintSourceCode2 constraint = + T.unlines + [ "module Testing where" + , "" + , "data Three a b c = Three a b c" + , "" + , "eq :: " <> constraint <> " => Three a b c -> Three a b c -> Bool" + , "eq (Three x y z) (Three x' y' z') = x == x' && y == y' && z == z'" + ] + + incompleteConstraintSourceCodeWithExtraCharsInContext :: T.Text -> T.Text + incompleteConstraintSourceCodeWithExtraCharsInContext constraint = + T.unlines + [ "module Testing where" + , "" + , "data Pair a b = Pair a b" + , "" + , "eq :: ( " <> constraint <> " ) => Pair a b -> Pair a b -> Bool" + , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" + ] + + incompleteConstraintSourceCodeWithNewlinesInTypeSignature :: T.Text -> T.Text + incompleteConstraintSourceCodeWithNewlinesInTypeSignature constraint = + T.unlines + [ "module Testing where" + , "data Pair a b = Pair a b" + , "eq " + , " :: (" <> constraint <> ")" + , " => Pair a b -> Pair a b -> Bool" + , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" + ] + + missingMonadConstraint constraint = T.unlines + [ "module Testing where" + , "f :: " <> constraint <> "m ()" + , "f = do " + , " return ()" + ] + + in testGroup "add function constraint" + [ checkCodeAction + "no preexisting constraint" + "Add `Eq a` to the context of the type signature for `eq`" + (missingConstraintSourceCode "") + (missingConstraintSourceCode "Eq a => ") + , checkCodeAction + "no preexisting constraint, with forall" + "Add `Eq a` to the context of the type signature for `eq`" + (missingConstraintWithForAllSourceCode "") + (missingConstraintWithForAllSourceCode "Eq a => ") + , checkCodeAction + "preexisting constraint, no parenthesis" + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintSourceCode "Eq a") + (incompleteConstraintSourceCode "(Eq a, Eq b)") + , checkCodeAction + "preexisting constraints in parenthesis" + "Add `Eq c` to the context of the type signature for `eq`" + (incompleteConstraintSourceCode2 "(Eq a, Eq b)") + (incompleteConstraintSourceCode2 "(Eq a, Eq b, Eq c)") + , checkCodeAction + "preexisting constraints with forall" + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintWithForAllSourceCode "Eq a") + (incompleteConstraintWithForAllSourceCode "(Eq a, Eq b)") + , checkCodeAction + "preexisting constraint, with extra spaces in context" + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a") + (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a, Eq b") + , checkCodeAction + "preexisting constraint, with newlines in type signature" + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a") + (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a, Eq b") + , checkCodeAction + "missing Monad constraint" + "Add `Monad m` to the context of the type signature for `f`" + (missingMonadConstraint "") + (missingMonadConstraint "Monad m => ") + ] + +checkCodeAction :: String -> T.Text -> T.Text -> T.Text -> TestTree +checkCodeAction testName actionTitle originalCode expectedCode = testSession testName $ do + doc <- createDoc "Testing.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 6 0) (Position 6 maxBound)) + chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + +addImplicitParamsConstraintTests :: TestTree +addImplicitParamsConstraintTests = + testGroup + "add missing implicit params constraints" + [ testGroup + "introduced" + [ let ex ctxtA = exampleCode "?a" ctxtA "" + in checkCodeAction "at top level" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()"), + let ex ctxA = exampleCode "x where x = ?a" ctxA "" + in checkCodeAction "in nested def" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()") + ], + testGroup + "inherited" + [ let ex = exampleCode "()" "?a::()" + in checkCodeAction + "with preexisting context" + "Add `?a::()` to the context of the type signature for `fCaller`" + (ex "Eq ()") + (ex "Eq (), ?a::()"), + let ex = exampleCode "()" "?a::()" + in checkCodeAction "without preexisting context" "Add ?a::() to the context of fCaller" (ex "") (ex "?a::()") + ] + ] + where + mkContext "" = "" + mkContext contents = "(" <> contents <> ") => " + + exampleCode bodyBase contextBase contextCaller = + T.unlines + [ "{-# LANGUAGE FlexibleContexts, ImplicitParams #-}", + "module Testing where", + "fBase :: " <> mkContext contextBase <> "()", + "fBase = " <> bodyBase, + "fCaller :: " <> mkContext contextCaller <> "()", + "fCaller = fBase" + ] +removeRedundantConstraintsTests :: TestTree +removeRedundantConstraintsTests = let + header = + [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" + , "module Testing where" + , "" + ] + + redundantConstraintsCode :: Maybe T.Text -> T.Text + redundantConstraintsCode mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "foo :: " <> constraint <> "a -> a" + , "foo = id" + ] + + redundantMixedConstraintsCode :: Maybe T.Text -> T.Text + redundantMixedConstraintsCode mConstraint = + let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint + in T.unlines $ header <> + [ "foo :: " <> constraint <> " => a -> Bool" + , "foo x = x == 1" + ] + + typeSignatureSpaces :: T.Text + typeSignatureSpaces = T.unlines $ header <> + [ "foo :: (Num a, Eq a, Monoid a) => a -> Bool" + , "foo x = x == 1" + ] + + typeSignatureMultipleLines :: T.Text + typeSignatureMultipleLines = T.unlines $ header <> + [ "foo :: (Num a, Eq a, Monoid a)" + , "=> a -> Bool" + , "foo x = x == 1" + ] + + check :: T.Text -> T.Text -> T.Text -> TestTree + check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do + doc <- createDoc "Testing.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 4 0) (Position 4 maxBound)) + chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + + checkPeculiarFormatting :: String -> T.Text -> TestTree + checkPeculiarFormatting title code = testSession title $ do + doc <- createDoc "Testing.hs" "haskell" code + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 4 0) (Position 4 maxBound)) + liftIO $ assertBool "Found some actions" (null actionsOrCommands) + + in testGroup "remove redundant function constraints" + [ check + "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" + (redundantConstraintsCode $ Just "Eq a") + (redundantConstraintsCode Nothing) + , check + "Remove redundant constraints `(Eq a, Monoid a)` from the context of the type signature for `foo`" + (redundantConstraintsCode $ Just "(Eq a, Monoid a)") + (redundantConstraintsCode Nothing) + , check + "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`" + (redundantMixedConstraintsCode $ Just "Monoid a, Show a") + (redundantMixedConstraintsCode Nothing) + , checkPeculiarFormatting + "should do nothing when constraints contain an arbitrary number of spaces" + typeSignatureSpaces + , checkPeculiarFormatting + "should do nothing when constraints contain line feeds" + typeSignatureMultipleLines + ] + +addSigActionTests :: TestTree +addSigActionTests = let + header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" + moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where" + before def = T.unlines [header, moduleH, def] + after' def sig = T.unlines [header, moduleH, sig, def] + + def >:: sig = testSession (T.unpack def) $ do + let originalCode = before def + let expectedCode = after' def sig + doc <- createDoc "Sigs.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound)) + chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + in + testGroup "add signature" + [ "abc = True" >:: "abc :: Bool" + , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a" + , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String" + , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool" + , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a" + , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2" + , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a" + ] + +exportUnusedTests :: TestTree +exportUnusedTests = testGroup "export unused actions" + [ testGroup "don't want suggestion" + [ testSession "implicit exports" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# OPTIONS_GHC -Wmissing-signatures #-}" + , "module A where" + , "foo = id"]) + (R 3 0 3 3) + "Export ‘foo’" + Nothing -- codeaction should not be available + , testSession "not top-level" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (foo,bar) where" + , "foo = ()" + , " where bar = ()" + , "bar = ()"]) + (R 2 0 2 11) + "Export ‘bar’" + Nothing + , testSession "type is exported but not the constructor of same name" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo) where" + , "data Foo = Foo"]) + (R 2 0 2 8) + "Export ‘Foo’" + Nothing -- codeaction should not be available + , testSession "unused data field" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo(Foo)) where" + , "data Foo = Foo {foo :: ()}"]) + (R 2 0 2 20) + "Export ‘foo’" + Nothing -- codeaction should not be available + ] + , testGroup "want suggestion" + [ testSession "empty exports" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (" + , ") where" + , "foo = id"]) + (R 3 0 3 3) + "Export ‘foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (" + , "foo) where" + , "foo = id"]) + , testSession "single line explicit exports" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (foo) where" + , "foo = id" + , "bar = foo"]) + (R 3 0 3 3) + "Export ‘bar’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (foo,bar) where" + , "foo = id" + , "bar = foo"]) + , testSession "multi line explicit exports" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " (" + , " foo) where" + , "foo = id" + , "bar = foo"]) + (R 5 0 5 3) + "Export ‘bar’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " (" + , " foo,bar) where" + , "foo = id" + , "bar = foo"]) + , testSession "export list ends in comma" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " (foo," + , " ) where" + , "foo = id" + , "bar = foo"]) + (R 4 0 4 3) + "Export ‘bar’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " (foo," + , " bar) where" + , "foo = id" + , "bar = foo"]) + , testSession "unused pattern synonym" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE PatternSynonyms #-}" + , "module A () where" + , "pattern Foo a <- (a, _)"]) + (R 3 0 3 10) + "Export ‘Foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE PatternSynonyms #-}" + , "module A (pattern Foo) where" + , "pattern Foo a <- (a, _)"]) + , testSession "unused data type" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "data Foo = Foo"]) + (R 2 0 2 7) + "Export ‘Foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo(..)) where" + , "data Foo = Foo"]) + , testSession "unused newtype" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "newtype Foo = Foo ()"]) + (R 2 0 2 10) + "Export ‘Foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo(..)) where" + , "newtype Foo = Foo ()"]) + , testSession "unused type synonym" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "type Foo = ()"]) + (R 2 0 2 7) + "Export ‘Foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo) where" + , "type Foo = ()"]) + , testSession "unused type family" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "module A () where" + , "type family Foo p"]) + (R 3 0 3 15) + "Export ‘Foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "module A (Foo(..)) where" + , "type family Foo p"]) + , testSession "unused typeclass" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "class Foo a"]) + (R 2 0 2 8) + "Export ‘Foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo(..)) where" + , "class Foo a"]) + , testSession "infix" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "a `f` b = ()"]) + (R 2 0 2 11) + "Export ‘f’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (f) where" + , "a `f` b = ()"]) + , testSession "function operator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "(<|) = ($)"]) + (R 2 0 2 9) + "Export ‘<|’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A ((<|)) where" + , "(<|) = ($)"]) + , testSession "type synonym operator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "type (:<) = ()"]) + (R 3 0 3 13) + "Export ‘:<’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A ((:<)) where" + , "type (:<) = ()"]) + , testSession "type family operator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "type family (:<)"]) + (R 4 0 4 15) + "Export ‘:<’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A (type (:<)(..)) where" + , "type family (:<)"]) + , testSession "typeclass operator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "class (:<) a"]) + (R 3 0 3 11) + "Export ‘:<’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A (type (:<)(..)) where" + , "class (:<) a"]) + , testSession "newtype operator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "newtype (:<) = Foo ()"]) + (R 3 0 3 20) + "Export ‘:<’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A (type (:<)(..)) where" + , "newtype (:<) = Foo ()"]) + , testSession "data type operator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "data (:<) = Foo ()"]) + (R 3 0 3 17) + "Export ‘:<’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A (type (:<)(..)) where" + , "data (:<) = Foo ()"]) + ] + ] + where + template doc range = exportTemplate (Just range) doc + +exportTemplate :: Maybe Range -> T.Text -> T.Text -> Maybe T.Text -> Session () +exportTemplate mRange initialContent expectedAction expectedContents = do + doc <- createDoc "A.hs" "haskell" initialContent + _ <- waitForDiagnostics + actions <- case mRange of + Nothing -> getAllCodeActions doc + Just range -> getCodeActions doc range + case expectedContents of + Just content -> do + action <- liftIO $ pickActionWithTitle expectedAction actions + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ content @=? contentAfterAction + Nothing -> + liftIO $ [_title | InR CodeAction{_title} <- actions, _title == expectedAction ] @?= [] + +removeExportTests :: TestTree +removeExportTests = testGroup "remove export actions" + [ testSession "single export" $ template + (T.unlines + [ "module A ( a ) where" + , "b :: ()" + , "b = ()"]) + "Remove ‘a’ from export" + (Just $ T.unlines + [ "module A ( ) where" + , "b :: ()" + , "b = ()"]) + , testSession "ending comma" $ template + (T.unlines + [ "module A ( a, ) where" + , "b :: ()" + , "b = ()"]) + "Remove ‘a’ from export" + (Just $ T.unlines + [ "module A ( ) where" + , "b :: ()" + , "b = ()"]) + , testSession "multiple exports" $ template + (T.unlines + [ "module A (a , c, b ) where" + , "a, c :: ()" + , "a = ()" + , "c = ()"]) + "Remove ‘b’ from export" + (Just $ T.unlines + [ "module A (a , c ) where" + , "a, c :: ()" + , "a = ()" + , "c = ()"]) + , testSession "not in scope constructor" $ template + (T.unlines + [ "module A (A (X,Y,Z,(:<)), ab) where" + , "data A = X Int | Y | (:<) Int" + , "ab :: ()" + , "ab = ()" + ]) + "Remove ‘Z’ from export" + (Just $ T.unlines + [ "module A (A (X,Y,(:<)), ab) where" + , "data A = X Int | Y | (:<) Int" + , "ab :: ()" + , "ab = ()"]) + , testSession "multiline export" $ template + (T.unlines + [ "module A (a" + , " , b" + , " , (:*:)" + , " , ) where" + , "a,b :: ()" + , "a = ()" + , "b = ()"]) + "Remove ‘:*:’ from export" + (Just $ T.unlines + [ "module A (a" + , " , b" + , " " + , " , ) where" + , "a,b :: ()" + , "a = ()" + , "b = ()"]) + , testSession "qualified re-export" $ template + (T.unlines + [ "module A (M.x,a) where" + , "import qualified Data.List as M" + , "a :: ()" + , "a = ()"]) + "Remove ‘M.x’ from export" + (Just $ T.unlines + [ "module A (a) where" + , "import qualified Data.List as M" + , "a :: ()" + , "a = ()"]) + , testSession "export module" $ template + (T.unlines + [ "module A (module B) where" + , "a :: ()" + , "a = ()"]) + "Remove ‘module B’ from export" + (Just $ T.unlines + [ "module A () where" + , "a :: ()" + , "a = ()"]) + , testSession "dodgy export" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (A (..)) where" + , "data X = X" + , "type A = X"]) + "Remove ‘A(..)’ from export" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A () where" + , "data X = X" + , "type A = X"]) + , testSession "dodgy export" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (A (..)) where" + , "data X = X" + , "type A = X"]) + "Remove ‘A(..)’ from export" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A () where" + , "data X = X" + , "type A = X"]) + , testSession "duplicate module export" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (module L,module L) where" + , "import Data.List as L" + , "a :: ()" + , "a = ()"]) + "Remove ‘Module L’ from export" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (module L) where" + , "import Data.List as L" + , "a :: ()" + , "a = ()"]) + , testSession "remove all exports single" $ template + (T.unlines + [ "module A (x) where" + , "a :: ()" + , "a = ()"]) + "Remove all redundant exports" + (Just $ T.unlines + [ "module A () where" + , "a :: ()" + , "a = ()"]) + , testSession "remove all exports two" $ template + (T.unlines + [ "module A (x,y) where" + , "a :: ()" + , "a = ()"]) + "Remove all redundant exports" + (Just $ T.unlines + [ "module A () where" + , "a :: ()" + , "a = ()"]) + , testSession "remove all exports three" $ template + (T.unlines + [ "module A (a,x,y) where" + , "a :: ()" + , "a = ()"]) + "Remove all redundant exports" + (Just $ T.unlines + [ "module A (a) where" + , "a :: ()" + , "a = ()"]) + , testSession "remove all exports composite" $ template + (T.unlines + [ "module A (x,y,b, module Ls, a, A(X,getW, Y, Z,(:-),getV), (-+), B(B)) where" + , "data A = X {getV :: Int} | Y {getV :: Int}" + , "data B = B" + , "a,b :: ()" + , "a = ()" + , "b = ()"]) + "Remove all redundant exports" + (Just $ T.unlines + [ "module A (b, a, A(X, Y,getV), B(B)) where" + , "data A = X {getV :: Int} | Y {getV :: Int}" + , "data B = B" + , "a,b :: ()" + , "a = ()" + , "b = ()"]) + ] + where + template = exportTemplate Nothing + +addSigLensesTests :: TestTree +addSigLensesTests = + let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" + moduleH exported = + T.unlines + [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators #-}" + , "module Sigs(" <> exported <> ") where" + , "import qualified Data.Complex as C" + , "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)" + ] + before enableGHCWarnings exported (def, _) others = + T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others + after' enableGHCWarnings exported (def, sig) others = + T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others + createConfig mode = A.object ["haskell" A..= A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]] + sigSession testName enableGHCWarnings mode exported def others = testSession testName $ do + let originalCode = before enableGHCWarnings exported def others + let expectedCode = after' enableGHCWarnings exported def others + sendNotification SWorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode + doc <- createDoc "Sigs.hs" "haskell" originalCode + waitForProgressDone + codeLenses <- getCodeLenses doc + if not $ null $ snd def + then do + liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses + executeCommand $ fromJust $ head codeLenses ^. L.command + modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc) + liftIO $ expectedCode @=? modifiedCode + else liftIO $ null codeLenses @? "Expected no code lens, but got: " <> show codeLenses + cases = + [ ("abc = True", "abc :: Bool") + , ("foo a b = a + b", "foo :: Num a => a -> a -> a") + , ("bar a b = show $ a + b", "bar :: (Show a, Num a) => a -> a -> String") + , ("(!!!) a b = a > b", "(!!!) :: Ord a => a -> a -> Bool") + , ("a >>>> b = a + b", "(>>>>) :: Num a => a -> a -> a") + , ("a `haha` b = a b", "haha :: (t1 -> t2) -> t1 -> t2") + , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a") + , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a") + , ("head = 233", "head :: Integer") + , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, [Char])") + , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"") + , ("promotedKindTest = Proxy @Nothing", "promotedKindTest :: Proxy 'Nothing") + , ("typeOperatorTest = Refl", "typeOperatorTest :: a :~: a") + , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType") + ] + in testGroup + "add signature" + [ testGroup "signatures are correct" [sigSession (T.unpack def) False "always" "" (def, Just sig) [] | (def, sig) <- cases] + , sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) + , testGroup + "diagnostics mode works" + [ sigSession "with GHC warnings" True "diagnostics" "" (second Just $ head cases) [] + , sigSession "without GHC warnings" False "diagnostics" "" (second (const Nothing) $ head cases) [] + ] + ] + +linkToLocation :: [LocationLink] -> [Location] +linkToLocation = map (\LocationLink{_targetUri,_targetRange} -> Location _targetUri _targetRange) + +checkDefs :: [Location] |? [LocationLink] -> Session [Expect] -> Session () +checkDefs (either id linkToLocation . toEither -> defs) mkExpectations = traverse_ check =<< mkExpectations where + check (ExpectRange expectedRange) = do + assertNDefinitionsFound 1 defs + assertRangeCorrect (head defs) expectedRange + check (ExpectLocation expectedLocation) = do + assertNDefinitionsFound 1 defs + liftIO $ do + canonActualLoc <- canonicalizeLocation (head defs) + canonExpectedLoc <- canonicalizeLocation expectedLocation + canonActualLoc @?= canonExpectedLoc + check ExpectNoDefinitions = do + assertNDefinitionsFound 0 defs + check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file" + check _ = pure () -- all other expectations not relevant to getDefinition + + assertNDefinitionsFound :: Int -> [a] -> Session () + assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs) + + assertRangeCorrect Location{_range = foundRange} expectedRange = + liftIO $ expectedRange @=? foundRange + +canonicalizeLocation :: Location -> IO Location +canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range + +findDefinitionAndHoverTests :: TestTree +findDefinitionAndHoverTests = let + + tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> Session [Expect] -> String -> TestTree + tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do + + -- Dirty the cache to check that definitions work even in the presence of iface files + liftIO $ runInDir dir $ do + let fooPath = dir "Foo.hs" + fooSource <- liftIO $ readFileUtf8 fooPath + fooDoc <- createDoc fooPath "haskell" fooSource + _ <- getHover fooDoc $ Position 4 3 + closeDoc fooDoc + + doc <- openTestDataDoc (dir sourceFilePath) + waitForProgressDone + found <- get doc pos + check found targetRange + + + + checkHover :: Maybe Hover -> Session [Expect] -> Session () + checkHover hover expectations = traverse_ check =<< expectations where + + check expected = + case hover of + Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" + Just Hover{_contents = (HoverContents MarkupContent{_value = standardizeQuotes -> msg}) + ,_range = rangeInHover } -> + case expected of + ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets + ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover + _ -> pure () -- all other expectations not relevant to hover + _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover + + extractLineColFromHoverMsg :: T.Text -> [T.Text] + extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":") + + checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () + checkHoverRange expectedRange rangeInHover msg = + let + lineCol = extractLineColFromHoverMsg msg + -- looks like hovers use 1-based numbering while definitions use 0-based + -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. + adjust Position{_line = l, _character = c} = + Position{_line = l + 1, _character = c + 1} + in + case map (read . T.unpack) lineCol of + [l,c] -> liftIO $ adjust (_start expectedRange) @=? Position l c + _ -> liftIO $ assertFailure $ + "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> + "\n but got: " <> show (msg, rangeInHover) + + assertFoundIn :: T.Text -> T.Text -> Assertion + assertFoundIn part whole = assertBool + (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole) + (part `T.isInfixOf` whole) + + sourceFilePath = T.unpack sourceFileName + sourceFileName = "GotoHover.hs" + + mkFindTests tests = testGroup "get" + [ testGroup "definition" $ mapMaybe fst tests + , testGroup "hover" $ mapMaybe snd tests + , checkFileCompiles sourceFilePath $ + expectDiagnostics + [ ( "GotoHover.hs", [(DsError, (62, 7), "Found hole: _")]) ] + , testGroup "type-definition" typeDefinitionTests ] + + typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 (pure tcData) "Saturated data con" + , tst (getTypeDefinitions, checkDefs) aL20 (pure [ExpectNoDefinitions]) "Polymorphic variable"] + + test runDef runHover look expect = testM runDef runHover look (return expect) + + testM runDef runHover look expect title = + ( runDef $ tst def look expect title + , runHover $ tst hover look expect title ) where + def = (getDefinitions, checkDefs) + hover = (getHover , checkHover) + + -- search locations expectations on results + fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR] + fffL8 = Position 12 4 ; + fffL14 = Position 18 7 ; + aL20 = Position 19 15 + aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3] + dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16] + dcL12 = Position 16 11 ; + xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ", "GHC.Types"]] + tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]] + vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6] + opL16 = Position 20 15 ; op = [mkR 21 2 21 4] + opL18 = Position 22 22 ; opp = [mkR 22 13 22 17] + aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11] + b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7] + xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["pack", ":: String -> Text", "Data.Text"]] + clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]] + clL25 = Position 29 9 + eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num"]] + dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21] + dnbL30 = Position 34 23 + lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27] + lclL33 = Position 37 22 + mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14] + mclL37 = Position 41 1 + spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]] + docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]] + ; constr = [ExpectHoverText ["Monad m"]] + eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]] + intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]] + tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]] + intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]] + chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]] + txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]] + lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]] + outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5] + innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7] + holeL60 = Position 62 7 ; hleInfo = [ExpectHoverText ["_ ::"]] + cccL17 = Position 17 16 ; docLink = [ExpectHoverText ["[Documentation](file:///"]] + imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3] + reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 0 3 14] + thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]] + in + mkFindTests + -- def hover look expect + [ test yes yes fffL4 fff "field in record definition" + , test yes yes fffL8 fff "field in record construction #1102" + , test yes yes fffL14 fff "field name used as accessor" -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs + , test yes yes aaaL14 aaa "top-level name" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes dcL7 tcDC "data constructor record #1029" + , test yes yes dcL12 tcDC "data constructor plain" -- https://github.com/haskell/ghcide/pull/121 + , test yes yes tcL6 tcData "type constructor #1028" -- https://github.com/haskell/ghcide/pull/147 + , test broken yes xtcL5 xtc "type constructor external #717,1028" + , test broken yes xvL20 xvMsg "value external package #717" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes vvL16 vv "plain parameter" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes aL18 apmp "pattern match name" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes opL16 op "top-level operator #713" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes opL18 opp "parameter operator" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes b'L19 bp "name in backticks" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes clL23 cls "class in instance declaration #1027" + , test yes yes clL25 cls "class in signature #1027" -- https://github.com/haskell/ghcide/pull/147 + , test broken yes eclL15 ecls "external class in signature #717,1027" + , test yes yes dnbL29 dnb "do-notation bind #1073" + , test yes yes dnbL30 dnb "do-notation lookup" + , test yes yes lcbL33 lcb "listcomp bind #1073" + , test yes yes lclL33 lcb "listcomp lookup" + , test yes yes mclL36 mcl "top-level fn 1st clause" + , test yes yes mclL37 mcl "top-level fn 2nd clause #1030" +#if MIN_GHC_API_VERSION(8,10,0) + , test yes yes spaceL37 space "top-level fn on space #1002" +#else + , test yes broken spaceL37 space "top-level fn on space #1002" +#endif + , test no yes docL41 doc "documentation #1129" + , test no yes eitL40 kindE "kind of Either #1017" + , test no yes intL40 kindI "kind of Int #1017" + , test no broken tvrL40 kindV "kind of (* -> *) type variable #1017" + , test no broken intL41 litI "literal Int in hover info #1016" + , test no broken chrL36 litC "literal Char in hover info #1016" + , test no broken txtL8 litT "literal Text in hover info #1016" + , test no broken lstL43 litL "literal List in hover info #1016" + , test no broken docL41 constr "type constraint in hover info #1012" + , test broken broken outL45 outSig "top-level signature #767" + , test broken broken innL48 innSig "inner signature #767" + , test no yes holeL60 hleInfo "hole without internal name #831" + , test no skip cccL17 docLink "Haddock html links" + , testM yes yes imported importedSig "Imported symbol" + , testM yes yes reexported reexportedSig "Imported symbol (reexported)" + , test no yes thLocL57 thLoc "TH Splice Hover" + ] + where yes, broken :: (TestTree -> Maybe TestTree) + yes = Just -- test should run and pass + broken = Just . (`xfail` "known broken") + no = const Nothing -- don't run this test at all + skip = const Nothing -- unreliable, don't run + +checkFileCompiles :: FilePath -> Session () -> TestTree +checkFileCompiles fp diag = + testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do + void (openTestDataDoc (dir fp)) + diag + +pluginSimpleTests :: TestTree +pluginSimpleTests = + ignoreInWindowsForGHC88And810 $ + testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do + _ <- openDoc (dir "KnownNat.hs") "haskell" + liftIO $ writeFile (dir"hie.yaml") + "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}" + + expectDiagnostics + [ ( "KnownNat.hs", + [(DsError, (9, 15), "Variable not in scope: c")] + ) + ] + +pluginParsedResultTests :: TestTree +pluginParsedResultTests = + ignoreInWindowsForGHC88And810 $ + testSessionWithExtraFiles "plugin-recorddot" "parsedResultAction plugin" $ \dir -> do + _ <- openDoc (dir "RecordDot.hs") "haskell" + expectNoMoreDiagnostics 2 + +cppTests :: TestTree +cppTests = + testGroup "cpp" + [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do + let content = + T.unlines + [ "{-# LANGUAGE CPP #-}", + "module Testing where", + "#ifdef FOO", + "foo = 42" + ] + -- The error locations differ depending on which C-preprocessor is used. + -- Some give the column number and others don't (hence -1). Assert either + -- of them. + (run $ expectError content (2, -1)) + `catch` ( \e -> do + let _ = e :: HUnitFailure + run $ expectError content (2, 1) + ) + , testSessionWait "cpp-ghcide" $ do + _ <- createDoc "A.hs" "haskell" $ T.unlines + ["{-# LANGUAGE CPP #-}" + ,"main =" + ,"#ifdef __GHCIDE__" + ," worked" + ,"#else" + ," failed" + ,"#endif" + ] + expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])] + ] + where + expectError :: T.Text -> Cursor -> Session () + expectError content cursor = do + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs", + [(DsError, cursor, "error: unterminated")] + ) + ] + expectNoMoreDiagnostics 0.5 + +preprocessorTests :: TestTree +preprocessorTests = testSessionWait "preprocessor" $ do + let content = + T.unlines + [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}" + , "module Testing where" + , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs", + [(DsError, (2, 8), "Variable not in scope: z")] + ) + ] + + +safeTests :: TestTree +safeTests = + testGroup + "SafeHaskell" + [ -- Test for https://github.com/haskell/ghcide/issues/424 + testSessionWait "load" $ do + let sourceA = + T.unlines + ["{-# LANGUAGE Trustworthy #-}" + ,"module A where" + ,"import System.IO.Unsafe" + ,"import System.IO ()" + ,"trustWorthyId :: a -> a" + ,"trustWorthyId i = unsafePerformIO $ do" + ," putStrLn \"I'm safe\"" + ," return i"] + sourceB = + T.unlines + ["{-# LANGUAGE Safe #-}" + ,"module B where" + ,"import A" + ,"safeId :: a -> a" + ,"safeId = trustWorthyId" + ] + + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + expectNoMoreDiagnostics 1 ] + +thTests :: TestTree +thTests = + testGroup + "TemplateHaskell" + [ -- Test for https://github.com/haskell/ghcide/pull/212 + testSessionWait "load" $ do + let sourceA = + T.unlines + [ "{-# LANGUAGE PackageImports #-}", + "{-# LANGUAGE TemplateHaskell #-}", + "module A where", + "import \"template-haskell\" Language.Haskell.TH", + "a :: Integer", + "a = $(litE $ IntegerL 3)" + ] + sourceB = + T.unlines + [ "{-# LANGUAGE PackageImports #-}", + "{-# LANGUAGE TemplateHaskell #-}", + "module B where", + "import A", + "import \"template-haskell\" Language.Haskell.TH", + "b :: Integer", + "b = $(litE $ IntegerL $ a) + n" + ] + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ] + , testSessionWait "newtype-closure" $ do + let sourceA = + T.unlines + [ "{-# LANGUAGE DeriveDataTypeable #-}" + ,"{-# LANGUAGE TemplateHaskell #-}" + ,"module A (a) where" + ,"import Data.Data" + ,"import Language.Haskell.TH" + ,"newtype A = A () deriving (Data)" + ,"a :: ExpQ" + ,"a = [| 0 |]"] + let sourceB = + T.unlines + [ "{-# LANGUAGE TemplateHaskell #-}" + ,"module B where" + ,"import A" + ,"b :: Int" + ,"b = $( a )" ] + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + return () + , thReloadingTest False + , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True + -- Regression test for https://github.com/haskell/haskell-language-server/issues/891 + , thLinkingTest False + , ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True + , testSessionWait "findsTHIdentifiers" $ do + let sourceA = + T.unlines + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module A (a) where" + , "a = [| glorifiedID |]" + , "glorifiedID :: a -> a" + , "glorifiedID = id" ] + let sourceB = + T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "{-# LANGUAGE TemplateHaskell #-}" + , "module B where" + , "import A" + , "main = $a (putStrLn \"success!\")"] + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + expectDiagnostics [ ( "B.hs", [(DsWarning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ] + , ignoreInWindowsForGHC88 $ testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do + + -- This test defines a TH value with the meaning "data A = A" in A.hs + -- Loads and export the template in B.hs + -- And checks wether the constructor A can be loaded in C.hs + -- This test does not fail when either A and B get manually loaded before C.hs + -- or when we remove the seemingly unnecessary TH pragma from C.hs + + let cPath = dir "C.hs" + _ <- openDoc cPath "haskell" + expectDiagnostics [ ( cPath, [(DsWarning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ] + ] + +-- | test that TH is reevaluated on typecheck +thReloadingTest :: Bool -> TestTree +thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do + + let aPath = dir "THA.hs" + bPath = dir "THB.hs" + cPath = dir "THC.hs" + + aSource <- liftIO $ readFileUtf8 aPath -- th = [d|a = ()|] + bSource <- liftIO $ readFileUtf8 bPath -- $th + cSource <- liftIO $ readFileUtf8 cPath -- c = a :: () + + adoc <- createDoc aPath "haskell" aSource + bdoc <- createDoc bPath "haskell" bSource + cdoc <- createDoc cPath "haskell" cSource + + expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])] + + -- Change th from () to Bool + let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"] + changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource'] + -- generate an artificial warning to avoid timing out if the TH change does not propagate + changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing $ cSource <> "\nfoo=()"] + + -- Check that the change propagates to C + expectDiagnostics + [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) + ,("THC.hs", [(DsWarning, (6,0), "Top-level binding")]) + ,("THB.hs", [(DsWarning, (4,0), "Top-level binding")]) + ] + + closeDoc adoc + closeDoc bdoc + closeDoc cdoc + where + name = "reloading-th-test" <> if unboxed then "-unboxed" else "" + dir | unboxed = "THUnboxed" + | otherwise = "TH" + +thLinkingTest :: Bool -> TestTree +thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do + + let aPath = dir "THA.hs" + bPath = dir "THB.hs" + + aSource <- liftIO $ readFileUtf8 aPath -- th_a = [d|a :: ()|] + bSource <- liftIO $ readFileUtf8 bPath -- $th_a + + adoc <- createDoc aPath "haskell" aSource + bdoc <- createDoc bPath "haskell" bSource + + expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])] + + let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"] + changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource'] + + -- modify b too + let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"] + changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing bSource'] + + expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])] + + closeDoc adoc + closeDoc bdoc + where + name = "th-linking-test" <> if unboxed then "-unboxed" else "" + dir | unboxed = "THUnboxed" + | otherwise = "TH" + +completionTests :: TestTree +completionTests + = testGroup "completion" + [ testGroup "non local" nonLocalCompletionTests + , testGroup "topLevel" topLevelCompletionTests + , testGroup "local" localCompletionTests + , testGroup "other" otherCompletionTests + ] + +completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe (List TextEdit))] -> TestTree +completionTest name src pos expected = testSessionWait name $ do + docId <- createDoc "A.hs" "haskell" (T.unlines src) + _ <- waitForDiagnostics + compls <- getCompletions docId pos + let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] + liftIO $ do + let emptyToMaybe x = if T.null x then Nothing else Just x + sortOn (Lens.view Lens._1) compls' @?= + sortOn (Lens.view Lens._1) [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] + forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs, _)) -> do + when expectedSig $ + assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) + when expectedDocs $ + assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) + +completionCommandTest :: + String -> + [T.Text] -> + Position -> + T.Text -> + [T.Text] -> + TestTree +completionCommandTest name src pos wanted expected = testSession name $ do + docId <- createDoc "A.hs" "haskell" (T.unlines src) + _ <- waitForDiagnostics + compls <- skipManyTill anyMessage (getCompletions docId pos) + let wantedC = find ( \case + CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x + _ -> False + ) compls + case wantedC of + Nothing -> + liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls] + Just CompletionItem {..} -> do + c <- assertJust "Expected a command" _command + executeCommand c + if src /= expected + then do + void $ skipManyTill anyMessage loggingNotification + modifiedCode <- skipManyTill anyMessage (getDocumentEdit docId) + liftIO $ modifiedCode @?= T.unlines expected + else do + expectMessages SWorkspaceApplyEdit 1 $ \edit -> + liftIO $ assertFailure $ "Expected no edit but got: " <> show edit + +completionNoCommandTest :: + String -> + [T.Text] -> + Position -> + T.Text -> + TestTree +completionNoCommandTest name src pos wanted = testSession name $ do + docId <- createDoc "A.hs" "haskell" (T.unlines src) + _ <- waitForDiagnostics + compls <- getCompletions docId pos + let wantedC = find ( \case + CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x + _ -> False + ) compls + case wantedC of + Nothing -> + liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls] + Just CompletionItem{..} -> liftIO . assertBool ("Expected no command but got: " <> show _command) $ null _command + + +topLevelCompletionTests :: [TestTree] +topLevelCompletionTests = [ + completionTest + "variable" + ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 8) + [("xxx", CiFunction, "xxx", True, True, Nothing), + ("XxxCon", CiConstructor, "XxxCon", False, True, Nothing) + ], + completionTest + "constructor" + ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 8) + [("xxx", CiFunction, "xxx", True, True, Nothing), + ("XxxCon", CiConstructor, "XxxCon", False, True, Nothing) + ], + completionTest + "class method" + ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"] + (Position 0 8) + [("xxx", CiFunction, "xxx", True, True, Nothing)], + completionTest + "type" + ["bar :: Xx", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 9) + [("Xxx", CiStruct, "Xxx", False, True, Nothing)], + completionTest + "class" + ["bar :: Xx", "xxx = ()", "-- | haddock", "class Xxx a"] + (Position 0 9) + [("Xxx", CiClass, "Xxx", False, True, Nothing)], + completionTest + "records" + ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ] + (Position 1 19) + [("_personName", CiFunction, "_personName", False, True, Nothing), + ("_personAge", CiFunction, "_personAge", False, True, Nothing)], + completionTest + "recordsConstructor" + ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ] + (Position 1 19) + [("XyRecord", CiConstructor, "XyRecord", False, True, Nothing), + ("XyRecord", CiSnippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)] + ] + +localCompletionTests :: [TestTree] +localCompletionTests = [ + completionTest + "argument" + ["bar (Just abcdef) abcdefg = abcd"] + (Position 0 32) + [("abcdef", CiFunction, "abcdef", True, False, Nothing), + ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) + ], + completionTest + "let" + ["bar = let (Just abcdef) = undefined" + ," abcdefg = let abcd = undefined in undefined" + ," in abcd" + ] + (Position 2 15) + [("abcdef", CiFunction, "abcdef", True, False, Nothing), + ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) + ], + completionTest + "where" + ["bar = abcd" + ," where (Just abcdef) = undefined" + ," abcdefg = let abcd = undefined in undefined" + ] + (Position 0 10) + [("abcdef", CiFunction, "abcdef", True, False, Nothing), + ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) + ], + completionTest + "do/1" + ["bar = do" + ," Just abcdef <- undefined" + ," abcd" + ," abcdefg <- undefined" + ," pure ()" + ] + (Position 2 6) + [("abcdef", CiFunction, "abcdef", True, False, Nothing) + ], + completionTest + "do/2" + ["bar abcde = do" + ," Just [(abcdef,_)] <- undefined" + ," abcdefg <- undefined" + ," let abcdefgh = undefined" + ," (Just [abcdefghi]) = undefined" + ," abcd" + ," where" + ," abcdefghij = undefined" + ] + (Position 5 8) + [("abcde", CiFunction, "abcde", True, False, Nothing) + ,("abcdefghij", CiFunction, "abcdefghij", True, False, Nothing) + ,("abcdef", CiFunction, "abcdef", True, False, Nothing) + ,("abcdefg", CiFunction, "abcdefg", True, False, Nothing) + ,("abcdefgh", CiFunction, "abcdefgh", True, False, Nothing) + ,("abcdefghi", CiFunction, "abcdefghi", True, False, Nothing) + ] + ] + +nonLocalCompletionTests :: [TestTree] +nonLocalCompletionTests = + [ completionTest + "variable" + ["module A where", "f = hea"] + (Position 1 7) + [("head", CiFunction, "head ${1:[a]}", True, True, Nothing)], + completionTest + "constructor" + ["module A where", "f = Tru"] + (Position 1 7) + [ ("True", CiConstructor, "True ", True, True, Nothing), + ("truncate", CiFunction, "truncate ${1:a}", True, True, Nothing) + ], + completionTest + "type" + ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"] + (Position 2 7) + [ ("Bounded", CiClass, "Bounded ${1:*}", True, True, Nothing), + ("Bool", CiStruct, "Bool ", True, True, Nothing) + ], + completionTest + "qualified" + ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"] + (Position 2 15) + [ ("head", CiFunction, "head ${1:[a]}", True, True, Nothing) + ], + completionTest + "duplicate import" + ["module A where", "import Data.List", "import Data.List", "f = perm"] + (Position 3 8) + [ ("permutations", CiFunction, "permutations ${1:[a]}", False, False, Nothing) + ], + completionTest + "dont show hidden items" + [ "{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", + "import Control.Monad hiding (join)", + "f = joi" + ] + (Position 3 6) + [], + testGroup "auto import snippets" + [ completionCommandTest + "show imports not in list - simple" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (msum)", "f = joi"] + (Position 3 6) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (msum, join)", "f = joi"] + , completionCommandTest + "show imports not in list - multi-line" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (\n msum)", "f = joi"] + (Position 4 6) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (\n msum, join)", "f = joi"] + , completionCommandTest + "show imports not in list - names with _" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M (msum)", "f = M.mapM_"] + (Position 3 11) + "mapM_" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M (msum, mapM_)", "f = M.mapM_"] + , completionCommandTest + "show imports not in list - initial empty list" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M ()", "f = M.joi"] + (Position 3 10) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M (join)", "f = M.joi"] + , testGroup "qualified imports" + [ completionCommandTest + "single" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad ()", "f = Control.Monad.joi"] + (Position 3 22) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (join)", "f = Control.Monad.joi"] + , completionCommandTest + "as" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M ()", "f = M.joi"] + (Position 3 10) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M (join)", "f = M.joi"] + , completionCommandTest + "multiple" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M ()", "import Control.Monad as N ()", "f = N.joi"] + (Position 4 10) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M ()", "import Control.Monad as N (join)", "f = N.joi"] + ] + , testGroup "Data constructor" + [ completionCommandTest + "not imported" + ["module A where", "import Text.Printf ()", "ZeroPad"] + (Position 2 4) + "ZeroPad" + ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] + , completionCommandTest + "parent imported abs" + ["module A where", "import Text.Printf (FormatAdjustment)", "ZeroPad"] + (Position 2 4) + "ZeroPad" + ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] + , completionNoCommandTest + "parent imported all" + ["module A where", "import Text.Printf (FormatAdjustment (..))", "ZeroPad"] + (Position 2 4) + "ZeroPad" + , completionNoCommandTest + "already imported" + ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] + (Position 2 4) + "ZeroPad" + , completionNoCommandTest + "function from Prelude" + ["module A where", "import Data.Maybe ()", "Nothing"] + (Position 2 4) + "Nothing" + , completionCommandTest + "type operator parent" + ["module A where", "import Data.Type.Equality ()", "f = Ref"] + (Position 2 8) + "Refl" + ["module A where", "import Data.Type.Equality ((:~:) (Refl))", "f = Ref"] + ] + , testGroup "Record completion" + [ completionCommandTest + "not imported" + ["module A where", "import Text.Printf ()", "FormatParse"] + (Position 2 10) + "FormatParse {" + ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] + , completionCommandTest + "parent imported" + ["module A where", "import Text.Printf (FormatParse)", "FormatParse"] + (Position 2 10) + "FormatParse {" + ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] + , completionNoCommandTest + "already imported" + ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] + (Position 2 10) + "FormatParse {" + ] + ], + -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls + completionTest + "do not show pragma completions" + [ "{-# LANGUAGE ", + "{module A where}", + "main = return ()" + ] + (Position 0 13) + [] + ] + +otherCompletionTests :: [TestTree] +otherCompletionTests = [ + completionTest + "keyword" + ["module A where", "f = newty"] + (Position 1 9) + [("newtype", CiKeyword, "", False, False, Nothing)], + completionTest + "type context" + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "f = f", + "g :: Intege" + ] + -- At this point the module parses but does not typecheck. + -- This should be sufficient to detect that we are in a + -- type context and only show the completion to the type. + (Position 3 11) + [("Integer", CiStruct, "Integer ", True, True, Nothing)], + + testSession "duplicate record fields" $ do + void $ + createDoc "B.hs" "haskell" $ + T.unlines + [ "{-# LANGUAGE DuplicateRecordFields #-}", + "module B where", + "newtype Foo = Foo { member :: () }", + "newtype Bar = Bar { member :: () }" + ] + docA <- + createDoc "A.hs" "haskell" $ + T.unlines + [ "module A where", + "import B", + "memb" + ] + _ <- waitForDiagnostics + compls <- getCompletions docA $ Position 2 4 + let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"] + liftIO $ compls' @?= ["member ${1:Foo}", "member ${1:Bar}"], + + testSessionWait "maxCompletions" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a = Prelude." + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + liftIO $ length compls @?= maxCompletions def + ] + +highlightTests :: TestTree +highlightTests = testGroup "highlight" + [ testSessionWait "value" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 3 2) + liftIO $ highlights @?= List + [ DocumentHighlight (R 2 0 2 3) (Just HkRead) + , DocumentHighlight (R 3 0 3 3) (Just HkWrite) + , DocumentHighlight (R 4 6 4 9) (Just HkRead) + , DocumentHighlight (R 5 22 5 25) (Just HkRead) + ] + , testSessionWait "type" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 2 8) + liftIO $ highlights @?= List + [ DocumentHighlight (R 2 7 2 10) (Just HkRead) + , DocumentHighlight (R 3 11 3 14) (Just HkRead) + ] + , testSessionWait "local" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 6 5) + liftIO $ highlights @?= List + [ DocumentHighlight (R 6 4 6 7) (Just HkWrite) + , DocumentHighlight (R 6 10 6 13) (Just HkRead) + , DocumentHighlight (R 7 12 7 15) (Just HkRead) + ] + , testSessionWait "record" $ do + doc <- createDoc "A.hs" "haskell" recsource + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 4 15) + liftIO $ highlights @?= List + -- Span is just the .. on 8.10, but Rec{..} before +#if MIN_GHC_API_VERSION(8,10,0) + [ DocumentHighlight (R 4 8 4 10) (Just HkWrite) +#else + [ DocumentHighlight (R 4 4 4 11) (Just HkWrite) +#endif + , DocumentHighlight (R 4 14 4 20) (Just HkRead) + ] + highlights <- getHighlights doc (Position 3 17) + liftIO $ highlights @?= List + [ DocumentHighlight (R 3 17 3 23) (Just HkWrite) + -- Span is just the .. on 8.10, but Rec{..} before +#if MIN_GHC_API_VERSION(8,10,0) + , DocumentHighlight (R 4 8 4 10) (Just HkRead) +#else + , DocumentHighlight (R 4 4 4 11) (Just HkRead) +#endif + ] + ] + where + source = T.unlines + ["{-# OPTIONS_GHC -Wunused-binds #-}" + ,"module Highlight () where" + ,"foo :: Int" + ,"foo = 3 :: Int" + ,"bar = foo" + ," where baz = let x = foo in x" + ,"baz arg = arg + x" + ," where x = arg" + ] + recsource = T.unlines + ["{-# LANGUAGE RecordWildCards #-}" + ,"{-# OPTIONS_GHC -Wunused-binds #-}" + ,"module Highlight () where" + ,"data Rec = Rec { field1 :: Int, field2 :: Char }" + ,"foo Rec{..} = field2 + field1" + ] + +outlineTests :: TestTree +outlineTests = testGroup + "outline" + [ testSessionWait "type class" $ do + let source = T.unlines ["module A where", "class A a where a :: a -> Bool"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [ moduleSymbol + "A" + (R 0 7 0 8) + [ classSymbol "A a" + (R 1 0 1 30) + [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)] + ] + ] + , testSessionWait "type class instance " $ do + let source = T.unlines ["class A a where", "instance A () where"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [ classSymbol "A a" (R 0 0 0 15) [] + , docSymbol "A ()" SkInterface (R 1 0 1 19) + ] + , testSessionWait "type family" $ do + let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)] + , testSessionWait "type family instance " $ do + let source = T.unlines + [ "{-# language TypeFamilies #-}" + , "type family A a" + , "type instance A () = ()" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15) + , docSymbol "A ()" SkInterface (R 2 0 2 23) + ] + , testSessionWait "data family" $ do + let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)] + , testSessionWait "data family instance " $ do + let source = T.unlines + [ "{-# language TypeFamilies #-}" + , "data family A a" + , "data instance A () = A ()" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11) + , docSymbol "A ()" SkInterface (R 2 0 2 25) + ] + , testSessionWait "constant" $ do + let source = T.unlines ["a = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [docSymbol "a" SkFunction (R 0 0 0 6)] + , testSessionWait "pattern" $ do + let source = T.unlines ["Just foo = Just 21"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [docSymbol "Just foo" SkFunction (R 0 0 0 18)] + , testSessionWait "pattern with type signature" $ do + let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [docSymbol "a :: ()" SkFunction (R 1 0 1 12)] + , testSessionWait "function" $ do + let source = T.unlines ["a _x = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 9)] + , testSessionWait "type synonym" $ do + let source = T.unlines ["type A = Bool"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)] + , testSessionWait "datatype" $ do + let source = T.unlines ["data A = C"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [ docSymbolWithChildren "A" + SkStruct + (R 0 0 0 10) + [docSymbol "C" SkConstructor (R 0 9 0 10)] + ] + , testSessionWait "record fields" $ do + let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @=? Left + [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13) + [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10) + [ docSymbol "x" SkField (R 1 2 1 3) + , docSymbol "y" SkField (R 2 4 2 5) + ] + ] + ] + , testSessionWait "import" $ do + let source = T.unlines ["import Data.Maybe ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [docSymbolWithChildren "imports" + SkModule + (R 0 0 0 20) + [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 20) + ] + ] + , testSessionWait "multiple import" $ do + let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [docSymbolWithChildren "imports" + SkModule + (R 1 0 3 27) + [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 20) + , docSymbol "import Control.Exception" SkModule (R 3 0 3 27) + ] + ] + , testSessionWait "foreign import" $ do + let source = T.unlines + [ "{-# language ForeignFunctionInterface #-}" + , "foreign import ccall \"a\" a :: Int" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)] + , testSessionWait "foreign export" $ do + let source = T.unlines + [ "{-# language ForeignFunctionInterface #-}" + , "foreign export ccall odd :: Int -> Bool" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)] + ] + where + docSymbol name kind loc = + DocumentSymbol name Nothing kind Nothing loc loc Nothing + docSymbol' name kind loc selectionLoc = + DocumentSymbol name Nothing kind Nothing loc selectionLoc Nothing + docSymbolD name detail kind loc = + DocumentSymbol name (Just detail) kind Nothing loc loc Nothing + docSymbolWithChildren name kind loc cc = + DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc) + docSymbolWithChildren' name kind loc selectionLoc cc = + DocumentSymbol name Nothing kind Nothing loc selectionLoc (Just $ List cc) + moduleSymbol name loc cc = DocumentSymbol name + Nothing + SkFile + Nothing + (R 0 0 maxBound 0) + loc + (Just $ List cc) + classSymbol name loc cc = DocumentSymbol name + (Just "class") + SkClass + Nothing + loc + loc + (Just $ List cc) + +pattern R :: Int -> Int -> Int -> Int -> Range +pattern R x y x' y' = Range (Position x y) (Position x' y') + +xfail :: TestTree -> String -> TestTree +xfail = flip expectFailBecause + +ignoreInWindowsBecause :: String -> TestTree -> TestTree +ignoreInWindowsBecause = if isWindows then ignoreTestBecause else (\_ x -> x) + +ignoreInWindowsForGHC88And810 :: TestTree -> TestTree +#if MIN_GHC_API_VERSION(8,8,1) && !MIN_GHC_API_VERSION(9,0,0) +ignoreInWindowsForGHC88And810 = + ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8 and 8.10" +#else +ignoreInWindowsForGHC88And810 = id +#endif + +ignoreInWindowsForGHC88 :: TestTree -> TestTree +#if MIN_GHC_API_VERSION(8,8,1) && !MIN_GHC_API_VERSION(8,10,1) +ignoreInWindowsForGHC88 = + ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8" +#else +ignoreInWindowsForGHC88 = id +#endif + +data Expect + = ExpectRange Range -- Both gotoDef and hover should report this range + | ExpectLocation Location +-- | ExpectDefRange Range -- Only gotoDef should report this range + | ExpectHoverRange Range -- Only hover should report this range + | ExpectHoverText [T.Text] -- the hover message must contain these snippets + | ExpectExternFail -- definition lookup in other file expected to fail + | ExpectNoDefinitions + | ExpectNoHover +-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples + deriving Eq + +mkR :: Int -> Int -> Int -> Int -> Expect +mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn + +mkL :: Uri -> Int -> Int -> Int -> Int -> Expect +mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn + +haddockTests :: TestTree +haddockTests + = testGroup "haddock" + [ testCase "Num" $ checkHaddock + (unlines + [ "However, '(+)' and '(*)' are" + , "customarily expected to define a ring and have the following properties:" + , "" + , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@" + , "[__Commutativity of (+)__]: @x + y@ = @y + x@" + , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@" + ] + ) + (unlines + [ "" + , "" + , "However, `(+)` and `(*)` are" + , "customarily expected to define a ring and have the following properties: " + , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`" + , "+ ****Commutativity of (+)****: `x + y` = `y + x`" + , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`" + ] + ) + , testCase "unsafePerformIO" $ checkHaddock + (unlines + [ "may require" + , "different precautions:" + , "" + , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" + , " that calls 'unsafePerformIO'. If the call is inlined," + , " the I\\/O may be performed more than once." + , "" + , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + (unlines + [ "" + , "" + , "may require" + , "different precautions: " + , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " + , " that calls `unsafePerformIO` . If the call is inlined," + , " the I/O may be performed more than once." + , "" + , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + ] + where + checkHaddock s txt = spanDocToMarkdownForTest s @?= txt + +cradleTests :: TestTree +cradleTests = testGroup "cradle" + [testGroup "dependencies" [sessionDepsArePickedUp] + ,testGroup "ignore-fatal" [ignoreFatalWarning] + ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] + ,testGroup "multi" [simpleMultiTest, simpleMultiTest2, simpleMultiDefTest] + ,testGroup "sub-directory" [simpleSubDirectoryTest] + ] + +loadCradleOnlyonce :: TestTree +loadCradleOnlyonce = testGroup "load cradle only once" + [ testSession' "implicit" implicit + , testSession' "direct" direct + ] + where + direct dir = do + liftIO $ writeFileUTF8 (dir "hie.yaml") + "cradle: {direct: {arguments: []}}" + test dir + implicit dir = test dir + test _dir = do + doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo" + msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) + liftIO $ length msgs @?= 1 + changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"] + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) + liftIO $ length msgs @?= 0 + _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar" + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) + liftIO $ length msgs @?= 0 + +retryFailedCradle :: TestTree +retryFailedCradle = testSession' "retry failed" $ \dir -> do + -- The false cradle always fails + let hieContents = "cradle: {bios: {shell: \"false\"}}" + hiePath = dir "hie.yaml" + liftIO $ writeFile hiePath hieContents + hieDoc <- createDoc hiePath "yaml" $ T.pack hieContents + let aPath = dir "A.hs" + doc <- createDoc aPath "haskell" "main = return ()" + Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess + + -- Fix the cradle and typecheck again + let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}" + liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle + changeDoc + hieDoc + [ TextDocumentContentChangeEvent + { _range = Nothing, + _rangeLength = Nothing, + _text = validCradle + } + ] + + -- Force a session restart by making an edit, just to dirty the typecheck node + changeDoc + doc + [ TextDocumentContentChangeEvent + { _range = Just Range {_start = Position 0 0, _end = Position 0 0}, + _rangeLength = Nothing, + _text = "\n" + } + ] + + Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess + + +dependentFileTest :: TestTree +dependentFileTest = testGroup "addDependentFile" + [testGroup "file-changed" [ignoreInWindowsForGHC88 $ testSession' "test" test] + ] + where + test dir = do + -- If the file contains B then no type error + -- otherwise type error + liftIO $ writeFile (dir "dep-file.txt") "A" + let fooContent = T.unlines + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module Foo where" + , "import Language.Haskell.TH.Syntax" + , "foo :: Int" + , "foo = 1 + $(do" + , " qAddDependentFile \"dep-file.txt\"" + , " f <- qRunIO (readFile \"dep-file.txt\")" + , " if f == \"B\" then [| 1 |] else lift f)" + ] + let bazContent = T.unlines ["module Baz where", "import Foo ()"] + _ <-createDoc "Foo.hs" "haskell" fooContent + doc <- createDoc "Baz.hs" "haskell" bazContent + expectDiagnostics + [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])] + -- Now modify the dependent file + liftIO $ writeFile (dir "dep-file.txt") "B" + let change = TextDocumentContentChangeEvent + { _range = Just (Range (Position 2 0) (Position 2 6)) + , _rangeLength = Nothing + , _text = "f = ()" + } + -- Modifying Baz will now trigger Foo to be rebuilt as well + changeDoc doc [change] + expectDiagnostics [("Foo.hs", [])] + + +cradleLoadedMessage :: Session FromServerMessage +cradleLoadedMessage = satisfy $ \case + FromServerMess (SCustomMethod m) (NotMess _) -> m == cradleLoadedMethod + _ -> False + +cradleLoadedMethod :: T.Text +cradleLoadedMethod = "ghcide/cradle/loaded" + +ignoreFatalWarning :: TestTree +ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do + let srcPath = dir "IgnoreFatal.hs" + src <- liftIO $ readFileUtf8 srcPath + _ <- createDoc srcPath "haskell" src + expectNoMoreDiagnostics 5 + +simpleSubDirectoryTest :: TestTree +simpleSubDirectoryTest = + testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do + let mainPath = dir "a/src/Main.hs" + mainSource <- liftIO $ readFileUtf8 mainPath + _mdoc <- createDoc mainPath "haskell" mainSource + expectDiagnosticsWithTags + [("a/src/Main.hs", [(DsWarning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded + ] + expectNoMoreDiagnostics 0.5 + +simpleMultiTest :: TestTree +simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + aSource <- liftIO $ readFileUtf8 aPath + adoc <- createDoc aPath "haskell" aSource + Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc + liftIO $ assertBool "A should typecheck" ideResultSuccess + bSource <- liftIO $ readFileUtf8 bPath + bdoc <- createDoc bPath "haskell" bSource + Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc + liftIO $ assertBool "B should typecheck" ideResultSuccess + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL (adoc ^. L.uri) 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +-- Like simpleMultiTest but open the files in the other order +simpleMultiTest2 :: TestTree +simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + bSource <- liftIO $ readFileUtf8 bPath + bdoc <- createDoc bPath "haskell" bSource + expectNoMoreDiagnostics 10 + aSource <- liftIO $ readFileUtf8 aPath + (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource + -- Need to have some delay here or the test fails + expectNoMoreDiagnostics 10 + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL adoc 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +-- Like simpleMultiTest but open the files in component 'a' in a seperate session +simpleMultiDefTest :: TestTree +simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + adoc <- liftIO $ runInDir dir $ do + aSource <- liftIO $ readFileUtf8 aPath + adoc <- createDoc aPath "haskell" aSource + ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do + A.Success fp' <- pure $ fromJSON fp + if equalFilePath fp' aPath then pure () else Nothing + _ -> Nothing + closeDoc adoc + pure adoc + bSource <- liftIO $ readFileUtf8 bPath + bdoc <- createDoc bPath "haskell" bSource + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL (adoc ^. L.uri) 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +ifaceTests :: TestTree +ifaceTests = testGroup "Interface loading tests" + [ -- https://github.com/haskell/ghcide/pull/645/ + ifaceErrorTest + , ifaceErrorTest2 + , ifaceErrorTest3 + , ifaceTHTest + ] + +bootTests :: TestTree +bootTests = testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do + let cPath = dir "C.hs" + cSource <- liftIO $ readFileUtf8 cPath + + -- Dirty the cache + liftIO $ runInDir dir $ do + cDoc <- createDoc cPath "haskell" cSource + _ <- getHover cDoc $ Position 4 3 + ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do + A.Success fp' <- pure $ fromJSON fp + if equalFilePath fp' cPath then pure () else Nothing + _ -> Nothing + closeDoc cDoc + + cdoc <- createDoc cPath "haskell" cSource + locs <- getDefinitions cdoc (Position 7 4) + let floc = mkR 9 0 9 1 + checkDefs locs (pure [floc]) + +-- | test that TH reevaluates across interfaces +ifaceTHTest :: TestTree +ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do + let aPath = dir "THA.hs" + bPath = dir "THB.hs" + cPath = dir "THC.hs" + + aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: () + _bSource <- liftIO $ readFileUtf8 bPath -- a :: () + cSource <- liftIO $ readFileUtf8 cPath -- c = a :: () + + cdoc <- createDoc cPath "haskell" cSource + + -- Change [TH]a from () to Bool + liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"]) + + -- Check that the change propogates to C + changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing cSource] + expectDiagnostics + [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) + ,("THB.hs", [(DsWarning, (4,0), "Top-level binding")])] + closeDoc cdoc + +ifaceErrorTest :: TestTree +ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do + let bPath = dir "B.hs" + pPath = dir "P.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + + bdoc <- createDoc bPath "haskell" bSource + expectDiagnostics + [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So what we know P has been loaded + + -- Change y from Int to B + changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] + -- save so that we can that the error propogates to A + sendNotification STextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing) + + -- Check that the error propogates to A + expectDiagnostics + [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])] + + + -- Check that we wrote the interfaces for B when we saved + let m = SCustomMethod "test" + lid <- sendRequest m $ toJSON $ GetInterfaceFilesDir bPath + res <- skipManyTill anyMessage $ responseForId m lid + liftIO $ case res of + ResponseMessage{_result=Right (A.fromJSON -> A.Success hidir)} -> do + hi_exists <- doesFileExist $ hidir "B.hi" + assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists + _ -> assertFailure $ "Got malformed response for CustomMessage hidir: " ++ show res + + pdoc <- createDoc pPath "haskell" pSource + changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ] + -- Now in P we have + -- bar = x :: Int + -- foo = y :: Bool + -- HOWEVER, in A... + -- x = y :: Int + -- This is clearly inconsistent, and the expected outcome a bit surprising: + -- - The diagnostic for A has already been received. Ghcide does not repeat diagnostics + -- - P is being typechecked with the last successful artifacts for A. + expectDiagnostics + [("P.hs", [(DsWarning,(4,0), "Top-level binding")]) + ,("P.hs", [(DsWarning,(6,0), "Top-level binding")]) + ] + expectNoMoreDiagnostics 2 + +ifaceErrorTest2 :: TestTree +ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \dir -> do + let bPath = dir "B.hs" + pPath = dir "P.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + + bdoc <- createDoc bPath "haskell" bSource + pdoc <- createDoc pPath "haskell" pSource + expectDiagnostics + [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded + + -- Change y from Int to B + changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] + + -- Add a new definition to P + changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ] + -- Now in P we have + -- bar = x :: Int + -- foo = y :: Bool + -- HOWEVER, in A... + -- x = y :: Int + expectDiagnostics + -- As in the other test, P is being typechecked with the last successful artifacts for A + -- (ot thanks to -fdeferred-type-errors) + [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) + ,("P.hs", [(DsWarning, (4, 0), "Top-level binding")]) + ,("P.hs", [(DsWarning, (6, 0), "Top-level binding")]) + ] + + expectNoMoreDiagnostics 2 + +ifaceErrorTest3 :: TestTree +ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \dir -> do + let bPath = dir "B.hs" + pPath = dir "P.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + + bdoc <- createDoc bPath "haskell" bSource + + -- Change y from Int to B + changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] + + -- P should not typecheck, as there are no last valid artifacts for A + _pdoc <- createDoc pPath "haskell" pSource + + -- In this example the interface file for A should not exist (modulo the cache folder) + -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors + expectDiagnostics + [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) + ,("P.hs", [(DsWarning,(4,0), "Top-level binding")]) + ] + expectNoMoreDiagnostics 2 + +sessionDepsArePickedUp :: TestTree +sessionDepsArePickedUp = testSession' + "session-deps-are-picked-up" + $ \dir -> do + liftIO $ + writeFileUTF8 + (dir "hie.yaml") + "cradle: {direct: {arguments: []}}" + -- Open without OverloadedStrings and expect an error. + doc <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])] + -- Update hie.yaml to enable OverloadedStrings. + liftIO $ + writeFileUTF8 + (dir "hie.yaml") + "cradle: {direct: {arguments: [-XOverloadedStrings]}}" + -- Send change event. + let change = + TextDocumentContentChangeEvent + { _range = Just (Range (Position 4 0) (Position 4 0)), + _rangeLength = Nothing, + _text = "\n" + } + changeDoc doc [change] + -- Now no errors. + expectDiagnostics [("Foo.hs", [])] + where + fooContent = + T.unlines + [ "module Foo where", + "import Data.Text", + "foo :: Text", + "foo = \"hello\"" + ] + +-- A test to ensure that the command line ghcide workflow stays working +nonLspCommandLine :: TestTree +nonLspCommandLine = testGroup "ghcide command line" + [ testCase "works" $ withTempDir $ \dir -> do + ghcide <- locateGhcideExecutable + copyTestDataFiles dir "multi" + let cmd = (proc ghcide ["a/A.hs"]){cwd = Just dir} + + setEnv "HOME" "/homeless-shelter" False + + (ec, _, _) <- readCreateProcessWithExitCode cmd "" + + ec @=? ExitSuccess + ] + +benchmarkTests :: TestTree +benchmarkTests = + let ?config = Bench.defConfig + { Bench.verbosity = Bench.Quiet + , Bench.repetitions = Just 3 + , Bench.buildTool = Bench.Cabal + } in + withResource Bench.setup Bench.cleanUp $ \getResource -> testGroup "benchmark experiments" + [ testCase (Bench.name e) $ do + Bench.SetupResult{Bench.benchDir} <- getResource + res <- Bench.runBench (runInDir benchDir) e + assertBool "did not successfully complete 5 repetitions" $ Bench.success res + | e <- Bench.experiments + , Bench.name e /= "edit" -- the edit experiment does not ever fail + -- the cradle experiments are way too slow + , not ("cradle" `isInfixOf` Bench.name e) + ] + +-- | checks if we use InitializeParams.rootUri for loading session +rootUriTests :: TestTree +rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do + let bPath = dir "dirB/Foo.hs" + liftIO $ copyTestDataFiles dir "rootUri" + bSource <- liftIO $ readFileUtf8 bPath + _ <- createDoc "Foo.hs" "haskell" bSource + expectNoMoreDiagnostics 0.5 + where + -- similar to run' except we can configure where to start ghcide and session + runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO () + runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir) + +-- | Test if ghcide asynchronously handles Commands and user Requests +asyncTests :: TestTree +asyncTests = testGroup "async" + [ + testSession "command" $ do + -- Execute a command that will block forever + let req = ExecuteCommandParams Nothing blockCommandId Nothing + void $ sendRequest SWorkspaceExecuteCommand req + -- Load a file and check for code actions. Will only work if the command is run asynchronously + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS -Wmissing-signatures #-}" + , "foo = id" + ] + void waitForDiagnostics + actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0)) + liftIO $ [ _title | InR CodeAction{_title} <- actions] @=? + [ "add signature: foo :: a -> a" ] + , testSession "request" $ do + -- Execute a custom request that will block for 1000 seconds + void $ sendRequest (SCustomMethod "test") $ toJSON $ BlockSeconds 1000 + -- Load a file and check for code actions. Will only work if the request is run asynchronously + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS -Wmissing-signatures #-}" + , "foo = id" + ] + void waitForDiagnostics + actions <- getCodeActions doc (Range (Position 0 0) (Position 0 0)) + liftIO $ [ _title | InR CodeAction{_title} <- actions] @=? + [ "add signature: foo :: a -> a" ] + ] + + +clientSettingsTest :: TestTree +clientSettingsTest = testGroup "client settings handling" + [ testSession "ghcide restarts shake session on config changes" $ do + void $ skipManyTill anyMessage $ message SClientRegisterCapability + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String))) + nots <- skipManyTill anyMessage $ count 3 loggingNotification + isMessagePresent "Restarting build session" (map getLogMessage nots) + + ] + where getLogMessage :: FromServerMessage -> T.Text + getLogMessage (FromServerMess SWindowLogMessage (NotificationMessage _ _ (LogMessageParams _ msg))) = msg + getLogMessage _ = "" + + isMessagePresent expectedMsg actualMsgs = liftIO $ + assertBool ("\"" ++ expectedMsg ++ "\" is not present in: " ++ show actualMsgs) + (any ((expectedMsg `isSubsequenceOf`) . show) actualMsgs) + +referenceTests :: TestTree +referenceTests = testGroup "references" + [ testGroup "can get references to FOIs" + [ referenceTest "can get references to symbols" + ("References.hs", 4, 7) + YesIncludeDeclaration + [ ("References.hs", 4, 6) + , ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + + , referenceTest "can get references to data constructor" + ("References.hs", 13, 2) + YesIncludeDeclaration + [ ("References.hs", 13, 2) + , ("References.hs", 16, 14) + , ("References.hs", 19, 21) + ] + + , referenceTest "getting references works in the other module" + ("OtherModule.hs", 6, 0) + YesIncludeDeclaration + [ ("OtherModule.hs", 6, 0) + , ("OtherModule.hs", 8, 16) + ] + + , referenceTest "getting references works in the Main module" + ("Main.hs", 9, 0) + YesIncludeDeclaration + [ ("Main.hs", 9, 0) + , ("Main.hs", 10, 4) + ] + + , referenceTest "getting references to main works" + ("Main.hs", 5, 0) + YesIncludeDeclaration + [ ("Main.hs", 4, 0) + , ("Main.hs", 5, 0) + ] + + , referenceTest "can get type references" + ("Main.hs", 9, 9) + YesIncludeDeclaration + [ ("Main.hs", 9, 0) + , ("Main.hs", 9, 9) + , ("Main.hs", 10, 0) + ] + + , expectFailBecause "references provider does not respect includeDeclaration parameter" $ + referenceTest "works when we ask to exclude declarations" + ("References.hs", 4, 7) + NoExcludeDeclaration + [ ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + + , referenceTest "INCORRECTLY returns declarations when we ask to exclude them" + ("References.hs", 4, 7) + NoExcludeDeclaration + [ ("References.hs", 4, 6) + , ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + ] + + , testGroup "can get references to non FOIs" + [ referenceTest "can get references to symbol defined in a module we import" + ("References.hs", 22, 4) + YesIncludeDeclaration + [ ("References.hs", 22, 4) + , ("OtherModule.hs", 0, 20) + , ("OtherModule.hs", 4, 0) + ] + + , referenceTest "can get references in modules that import us to symbols we define" + ("OtherModule.hs", 4, 0) + YesIncludeDeclaration + [ ("References.hs", 22, 4) + , ("OtherModule.hs", 0, 20) + , ("OtherModule.hs", 4, 0) + ] + + , referenceTest "can get references to symbol defined in a module we import transitively" + ("References.hs", 24, 4) + YesIncludeDeclaration + [ ("References.hs", 24, 4) + , ("OtherModule.hs", 0, 48) + , ("OtherOtherModule.hs", 2, 0) + ] + + , referenceTest "can get references in modules that import us transitively to symbols we define" + ("OtherOtherModule.hs", 2, 0) + YesIncludeDeclaration + [ ("References.hs", 24, 4) + , ("OtherModule.hs", 0, 48) + , ("OtherOtherModule.hs", 2, 0) + ] + + , referenceTest "can get type references to other modules" + ("Main.hs", 12, 10) + YesIncludeDeclaration + [ ("Main.hs", 12, 7) + , ("Main.hs", 13, 0) + , ("References.hs", 12, 5) + , ("References.hs", 16, 0) + ] + ] + ] + +-- | When we ask for all references to symbol "foo", should the declaration "foo +-- = 2" be among the references returned? +data IncludeDeclaration = + YesIncludeDeclaration + | NoExcludeDeclaration + +getReferences' :: SymbolLocation -> IncludeDeclaration -> Session (List Location) +getReferences' (file, l, c) includeDeclaration = do + doc <- openDoc file "haskell" + getReferences doc (Position l c) $ toBool includeDeclaration + where toBool YesIncludeDeclaration = True + toBool NoExcludeDeclaration = False + +referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree +referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do + let docs = map (dir ) $ delete thisDoc $ nubOrd docs' + -- Initial Index + docid <- openDoc thisDoc "haskell" + let + loop :: [FilePath] -> Session () + loop [] = pure () + loop docs = do + doc <- skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do + A.Success fp' <- pure $ fromJSON fp + find (fp' ==) docs + _ -> Nothing + loop (delete doc docs) + loop docs + f dir + closeDoc docid + +-- | Given a location, lookup the symbol and all references to it. Make sure +-- they are the ones we expect. +referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree +referenceTest name loc includeDeclaration expected = + referenceTestSession name (fst3 loc) docs $ \dir -> do + List actual <- getReferences' loc includeDeclaration + liftIO $ actual `expectSameLocations` map (first3 (dir )) expected + where + docs = map fst3 expected + +type SymbolLocation = (FilePath, Int, Int) + +expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion +expectSameLocations actual expected = do + let actual' = + Set.map (\location -> (location ^. L.uri + , location ^. L.range . L.start . L.line + , location ^. L.range . L.start . L.character)) + $ Set.fromList actual + expected' <- Set.fromList <$> + (forM expected $ \(file, l, c) -> do + fp <- canonicalizePath file + return (filePathToUri fp, l, c)) + actual' @?= expected' + +---------------------------------------------------------------------- +-- Utils +---------------------------------------------------------------------- + +testSession :: String -> Session () -> TestTree +testSession name = testCase name . run + +testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree +testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix + +testSession' :: String -> (FilePath -> Session ()) -> TestTree +testSession' name = testCase name . run' + +testSessionWait :: String -> Session () -> TestTree +testSessionWait name = testSession name . + -- Check that any diagnostics produced were already consumed by the test case. + -- + -- If in future we add test cases where we don't care about checking the diagnostics, + -- this could move elsewhere. + -- + -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear. + ( >> expectNoMoreDiagnostics 0.5) + +pickActionWithTitle :: T.Text -> [Command |? CodeAction] -> IO CodeAction +pickActionWithTitle title actions = do + assertBool ("Found no matching actions for " <> show title <> " in " <> show titles) (not $ null matches) + return $ head matches + where + titles = + [ actionTitle + | InR CodeAction { _title = actionTitle } <- actions + ] + matches = + [ action + | InR action@CodeAction { _title = actionTitle } <- actions + , title == actionTitle + ] + +mkRange :: Int -> Int -> Int -> Int -> Range +mkRange a b c d = Range (Position a b) (Position c d) + +run :: Session a -> IO a +run s = run' (const s) + +runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a +runWithExtraFiles prefix s = withTempDir $ \dir -> do + copyTestDataFiles dir prefix + runInDir dir (s dir) + +copyTestDataFiles :: FilePath -> FilePath -> IO () +copyTestDataFiles dir prefix = do + -- Copy all the test data files to the temporary workspace + testDataFiles <- getDirectoryFilesIO ("test/data" prefix) ["//*"] + for_ testDataFiles $ \f -> do + createDirectoryIfMissing True $ dir takeDirectory f + copyFile ("test/data" prefix f) (dir f) + +run' :: (FilePath -> Session a) -> IO a +run' s = withTempDir $ \dir -> runInDir dir (s dir) + +runInDir :: FilePath -> Session a -> IO a +runInDir dir = runInDir' dir "." "." [] + +withLongTimeout :: IO a -> IO a +withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") + +-- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root. +runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a +runInDir' dir startExeIn startSessionIn extraOptions s = do + ghcideExe <- locateGhcideExecutable + let startDir = dir startExeIn + let projDir = dir startSessionIn + + createDirectoryIfMissing True startDir + createDirectoryIfMissing True projDir + -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56 + -- since the package import test creates "Data/List.hs", which otherwise has no physical home + createDirectoryIfMissing True $ projDir ++ "/Data" + + shakeProfiling <- getEnv "SHAKE_PROFILING" + let cmd = unwords $ + [ghcideExe, "--lsp", "--test", "--verbose", "-j2", "--cwd", startDir + ] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling] + ] ++ extraOptions + -- HIE calls getXgdDirectory which assumes that HOME is set. + -- Only sets HOME if it wasn't already set. + setEnv "HOME" "/homeless-shelter" False + let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True } + logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR" + timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT" + let conf = defaultConfig{messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride} + -- uncomment this or set LSP_TEST_LOG_STDERR=1 to see all logging + -- { logStdErr = True } + -- uncomment this or set LSP_TEST_LOG_MESSAGES=1 to see all messages + -- { logMessages = True } + runSessionWithConfig conf{logColor} cmd lspTestCaps projDir s + where + checkEnv :: String -> IO (Maybe Bool) + checkEnv s = fmap convertVal <$> getEnv s + convertVal "0" = False + convertVal _ = True + +openTestDataDoc :: FilePath -> Session TextDocumentIdentifier +openTestDataDoc path = do + source <- liftIO $ readFileUtf8 $ "test/data" path + createDoc path "haskell" source + +findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] +findCodeActions = findCodeActions' (==) "is not a superset of" + +findCodeActionsByPrefix :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] +findCodeActionsByPrefix = findCodeActions' T.isPrefixOf "is not prefix of" + +findCodeActions' :: (T.Text -> T.Text -> Bool) -> String -> TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] +findCodeActions' op errMsg doc range expectedTitles = do + actions <- getCodeActions doc range + let matches = sequence + [ listToMaybe + [ action + | InR action@CodeAction { _title = actionTitle } <- actions + , expectedTitle `op` actionTitle] + | expectedTitle <- expectedTitles] + let msg = show + [ actionTitle + | InR CodeAction { _title = actionTitle } <- actions + ] + ++ " " <> errMsg <> " " + ++ show expectedTitles + liftIO $ case matches of + Nothing -> assertFailure msg + Just _ -> pure () + return (fromJust matches) + +findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction +findCodeAction doc range t = head <$> findCodeActions doc range [t] + +unitTests :: TestTree +unitTests = do + testGroup "Unit" + [ testCase "empty file path does NOT work with the empty String literal" $ + uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "." + , testCase "empty file path works using toNormalizedFilePath'" $ + uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just "" + , testCase "empty path URI" $ do + Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri) + uriScheme @?= "file:" + uriPath @?= "" + , testCase "from empty path URI" $ do + let uri = Uri "file://" + uriToFilePath' uri @?= Just "" + , testCase "Key with empty file path roundtrips via Binary" $ + Binary.decode (Binary.encode (Q ((), emptyFilePath))) @?= Q ((), emptyFilePath) + , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do + let diag = ("", Diagnostics.ShowDiag, Diagnostic + { _range = Range + { _start = Position{_line = 0, _character = 1} + , _end = Position{_line = 2, _character = 3} + } + , _severity = Nothing + , _code = Nothing + , _source = Nothing + , _message = "" + , _relatedInformation = Nothing + , _tags = Nothing + }) + let shown = T.unpack (Diagnostics.showDiagnostics [diag]) + let expected = "1:2-3:4" + assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $ + expected `isInfixOf` shown + ] + +positionMappingTests :: TestTree +positionMappingTests = + testGroup "position mapping" + [ testGroup "toCurrent" + [ testCase "before" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 0) @?= PositionExact (Position 0 0) + , testCase "after, same line, same length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 3) @?= PositionExact (Position 0 3) + , testCase "after, same line, increased length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 0 3) @?= PositionExact (Position 0 4) + , testCase "after, same line, decreased length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "a" + (Position 0 3) @?= PositionExact (Position 0 2) + , testCase "after, next line, no newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 1 3) @?= PositionExact (Position 1 3) + , testCase "after, next line, newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\ndef" + (Position 1 0) @?= PositionExact (Position 2 0) + , testCase "after, same line, newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd" + (Position 0 4) @?= PositionExact (Position 1 2) + , testCase "after, same line, newline + newline at end" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd\n" + (Position 0 4) @?= PositionExact (Position 2 1) + , testCase "after, same line, newline + newline at end" $ + toCurrent + (Range (Position 0 1) (Position 0 1)) + "abc" + (Position 0 1) @?= PositionExact (Position 0 4) + ] + , testGroup "fromCurrent" + [ testCase "before" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 0) @?= PositionExact (Position 0 0) + , testCase "after, same line, same length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 3) @?= PositionExact (Position 0 3) + , testCase "after, same line, increased length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 0 4) @?= PositionExact (Position 0 3) + , testCase "after, same line, decreased length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "a" + (Position 0 2) @?= PositionExact (Position 0 3) + , testCase "after, next line, no newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 1 3) @?= PositionExact (Position 1 3) + , testCase "after, next line, newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\ndef" + (Position 2 0) @?= PositionExact (Position 1 0) + , testCase "after, same line, newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd" + (Position 1 2) @?= PositionExact (Position 0 4) + , testCase "after, same line, newline + newline at end" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd\n" + (Position 2 1) @?= PositionExact (Position 0 4) + , testCase "after, same line, newline + newline at end" $ + fromCurrent + (Range (Position 0 1) (Position 0 1)) + "abc" + (Position 0 4) @?= PositionExact (Position 0 1) + ] + , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties" + [ testProperty "fromCurrent r t <=< toCurrent r t" $ do + -- Note that it is important to use suchThatMap on all values at once + -- instead of only using it on the position. Otherwise you can get + -- into situations where there is no position that can be mapped back + -- for the edit which will result in QuickCheck looping forever. + let gen = do + rope <- genRope + range <- genRange rope + PrintableText replacement <- arbitrary + oldPos <- genPosition rope + pure (range, replacement, oldPos) + forAll + (suchThatMap gen + (\(range, replacement, oldPos) -> positionResultToMaybe $ (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $ + \(range, replacement, oldPos, newPos) -> + fromCurrent range replacement newPos === PositionExact oldPos + , testProperty "toCurrent r t <=< fromCurrent r t" $ do + let gen = do + rope <- genRope + range <- genRange rope + PrintableText replacement <- arbitrary + let newRope = applyChange rope (TextDocumentContentChangeEvent (Just range) Nothing replacement) + newPos <- genPosition newRope + pure (range, replacement, newPos) + forAll + (suchThatMap gen + (\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $ + \(range, replacement, newPos, oldPos) -> + toCurrent range replacement oldPos === PositionExact newPos + ] + ] + +newtype PrintableText = PrintableText { getPrintableText :: T.Text } + deriving Show + +instance Arbitrary PrintableText where + arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary + + +genRope :: Gen Rope +genRope = Rope.fromText . getPrintableText <$> arbitrary + +genPosition :: Rope -> Gen Position +genPosition r = do + row <- choose (0, max 0 $ rows - 1) + let columns = Rope.columns (nthLine row r) + column <- choose (0, max 0 $ columns - 1) + pure $ Position row column + where rows = Rope.rows r + +genRange :: Rope -> Gen Range +genRange r = do + startPos@(Position startLine startColumn) <- genPosition r + let maxLineDiff = max 0 $ rows - 1 - startLine + endLine <- choose (startLine, startLine + maxLineDiff) + let columns = Rope.columns (nthLine endLine r) + endColumn <- + if startLine == endLine + then choose (startColumn, columns) + else choose (0, max 0 $ columns - 1) + pure $ Range startPos (Position endLine endColumn) + where rows = Rope.rows r + +-- | Get the ith line of a rope, starting from 0. Trailing newline not included. +nthLine :: Int -> Rope -> Rope +nthLine i r + | i < 0 = error $ "Negative line number: " <> show i + | i == 0 && Rope.rows r == 0 = r + | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r) + | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r + +getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions] +getWatchedFilesSubscriptionsUntil m = do + msgs <- manyTill (Just <$> message SClientRegisterCapability <|> Nothing <$ anyMessage) (message m) + return + [ args + | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs + , SomeRegistration (Registration _id SWorkspaceDidChangeWatchedFiles args) <- regs + ] + +-- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path +-- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or +-- @/var@ +withTempDir :: (FilePath -> IO a) -> IO a +withTempDir f = System.IO.Extra.withTempDir $ \dir -> do + dir' <- canonicalizePath dir + f dir' + +-- | Assert that a value is not 'Nothing', and extract the value. +assertJust :: MonadIO m => String -> Maybe a -> m a +assertJust s = \case + Nothing -> liftIO $ assertFailure s + Just x -> pure x diff --git a/test/preprocessor/Main.hs b/test/preprocessor/Main.hs --- a/test/preprocessor/Main.hs +++ b/test/preprocessor/Main.hs @@ -1,10 +1,10 @@ - -module Main(main) where - -import System.Environment - -main :: IO () -main = do - _:input:output:_ <- getArgs - let f = map (\x -> if x == 'x' then 'y' else x) - writeFile output . f =<< readFile input + +module Main(main) where + +import System.Environment + +main :: IO () +main = do + _:input:output:_ <- getArgs + let f = map (\x -> if x == 'x' then 'y' else x) + writeFile output . f =<< readFile input diff --git a/test/src/Development/IDE/Test.hs b/test/src/Development/IDE/Test.hs --- a/test/src/Development/IDE/Test.hs +++ b/test/src/Development/IDE/Test.hs @@ -1,201 +1,202 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} - -module Development.IDE.Test - ( Cursor - , cursorPosition - , requireDiagnostic - , diagnostic - , expectDiagnostics - , expectDiagnosticsWithTags - , expectNoMoreDiagnostics - , expectMessages - , expectCurrentDiagnostics - , checkDiagnosticsForDoc - , canonicalizeUri - , standardizeQuotes - , flushMessages - , waitForAction - ) where - -import qualified Data.Aeson as A -import Control.Applicative.Combinators -import Control.Lens hiding (List) -import Control.Monad -import Control.Monad.IO.Class -import Data.Bifunctor (second) -import qualified Data.Map.Strict as Map -import qualified Data.Text as T -import Language.LSP.Test hiding (message) -import qualified Language.LSP.Test as LspTest -import Language.LSP.Types -import Language.LSP.Types.Lens as Lsp -import System.Time.Extra -import Test.Tasty.HUnit -import System.Directory (canonicalizePath) -import Data.Maybe (fromJust) -import Development.IDE.Plugin.Test (WaitForIdeRuleResult, TestRequest(..)) - --- | (0-based line number, 0-based column number) -type Cursor = (Int, Int) - -cursorPosition :: Cursor -> Position -cursorPosition (line, col) = Position line col - -requireDiagnostic :: List Diagnostic -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) -> Assertion -requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) = do - unless (any match actuals) $ - assertFailure $ - "Could not find " <> show expected <> - " in " <> show actuals - where - match :: Diagnostic -> Bool - match d = - Just severity == _severity d - && cursorPosition cursor == d ^. range . start - && standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf` - standardizeQuotes (T.toLower $ d ^. message) - && hasTag expectedTag (d ^. tags) - - hasTag :: Maybe DiagnosticTag -> Maybe (List DiagnosticTag) -> Bool - hasTag Nothing _ = True - hasTag (Just _) Nothing = False - hasTag (Just actualTag) (Just (List tags)) = actualTag `elem` tags - --- |wait for @timeout@ seconds and report an assertion failure --- if any diagnostic messages arrive in that period -expectNoMoreDiagnostics :: Seconds -> Session () -expectNoMoreDiagnostics timeout = - expectMessages STextDocumentPublishDiagnostics timeout $ \diagsNot -> do - let fileUri = diagsNot ^. params . uri - actual = diagsNot ^. params . diagnostics - liftIO $ - assertFailure $ - "Got unexpected diagnostics for " <> show fileUri - <> " got " - <> show actual - -expectMessages :: SMethod m -> Seconds -> (ServerMessage m -> Session ()) -> Session () -expectMessages m timeout handle = 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. - let cm = SCustomMethod "test" - i <- sendRequest cm $ A.toJSON GetShakeSessionQueueCount - go cm i - where - go cm i = handleMessages - where - handleMessages = (LspTest.message m >>= handle) <|> (void $ responseForId cm i) <|> ignoreOthers - ignoreOthers = void anyMessage >> handleMessages - -flushMessages :: Session () -flushMessages = do - let cm = SCustomMethod "non-existent-method" - i <- sendRequest cm A.Null - void (responseForId cm i) <|> ignoreOthers cm i - where - ignoreOthers cm i = skipManyTill anyMessage (responseForId cm i) >> flushMessages - --- | It is not possible to use 'expectDiagnostics []' to assert the absence of diagnostics, --- only that existing diagnostics have been cleared. --- --- Rather than trying to assert the absence of diagnostics, introduce an --- expected diagnostic (e.g. a redundant import) and assert the singleton diagnostic. -expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session () -expectDiagnostics - = expectDiagnosticsWithTags - . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) - -unwrapDiagnostic :: NotificationMessage TextDocumentPublishDiagnostics -> (Uri, List Diagnostic) -unwrapDiagnostic diagsNot = (diagsNot^.params.uri, diagsNot^.params.diagnostics) - -expectDiagnosticsWithTags :: [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () -expectDiagnosticsWithTags expected = do - let f = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri - next = unwrapDiagnostic <$> skipManyTill anyMessage diagnostic - expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) f expected - expectDiagnosticsWithTags' next expected' - -expectDiagnosticsWithTags' :: - MonadIO m => - m (Uri, List Diagnostic) -> - Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] -> - m () -expectDiagnosticsWithTags' next m | null m = do - (_,actual) <- next - case actual of - List [] -> - return () - _ -> - liftIO $ assertFailure $ "Got unexpected diagnostics:" <> show actual - -expectDiagnosticsWithTags' next expected = go expected - where - go m - | Map.null m = pure () - | otherwise = do - (fileUri, actual) <- next - canonUri <- liftIO $ toNormalizedUri <$> canonicalizeUri fileUri - case Map.lookup canonUri m of - Nothing -> do - liftIO $ - assertFailure $ - "Got diagnostics for " <> show fileUri - <> " but only expected diagnostics for " - <> show (Map.keys m) - <> " got " - <> show actual - Just expected -> do - liftIO $ mapM_ (requireDiagnostic actual) expected - liftIO $ - unless (length expected == length actual) $ - assertFailure $ - "Incorrect number of diagnostics for " <> show fileUri - <> ", expected " - <> show expected - <> " but got " - <> show actual - go $ Map.delete canonUri m - -expectCurrentDiagnostics :: TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session () -expectCurrentDiagnostics doc expected = do - diags <- getCurrentDiagnostics doc - checkDiagnosticsForDoc doc expected diags - -checkDiagnosticsForDoc :: TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> [Diagnostic] -> Session () -checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do - let expected' = Map.fromList [(nuri, map (\(ds, c, t) -> (ds, c, t, Nothing)) expected)] - nuri = toNormalizedUri _uri - expectDiagnosticsWithTags' (return (_uri, List obtained)) expected' - -canonicalizeUri :: Uri -> IO Uri -canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePath uri)) - -diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics) -diagnostic = LspTest.message STextDocumentPublishDiagnostics - -standardizeQuotes :: T.Text -> T.Text -standardizeQuotes msg = let - repl '‘' = '\'' - repl '’' = '\'' - repl '`' = '\'' - repl c = c - in T.map repl msg - -waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) -waitForAction key TextDocumentIdentifier{_uri} = do - let cm = SCustomMethod "test" - waitId <- sendRequest cm (A.toJSON $ WaitForIdeRule key _uri) - ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId - return $ do - e <- _result - case A.fromJSON e of - A.Error e -> Left $ ResponseError InternalError (T.pack e) Nothing - A.Success a -> pure a +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE PolyKinds #-} + +module Development.IDE.Test + ( Cursor + , cursorPosition + , requireDiagnostic + , diagnostic + , expectDiagnostics + , expectDiagnosticsWithTags + , expectNoMoreDiagnostics + , expectMessages + , expectCurrentDiagnostics + , checkDiagnosticsForDoc + , canonicalizeUri + , standardizeQuotes + , flushMessages + , waitForAction + ) where + +import Control.Applicative.Combinators +import Control.Lens hiding (List) +import Control.Monad +import Control.Monad.IO.Class +import qualified Data.Aeson as A +import Data.Bifunctor (second) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust) +import qualified Data.Text as T +import Development.IDE.Plugin.Test (TestRequest (..), + WaitForIdeRuleResult) +import Language.LSP.Test hiding (message) +import qualified Language.LSP.Test as LspTest +import Language.LSP.Types +import Language.LSP.Types.Lens as Lsp +import System.Directory (canonicalizePath) +import System.Time.Extra +import Test.Tasty.HUnit + +-- | (0-based line number, 0-based column number) +type Cursor = (Int, Int) + +cursorPosition :: Cursor -> Position +cursorPosition (line, col) = Position line col + +requireDiagnostic :: List Diagnostic -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) -> Assertion +requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) = do + unless (any match actuals) $ + assertFailure $ + "Could not find " <> show expected <> + " in " <> show actuals + where + match :: Diagnostic -> Bool + match d = + Just severity == _severity d + && cursorPosition cursor == d ^. range . start + && standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf` + standardizeQuotes (T.toLower $ d ^. message) + && hasTag expectedTag (d ^. tags) + + hasTag :: Maybe DiagnosticTag -> Maybe (List DiagnosticTag) -> Bool + hasTag Nothing _ = True + hasTag (Just _) Nothing = False + hasTag (Just actualTag) (Just (List tags)) = actualTag `elem` tags + +-- |wait for @timeout@ seconds and report an assertion failure +-- if any diagnostic messages arrive in that period +expectNoMoreDiagnostics :: Seconds -> Session () +expectNoMoreDiagnostics timeout = + expectMessages STextDocumentPublishDiagnostics timeout $ \diagsNot -> do + let fileUri = diagsNot ^. params . uri + actual = diagsNot ^. params . diagnostics + liftIO $ + assertFailure $ + "Got unexpected diagnostics for " <> show fileUri + <> " got " + <> show actual + +expectMessages :: SMethod m -> Seconds -> (ServerMessage m -> Session ()) -> Session () +expectMessages m timeout handle = 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. + let cm = SCustomMethod "test" + i <- sendRequest cm $ A.toJSON GetShakeSessionQueueCount + go cm i + where + go cm i = handleMessages + where + handleMessages = (LspTest.message m >>= handle) <|> (void $ responseForId cm i) <|> ignoreOthers + ignoreOthers = void anyMessage >> handleMessages + +flushMessages :: Session () +flushMessages = do + let cm = SCustomMethod "non-existent-method" + i <- sendRequest cm A.Null + void (responseForId cm i) <|> ignoreOthers cm i + where + ignoreOthers cm i = skipManyTill anyMessage (responseForId cm i) >> flushMessages + +-- | It is not possible to use 'expectDiagnostics []' to assert the absence of diagnostics, +-- only that existing diagnostics have been cleared. +-- +-- Rather than trying to assert the absence of diagnostics, introduce an +-- expected diagnostic (e.g. a redundant import) and assert the singleton diagnostic. +expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session () +expectDiagnostics + = expectDiagnosticsWithTags + . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) + +unwrapDiagnostic :: NotificationMessage TextDocumentPublishDiagnostics -> (Uri, List Diagnostic) +unwrapDiagnostic diagsNot = (diagsNot^.params.uri, diagsNot^.params.diagnostics) + +expectDiagnosticsWithTags :: [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () +expectDiagnosticsWithTags expected = do + let f = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri + next = unwrapDiagnostic <$> skipManyTill anyMessage diagnostic + expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) f expected + expectDiagnosticsWithTags' next expected' + +expectDiagnosticsWithTags' :: + MonadIO m => + m (Uri, List Diagnostic) -> + Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] -> + m () +expectDiagnosticsWithTags' next m | null m = do + (_,actual) <- next + case actual of + List [] -> + return () + _ -> + liftIO $ assertFailure $ "Got unexpected diagnostics:" <> show actual + +expectDiagnosticsWithTags' next expected = go expected + where + go m + | Map.null m = pure () + | otherwise = do + (fileUri, actual) <- next + canonUri <- liftIO $ toNormalizedUri <$> canonicalizeUri fileUri + case Map.lookup canonUri m of + Nothing -> do + liftIO $ + assertFailure $ + "Got diagnostics for " <> show fileUri + <> " but only expected diagnostics for " + <> show (Map.keys m) + <> " got " + <> show actual + Just expected -> do + liftIO $ mapM_ (requireDiagnostic actual) expected + liftIO $ + unless (length expected == length actual) $ + assertFailure $ + "Incorrect number of diagnostics for " <> show fileUri + <> ", expected " + <> show expected + <> " but got " + <> show actual + go $ Map.delete canonUri m + +expectCurrentDiagnostics :: TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session () +expectCurrentDiagnostics doc expected = do + diags <- getCurrentDiagnostics doc + checkDiagnosticsForDoc doc expected diags + +checkDiagnosticsForDoc :: TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> [Diagnostic] -> Session () +checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do + let expected' = Map.fromList [(nuri, map (\(ds, c, t) -> (ds, c, t, Nothing)) expected)] + nuri = toNormalizedUri _uri + expectDiagnosticsWithTags' (return (_uri, List obtained)) expected' + +canonicalizeUri :: Uri -> IO Uri +canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePath uri)) + +diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics) +diagnostic = LspTest.message STextDocumentPublishDiagnostics + +standardizeQuotes :: T.Text -> T.Text +standardizeQuotes msg = let + repl '‘' = '\'' + repl '’' = '\'' + repl '`' = '\'' + repl c = c + in T.map repl msg + +waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) +waitForAction key TextDocumentIdentifier{_uri} = do + let cm = SCustomMethod "test" + waitId <- sendRequest cm (A.toJSON $ WaitForIdeRule key _uri) + ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId + return $ do + e <- _result + case A.fromJSON e of + A.Error e -> Left $ ResponseError InternalError (T.pack e) Nothing + A.Success a -> pure a