packages feed

ghcide 0.7.5.0 → 1.0.0.0

raw patch · 80 files changed

+22772/−22787 lines, 80 filesdep ~hie-compatdep ~hls-plugin-apiPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: hie-compat, hls-plugin-api

API changes (from Hackage documentation)

+ Development.IDE: getClientConfig :: MonadLsp Config m => ShakeExtras -> m Config
+ Development.IDE: getPluginConfig :: MonadLsp Config m => ShakeExtras -> PluginId -> m PluginConfig
+ Development.IDE.Core.RuleTypes: instance Control.DeepSeq.NFData Development.IDE.Core.RuleTypes.LinkableType
+ Development.IDE.Core.RuleTypes: instance Data.Hashable.Class.Hashable Development.IDE.Core.RuleTypes.LinkableType
+ Development.IDE.Core.RuleTypes: instance GHC.Generics.Generic Development.IDE.Core.RuleTypes.LinkableType
+ Development.IDE.Core.Shake: [defaultConfig] :: ShakeExtras -> Config
+ Development.IDE.Core.Shake: getClientConfig :: MonadLsp Config m => ShakeExtras -> m Config
+ Development.IDE.Core.Shake: getPluginConfig :: MonadLsp Config m => ShakeExtras -> PluginId -> m PluginConfig
- Development.IDE.Core.Service: initialise :: Rules () -> Maybe (LanguageContextEnv Config) -> Logger -> Debouncer NormalizedUri -> IdeOptions -> VFSHandle -> HieDb -> IndexQueue -> IO IdeState
+ Development.IDE.Core.Service: initialise :: Config -> Rules () -> Maybe (LanguageContextEnv Config) -> Logger -> Debouncer NormalizedUri -> IdeOptions -> VFSHandle -> HieDb -> IndexQueue -> IO IdeState
- Development.IDE.Core.Shake: ShakeExtras :: Maybe (LanguageContextEnv Config) -> Debouncer NormalizedUri -> Logger -> Var (HashMap TypeRep Dynamic) -> Var Values -> Var DiagnosticStore -> Var DiagnosticStore -> Var (HashMap NormalizedUri [Diagnostic]) -> Var (HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping))) -> Var (HashMap NormalizedFilePath Int) -> (ProgressEvent -> IO ()) -> IdeTesting -> MVar ShakeSession -> ([DelayedAction ()] -> IO ()) -> IORef NameCache -> Var (Hashed KnownTargets) -> Var ExportsMap -> ActionQueue -> ClientCapabilities -> HieDb -> HieDbWriter -> Var (HashMap Key GetStalePersistent) -> VFSHandle -> ShakeExtras
+ Development.IDE.Core.Shake: ShakeExtras :: Maybe (LanguageContextEnv Config) -> Debouncer NormalizedUri -> Logger -> Var (HashMap TypeRep Dynamic) -> Var Values -> Var DiagnosticStore -> Var DiagnosticStore -> Var (HashMap NormalizedUri [Diagnostic]) -> Var (HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping))) -> Var (HashMap NormalizedFilePath Int) -> (ProgressEvent -> IO ()) -> IdeTesting -> MVar ShakeSession -> ([DelayedAction ()] -> IO ()) -> IORef NameCache -> Var (Hashed KnownTargets) -> Var ExportsMap -> ActionQueue -> ClientCapabilities -> HieDb -> HieDbWriter -> Var (HashMap Key GetStalePersistent) -> VFSHandle -> Config -> ShakeExtras
- Development.IDE.Core.Shake: shakeOpen :: Maybe (LanguageContextEnv Config) -> Logger -> Debouncer NormalizedUri -> Maybe FilePath -> IdeReportProgress -> IdeTesting -> HieDb -> IndexQueue -> VFSHandle -> ShakeOptions -> Rules () -> IO IdeState
+ Development.IDE.Core.Shake: shakeOpen :: Maybe (LanguageContextEnv Config) -> Config -> Logger -> Debouncer NormalizedUri -> Maybe FilePath -> IdeReportProgress -> IdeTesting -> HieDb -> IndexQueue -> VFSHandle -> ShakeOptions -> Rules () -> IO IdeState
- Development.IDE.Plugin.HLS: asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config
+ Development.IDE.Plugin.HLS: asGhcIdePlugin :: Config -> IdePlugins IdeState -> Plugin Config

Files

CHANGELOG.md view
@@ -1,265 +1,265 @@-### 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)+### 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)
LICENSE view
@@ -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.
README.md view
@@ -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/).
bench/exe/Main.hs view
@@ -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 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
bench/hist/Main.hs view
@@ -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-    ├── <git-reference>-    │   ├── ghc.path                          - path to ghc used to build the binary-    │   ├── ghcide                            - binary for this version-    ├─ <example>-    │   ├── results.csv                           - aggregated results for all the versions-    │   └── <git-reference>-    │       ├── <experiment>.gcStats.log          - RTS -s output-    │       ├── <experiment>.csv                  - stats for the experiment-    │       ├── <experiment>.svg                  - Graph of bytes over elapsed time-    │       ├── <experiment>.diff.svg             - idem, including the previous version-    │       ├── <experiment>.log                  - ghcide-bench output-    │       └── results.csv                       - results of all the experiments for the example-    ├── results.csv        - aggregated results of all the experiments and versions-    └── <experiment>.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
+    ├── <git-reference>
+    │   ├── ghc.path                          - path to ghc used to build the binary
+    │   ├── ghcide                            - binary for this version
+    ├─ <example>
+    │   ├── results.csv                           - aggregated results for all the versions
+    │   └── <git-reference>
+    │       ├── <experiment>.gcStats.log          - RTS -s output
+    │       ├── <experiment>.csv                  - stats for the experiment
+    │       ├── <experiment>.svg                  - Graph of bytes over elapsed time
+    │       ├── <experiment>.diff.svg             - idem, including the previous version
+    │       ├── <experiment>.log                  - ghcide-bench output
+    │       └── results.csv                       - results of all the experiments for the example
+    ├── results.csv        - aggregated results of all the experiments and versions
+    └── <experiment>.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/lib/Experiments.hs view
@@ -1,573 +1,573 @@-{-# 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 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
bench/lib/Experiments/Types.hs view
@@ -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 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]
cbits/getmodtime.c view
@@ -1,21 +1,21 @@-// Copyright (c) 2019 The DAML Authors. All rights reserved.-// SPDX-License-Identifier: Apache-2.0--#include <sys/stat.h>-#include <time.h>-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 <sys/stat.h>
+#include <time.h>
+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;
+}
+
exe/Arguments.hs view
@@ -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 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"
exe/Main.hs view
@@ -1,117 +1,117 @@--- 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.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
+                  }
+            }
+
ghcide.cabal view
@@ -1,415 +1,425 @@-cabal-version:      1.20-build-type:         Simple-category:           Development-name:               ghcide-version:            0.7.5.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--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,-        hashable,-        hie-compat,-        hls-plugin-api >= 0.7.1,-        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--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--    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.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
include/ghc-api-version.h view
@@ -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
session-loader/Development/IDE/Session.hs view
@@ -1,862 +1,862 @@-{-# 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 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)
session-loader/Development/IDE/Session/VersionCheck.hs view
@@ -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"))
src/Development/IDE.hs view
@@ -1,46 +1,50 @@-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.RuleTypes as X-import Development.IDE.Core.Rules as X-  (getAtPoint-  ,getClientConfigAction-  ,getDefinition-  ,getParsedModule-  ,getTypeDefinition-  )-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.Service as X (runAction)-import Development.IDE.Core.Shake as X-  ( IdeState,-    shakeExtras,-    ShakeExtras,-    IdeRule,-    define, defineEarlyCutoff,-    use, useNoFile, uses, useWithStale, useWithStaleFast, useWithStaleFast',-    FastResult(..),-    use_, useNoFile_, uses_, useWithStale_,-    ideLogger,-    actionLogger,-    IdeAction(..), runIdeAction-  )-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, action, Rules, RuleResult)+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)
src/Development/IDE/Core/Compile.hs view
@@ -1,968 +1,973 @@--- 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 "<internal>")-      . (("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-                          session' = session { hsc_dflags = (ms_hspp_opts summary') { outputFile = Just dot_o }}-                      (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 "<internal>")-    . (("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 "<internal>")-    . (("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 "<built-in>" and "<command-line>"-               --   - 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 "<ghcide>") 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 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 "<internal>")
+      . (("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 "<internal>")
+    . (("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 "<internal>")
+    . (("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 "<built-in>" and "<command-line>"
+               --   - 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 "<ghcide>") 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
src/Development/IDE/Core/Debouncer.hs view
@@ -1,57 +1,57 @@--- 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.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
src/Development/IDE/Core/FileExists.hs view
@@ -1,239 +1,239 @@-{-# 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.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)
src/Development/IDE/Core/FileStore.hs view
@@ -1,242 +1,242 @@--- 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
+    ) 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 []
src/Development/IDE/Core/IdeConfiguration.hs view
@@ -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.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
src/Development/IDE/Core/OfInterest.hs view
@@ -1,121 +1,121 @@--- 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 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
+
src/Development/IDE/Core/PositionMapping.hs view
@@ -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.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)
src/Development/IDE/Core/Preprocessor.hs view
@@ -1,227 +1,227 @@--- 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.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
src/Development/IDE/Core/RuleTypes.hs view
@@ -1,470 +1,472 @@--- 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)---- 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 = Bool--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 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
src/Development/IDE/Core/Rules.hs view
@@ -1,1123 +1,1140 @@--- 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-getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType)-getLinkableType f = do-  needsComp <- use_ NeedsCompilation f-  pure $ if needsComp then Just BCOLinkable else Nothing--needsCompilationRule :: Rules ()-needsCompilationRule = defineEarlyCutoff $ \NeedsCompilation file -> 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.-  (ms,_) <- fst <$> useWithStale_ GetModSummaryWithoutTimestamps file-  -- A file needs object code if it uses TemplateHaskell or any file that depends on it uses TemplateHaskell-  res <--    if uses_th_qq ms-    then pure True-    else do-      graph <- useNoFile GetModuleGraph-      case graph of-          -- Treat as False if some reverse dependency header fails to parse-          Nothing -> pure False-          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 -> anyM (fmap (fromMaybe False) . use NeedsCompilation) revdeps--  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---- | 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 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
src/Development/IDE/Core/Service.hs view
@@ -1,80 +1,82 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.--- SPDX-License-Identifier: Apache-2.0--{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RankNTypes #-}---- | 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.Types.Options (IdeOptions(..))-import Development.IDE.Core.Debouncer-import           Development.IDE.Core.FileStore  (fileStoreRules)-import           Development.IDE.Core.FileExists (fileExistsRules)-import           Development.IDE.Core.OfInterest-import Development.IDE.Types.Logger as Logger-import           Development.Shake-import qualified Language.LSP.Server as LSP-import qualified Language.LSP.Types as LSP-import           Ide.Plugin.Config--import           Development.IDE.Core.Shake-import Control.Monad------------------------------------------------------------------ Exposed API---- | Initialise the Compiler Service.-initialise :: Rules ()-           -> Maybe (LSP.LanguageContextEnv Config)-           -> Logger-           -> Debouncer LSP.NormalizedUri-           -> IdeOptions-           -> VFSHandle-           -> HieDb-           -> IndexQueue-           -> IO IdeState-initialise mainRule lspEnv logger debouncer options vfs hiedb hiedbChan =-    shakeOpen-        lspEnv-        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.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)
src/Development/IDE/Core/Shake.hs view
@@ -1,1136 +1,1153 @@--- 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(..),-    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---- | 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-    }--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---- | 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)-          -> Logger-          -> Debouncer NormalizedUri-          -> Maybe FilePath-          -> IdeReportProgress-          -> IdeTesting-          -> HieDb-          -> IndexQueue-          -> VFSHandle-          -> ShakeOptions-          -> Rules ()-          -> IO IdeState-shakeOpen lspEnv 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 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
src/Development/IDE/Core/Tracing.hs view
@@ -1,217 +1,217 @@-{-# 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         (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
src/Development/IDE/GHC/CPP.hs view
@@ -1,228 +1,228 @@--- 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, 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
src/Development/IDE/GHC/Compat.hs view
@@ -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
src/Development/IDE/GHC/Error.hs view
@@ -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 "<Internal>") (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                     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 "<Internal>") (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."
src/Development/IDE/GHC/ExactPrint.hs view
@@ -1,450 +1,448 @@-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GADTs              #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE RankNTypes         #-}-{-# LANGUAGE TypeFamilies       #-}--{- HLINT ignore "Use zipFrom" -}--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 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
src/Development/IDE/GHC/Orphans.hs view
@@ -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 "<moddetails>"-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 _ = "<Annotated ParsedSource>"--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           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 "<moddetails>"
+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 _ = "<Annotated ParsedSource>"
+
+instance NFData (Annotated ParsedSource) where
+  rnf = rwhnf
src/Development/IDE/GHC/Util.hs view
@@ -1,263 +1,263 @@-{-# 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 = "<interactive>"-      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,
+    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 = "<interactive>"
+      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)
src/Development/IDE/GHC/Warnings.hs view
@@ -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.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
src/Development/IDE/Import/DependencyInformation.hs view
@@ -1,377 +1,377 @@--- 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.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
src/Development/IDE/Import/FindImports.hs view
@@ -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.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 = []
+  }
src/Development/IDE/LSP/HoverDefinition.hs view
@@ -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 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)
src/Development/IDE/LSP/LanguageServer.hs view
@@ -1,210 +1,210 @@-      -- 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           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
+
src/Development/IDE/LSP/Notifications.hs view
@@ -1,144 +1,144 @@--- 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 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"
+  ]
src/Development/IDE/LSP/Outline.hs view
@@ -1,225 +1,225 @@-{-# 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 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
src/Development/IDE/LSP/Server.hs view
@@ -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 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)
+
+
src/Development/IDE/Main.hs view
@@ -1,224 +1,225 @@-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 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-                    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 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 (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
src/Development/IDE/Plugin.hs view
@@ -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
src/Development/IDE/Plugin/CodeAction.hs view
@@ -1,1467 +1,1444 @@--- 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-    ++ suggestDisableWarning pm text 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--suggestDisableWarning :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestDisableWarning pm contents Diagnostic{..}-    | Just (InR (T.stripPrefix "-W" -> Just w)) <- _code =-        pure-            ( "Disable \"" <> w <> "\" warnings"-            , [TextEdit (endOfModuleHeader pm contents) $ "{-# OPTIONS_GHC -Wno-" <> w <> " #-}\n"]-            )-    | otherwise = []--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 "<dummy>" _range) $ \df ->-                    liftParseAST @(HsExpr GhcPs) df $-                    prettyPrint $-                        HsVar @GhcPs noExtField $-                            L (UnhelpfulSpan "") rdr-                else Rewrite (rangeToSrcSpan "<dummy>" _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 <> ")"---- | Find the first non-blank line before the first of (module name / imports / declarations).--- Useful for inserting pragmas.-endOfModuleHeader :: ParsedModule -> Maybe T.Text -> Range-endOfModuleHeader pm contents =-    let mod = unLoc $ pm_parsed_source pm-        modNameLoc = getLoc <$> hsmodName mod-        firstImportLoc = getLoc <$> listToMaybe (hsmodImports mod)-        firstDeclLoc = getLoc <$> listToMaybe (hsmodDecls mod)-        line = fromMaybe 0 $ firstNonBlankBefore . _line . _start =<< srcSpanToRange =<<-            modNameLoc <|> firstImportLoc <|> firstDeclLoc-        firstNonBlankBefore n = (n -) . fromMaybe 0 . findIndex (not . T.null) . reverse . take n . T.lines <$> contents-        loc = Position line 0-     in Range loc loc+-- 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 "<dummy>" _range) $ \df ->
+                    liftParseAST @(HsExpr GhcPs) df $
+                    prettyPrint $
+                        HsVar @GhcPs noExtField $
+                            L (UnhelpfulSpan "") rdr
+                else Rewrite (rangeToSrcSpan "<dummy>" _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 <> ")"
+
src/Development/IDE/Plugin/CodeAction/ExactPrint.hs view
@@ -1,435 +1,435 @@-{-# 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,
+  )
+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
src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs view
@@ -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
src/Development/IDE/Plugin/Completions.hs view
@@ -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.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 Language.LSP.Types-import qualified Language.LSP.Server as LSP-import qualified Language.LSP.VFS as VFS-import Development.Shake.Classes-import Development.Shake-import GHC.Generics-import Development.IDE.Core.Service-import Development.IDE.Core.PositionMapping-import Development.IDE.Plugin.Completions.Logic-import Development.IDE.Types.Location-import Development.IDE.Core.RuleTypes-import Development.IDE.Core.Shake-import Development.IDE.GHC.Compat-import Development.IDE.GHC.ExactPrint (Annotated (annsA), GetAnnotatedParsedSource (GetAnnotatedParsedSource))-import Development.IDE.Types.HscEnvEq (hscEnv)-import Development.IDE.Plugin.CodeAction.ExactPrint-import Development.IDE.Plugin.Completions.Types-import Ide.Plugin.Config (Config (completionSnippetsOn))-import Ide.PluginUtils (getClientConfig)-import Ide.Types-import TcRnDriver (tcRnImportDecls)-import Control.Concurrent.Async (concurrently)-import GHC.Exts (toList)-import Development.IDE.GHC.Error (rangeToSrcSpan)-import Development.IDE.GHC.Util (prettyPrint)--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-                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 (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
src/Development/IDE/Plugin/Completions/Logic.hs view
@@ -1,758 +1,758 @@-{-# 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 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
src/Development/IDE/Plugin/Completions/Types.hs view
@@ -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 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')
src/Development/IDE/Plugin/HLS.hs view
@@ -1,185 +1,186 @@-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE GADTs #-}--module Development.IDE.Plugin.HLS-    (-      asGhcIdePlugin-    ) where--import           Control.Exception(SomeException)-import           Control.Monad-import qualified Data.Aeson as J-import           Data.Either-import qualified Data.List                     as List-import qualified Data.Map  as Map-import qualified Data.Text                     as T-import           Development.IDE.Core.Shake-import           Development.IDE.LSP.Server-import           Development.IDE.Plugin-import           Ide.Plugin.Config-import           Ide.Types as HLS-import qualified Language.LSP.Server             as LSP-import qualified Language.LSP.Types              as J-import Language.LSP.Types-import           Text.Regex.TDFA.Text()-import Development.Shake (Rules)-import Ide.PluginUtils (getClientConfig)-import Development.IDE.Core.Tracing-import UnliftIO.Async (forConcurrently)-import UnliftIO.Exception (catchAny)-import           Data.Dependent.Map (DMap)-import qualified Data.Dependent.Map as DMap-import           Data.Dependent.Sum-import Data.List.NonEmpty (nonEmpty,NonEmpty,toList)-import UnliftIO (MonadUnliftIO)-import Data.String-import Data.Bifunctor---- ---------------------------------------------------------------------------- | Map a set of plugins to the underlying ghcide engine.-asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config-asGhcIdePlugin mp =-    mkPlugin rulesPlugins          HLS.pluginRules <>-    mkPlugin executeCommandPlugins HLS.pluginCommands <>-    mkPlugin extensiblePlugins     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 :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config-extensiblePlugins 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 <- 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
src/Development/IDE/Plugin/HLS/GhcIde.hs view
@@ -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
+
+-- ---------------------------------------------------------------------
src/Development/IDE/Plugin/Test.hs view
@@ -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 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)
src/Development/IDE/Plugin/TypeLenses.hs view
@@ -1,117 +1,117 @@--- | 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+-- | 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
src/Development/IDE/Spans/AtPoint.hs view
@@ -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 <- maybe [] id (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 <no location info>" 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 (maybe [] id) . 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 (maybe [] id) . 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 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 <no location info>" 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
src/Development/IDE/Spans/Common.hs view
@@ -1,192 +1,192 @@-{-# 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 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
src/Development/IDE/Spans/Documentation.hs view
@@ -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 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
src/Development/IDE/Spans/LocalBindings.hs view
@@ -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 _ = "<bindings>"------------------------------------------------------------------------------------ | 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 _ = "<bindings>"
+
+
+------------------------------------------------------------------------------
+-- | 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
+
src/Development/IDE/Types/Action.hs view
@@ -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.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
src/Development/IDE/Types/Diagnostics.hs view
@@ -1,151 +1,151 @@--- 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 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
src/Development/IDE/Types/Exports.hs view
@@ -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.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])
src/Development/IDE/Types/HscEnvEq.hs view
@@ -1,159 +1,159 @@-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 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)
+
src/Development/IDE/Types/KnownTargets.hs view
@@ -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 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
src/Development/IDE/Types/Location.hs view
@@ -1,112 +1,112 @@--- 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 = "<unknown>"---- 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 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 = "<unknown>"
+
+-- 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
src/Development/IDE/Types/Logger.hs view
@@ -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 ()
src/Development/IDE/Types/Options.hs view
@@ -1,175 +1,175 @@--- 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
+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"
+  ]
src/Development/IDE/Types/Shake.hs view
@@ -1,133 +1,133 @@-{-# 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 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
test/cabal/Development/IDE/Test/Runfiles.hs view
@@ -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"
test/data/hover/Bar.hs view
@@ -1,4 +1,4 @@-module Bar (Bar(..)) where---- | Bar Haddock-data Bar = Bar+module Bar (Bar(..)) where
+
+-- | Bar Haddock
+data Bar = Bar
test/data/hover/Foo.hs view
@@ -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
test/data/hover/GotoHover.hs view
@@ -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 = _
test/data/multi/a/A.hs view
@@ -1,3 +1,3 @@-module A(foo) where--foo = ()+module A(foo) where
+
+foo = ()
test/data/multi/a/a.cabal view
@@ -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: .
test/data/multi/b/B.hs view
@@ -1,3 +1,3 @@-module B(module B) where-import A-qux = foo+module B(module B) where
+import A
+qux = foo
test/data/multi/b/b.cabal view
@@ -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: .
test/data/multi/cabal.project view
@@ -1,1 +1,1 @@-packages: a b+packages: a b
test/data/multi/hie.yaml view
@@ -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"
test/exe/Main.hs view
@@ -1,5347 +1,5298 @@--- 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.Functor-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-  , disableWarningTests-  , 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-      action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove import")-        =<< getCodeActions docB (Range (Position 2 0) (Position 2 5))-      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-      action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove import")-        =<< getCodeActions docB (Range (Position 2 0) (Position 2 5))-      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-      action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove stuffA, stuffC from import")-        =<< getCodeActions docB (Range (Position 2 0) (Position 2 5))-      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-      action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove !!, <?> from import")-        =<< getCodeActions docB (Range (Position 2 0) (Position 2 5))-      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-      action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove A from import")-        =<< getCodeActions docB (Range (Position 2 0) (Position 2 5))-      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-      action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove A, E, F from import")-        =<< getCodeActions docB (Range (Position 2 0) (Position 2 5))-      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-      action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove import")-        =<< getCodeActions docB (Range (Position 2 0) (Position 2 5))-      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-      action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove all redundant imports")-        =<< getCodeActions doc (Range (Position 2 0) (Position 2 5))-      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-  ]-  where-    caWithTitle t = \case-      InR  a@CodeAction{_title} -> guard (_title == t) >> Just a-      _ -> Nothing--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"-    ]--disableWarningTests :: TestTree-disableWarningTests =-  testGroup "disable warnings" $-    [-      ( "missing-signatures"-      , T.unlines-          [ "{-# OPTIONS_GHC -Wall #-}"-          , "main = putStrLn \"hello\""-          ]-      , T.unlines-          [ "{-# OPTIONS_GHC -Wall #-}"-          , "{-# OPTIONS_GHC -Wno-missing-signatures #-}"-          , "main = putStrLn \"hello\""-          ]-      )-    ,-      ( "unused-imports"-      , T.unlines-          [ "{-# OPTIONS_GHC -Wall #-}"-          , ""-          , ""-          , "module M where"-          , ""-          , "import Data.Functor"-          ]-      , T.unlines-          [ "{-# OPTIONS_GHC -Wall #-}"-          , "{-# OPTIONS_GHC -Wno-unused-imports #-}"-          , ""-          , ""-          , "module M where"-          , ""-          , "import Data.Functor"-          ]-      )-    ]-      <&> \(warning, initialContent, expectedContent) -> testSession (T.unpack warning) $ do-        doc <- createDoc "Module.hs" "haskell" initialContent-        _ <- waitForDiagnostics-        codeActs <- mapMaybe caResultToCodeAct <$> getCodeActions doc (Range (Position 0 0) (Position 0 0))-        case find (\CodeAction{_title} -> _title == "Disable \"" <> warning <> "\" warnings") codeActs of-          Nothing -> liftIO $ assertFailure "No code action with expected title"-          Just action -> do-            executeCodeAction action-            contentAfterAction <- documentContents doc-            liftIO $ expectedContent @=? contentAfterAction- where-  caResultToCodeAct = \case-    InL _ -> Nothing-    InR c -> Just c--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 (other than \"disable warnings\")"-      $ all isDisableWarningAction actionsOrCommands-    where-      isDisableWarningAction = \case-        InR CodeAction{_title} -> "Disable" `T.isPrefixOf` _title && "warnings" `T.isSuffixOf` _title-        _ -> False--  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 <> ":<LINE>:<COL>**[...]", 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-    -- Regression test for https://github.com/haskell/haskell-language-server/issues/891-    , thLinkingTest-    , 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 :: TestTree-thReloadingTest = testCase "reloading-th-test" $ runWithExtraFiles "TH" $ \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--thLinkingTest :: TestTree-thLinkingTest = testCase "th-linking-test" $ runWithExtraFiles "TH" $ \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---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"-              , "Disable \"missing-signatures\" warnings"-              ]-    , 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"-              , "Disable \"missing-signatures\" warnings"-              ]-    ]---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 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 <> ":<LINE>:<COL>**[...]", 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
test/preprocessor/Main.hs view
@@ -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
test/src/Development/IDE/Test.hs view
@@ -1,201 +1,201 @@--- 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 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