packages feed

ghcide 2.5.0.0 → 2.14.0.0

raw patch · 196 files changed

Files

README.md view
@@ -1,45 +1,5 @@ # `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)).@@ -47,294 +7,4 @@  [`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.8, 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.--### 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/).+Set-up and usage instructions can be found on [haskell-language-server documentation](https://haskell-language-server.readthedocs.io/en/latest/components/ghcide.html)
exe/Arguments.hs view
@@ -20,7 +20,6 @@     ,argsVerbose                    :: Bool     ,argsCommand                    :: Command     ,argsConservativeChangeTracking :: Bool-    ,argsMonitoringPort             :: Int     }  getArguments :: IdePlugins IdeState -> IO Arguments@@ -43,7 +42,6 @@       <*> switch (short 'd' <> long "verbose" <> help "Include internal events in logging output")       <*> (commandP plugins <|> lspCommand <|> checkCommand)       <*> switch (long "conservative-change-tracking" <> help "disable reactive change tracking (for testing/debugging)")-      <*> option auto (long "monitoring-port" <> metavar "PORT" <> value 8999 <> showDefault <> help "Port to use for EKG monitoring (if the binary is built with EKG)")       where           checkCommand = Check <$> many (argument str (metavar "FILES/DIRS..."))           lspCommand = LSP <$ flag' True (long "lsp" <> help "Start talking to an LSP client")
exe/Main.hs view
@@ -1,31 +1,24 @@ -- 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 (..),                                                            getArguments)-import           Control.Monad.Extra                      (unless) import           Control.Monad.IO.Class                   (liftIO) import           Data.Default                             (def) import           Data.Function                            ((&)) import           Data.Version                             (showVersion) import           Development.GitRev                       (gitHash)-import           Development.IDE                          (action)-import           Development.IDE.Core.OfInterest          (kick) import           Development.IDE.Core.Rules               (mainRule) import qualified Development.IDE.Core.Rules               as Rules-import           Development.IDE.Core.Tracing             (withTelemetryLogger)+import           Development.IDE.Core.Tracing             (withTelemetryRecorder) import qualified Development.IDE.Main                     as IDEMain-import qualified Development.IDE.Monitoring.EKG           as EKG import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry import qualified Development.IDE.Plugin.HLS.GhcIde        as GhcIde import           Development.IDE.Types.Options-import           GHC.Stack                                (emptyCallStack)-import           Ide.Logger                               (Logger (Logger),-                                                           LoggingColumn (DataColumn, PriorityColumn),+import           Ide.Logger                               (LoggingColumn (..),                                                            Pretty (pretty),                                                            Priority (Debug, Error, Info),                                                            WithPriority (WithPriority, priority),@@ -73,11 +66,11 @@              <> gitHashSection  main :: IO ()-main = withTelemetryLogger $ \telemetryLogger -> do+main = withTelemetryRecorder $ \telemetryRecorder -> do     -- stderr recorder just for plugin cli commands     pluginCliRecorder <-       cmapWithPrio pretty-      <$> makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn])+      <$> makeDefaultStderrRecorder (Just [ThreadIdColumn, PriorityColumn, DataColumn])      let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde pluginCliRecorder))     -- WARNING: If you write to stdout before runLanguageServer@@ -100,7 +93,7 @@     (lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder     -- This plugin just installs a handler for the `initialized` notification, which then     -- picks up the LSP environment and feeds it to our recorders-    let lspRecorderPlugin = (defaultPluginDescriptor "LSPRecorderCallback")+    let lspRecorderPlugin = (defaultPluginDescriptor "LSPRecorderCallback" "Internal plugin")           { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SMethod_Initialized $ \_ _ _ _ -> do               env <- LSP.getLspEnv               liftIO $ (cb1 <> cb2) env@@ -111,32 +104,24 @@           (lspLogRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions)                           & cfilter (\WithPriority{ priority } -> priority >= minPriority)) <>           (lspMessageRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions)-                              & cfilter (\WithPriority{ priority } -> priority >= Error))--    -- exists so old-style logging works. intended to be phased out-    let logger = Logger $ \p m -> Logger.logger_ docWithFilteredPriorityRecorder (WithPriority p emptyCallStack (pretty m))+                              & cfilter (\WithPriority{ priority } -> priority >= Error)) <>+          telemetryRecorder      let recorder = docWithFilteredPriorityRecorder                  & cmapWithPrio pretty      let arguments =           if argsTesting-          then IDEMain.testing (cmapWithPrio LogIDEMain recorder) logger hlsPlugins-          else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) logger hlsPlugins+          then IDEMain.testing (cmapWithPrio LogIDEMain recorder) argsCwd hlsPlugins+          else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) argsCwd hlsPlugins      IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments-        { IDEMain.argsProjectRoot = Just argsCwd+        { IDEMain.argsProjectRoot = argsCwd         , IDEMain.argCommand = argsCommand-        , IDEMain.argsLogger = IDEMain.argsLogger arguments <> pure telemetryLogger         , IDEMain.argsHlsPlugins = IDEMain.argsHlsPlugins arguments <> pluginDescToIdePlugins [lspRecorderPlugin]          , IDEMain.argsRules = do-            -- install the main and ghcide-plugin rules             mainRule (cmapWithPrio LogRules recorder) def-            -- install the kick action, which triggers a typecheck on every-            -- Shake database restart, i.e. on every user edit.-            unless argsDisableKick $-                action kick          , IDEMain.argsThreads = case argsThreads of 0 -> Nothing ; i -> Just (fromIntegral i) @@ -149,5 +134,5 @@                 , optRunSubset = not argsConservativeChangeTracking                 , optVerifyCoreFile = argsVerifyCoreFile                 }-        , IDEMain.argsMonitoring = OpenTelemetry.monitoring <> EKG.monitoring logger argsMonitoringPort+        , IDEMain.argsMonitoring = OpenTelemetry.monitoring         }
ghcide.cabal view
@@ -1,8 +1,8 @@-cabal-version:      3.0+cabal-version:      3.4 build-type:         Simple category:           Development name:               ghcide-version:            2.5.0.0+version:            2.14.0.0 license:            Apache-2.0 license-file:       LICENSE author:             Digital Asset and Ghcide contributors@@ -14,39 +14,38 @@   https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme  bug-reports:        https://github.com/haskell/haskell-language-server/issues-tested-with:        GHC ==9.0.2 || ==9.2.5+tested-with:        GHC == {9.14.1, 9.12.2, 9.10.3, 9.8.4, 9.6.7} extra-source-files:   CHANGELOG.md   README.md-  test/data/**/*.cabal-  test/data/**/*.hs-  test/data/**/*.hs-boot-  test/data/**/*.project-  test/data/**/*.yaml  source-repository head   type:     git   location: https://github.com/haskell/haskell-language-server.git -flag ekg-  description:-    Enable EKG monitoring of the build graph and other metrics on port 8999--  default:     False-  manual:      True- flag pedantic   description: Enable -Werror   default:     False   manual:      True +common warnings+  ghc-options:+    -Werror=incomplete-patterns+    -Wall+    -Wincomplete-uni-patterns+    -Wunused-packages+    -Wno-name-shadowing+    -Wno-unticked-promoted-constructors+    -fno-ignore-asserts+ library-  default-language:   Haskell2010+  import: warnings+  default-language:   GHC2021   build-depends:     , aeson     , array     , async-    , base                         >=4        && <5+    , base                         >=4.16     && <5     , base16-bytestring            >=0.1.1    && <1.1     , binary     , bytestring@@ -58,44 +57,42 @@     , deepseq     , dependent-map     , dependent-sum-    , Diff                         ^>=0.4.0+    , Diff                         ^>=0.5 || ^>=1.0.0     , directory     , dlist+    , edit-distance     , enummapset     , exceptions     , extra                        >=1.7.14     , filepath     , fingertree     , focus                        >=1.0.3.2-    , ghc                          >=9.0+    , ghc                          >=9.2     , ghc-boot     , ghc-boot-th-    , ghc-check                    >=0.5.0.8-    , ghc-paths     , ghc-trace-events     , Glob     , haddock-library              >=1.8      && <1.12     , hashable-    , hie-bios                     ==0.12.1-    , hie-compat                   ^>=0.3.0.0-    , hiedb                        >=0.4.4    && <0.4.5-    , hls-graph                    == 2.5.0.0-    , hls-plugin-api               == 2.5.0.0-    , implicit-hie                 <0.1.3-    , implicit-hie-cradle          ^>=0.3.0.5 || ^>=0.5+    , hie-bios                     ^>= 0.19.0+    , hiedb                        ^>= 0.8.0.0+    , hls-graph                    == 2.14.0.0+    , hls-plugin-api               == 2.14.0.0+    , implicit-hie                 >= 0.1.4.0 && < 0.1.5     , lens+    , lens-aeson     , list-t-    , lsp                          ^>=2.3.0.0-    , lsp-types                    ^>=2.1.0.0+    , lsp                          ^>=2.8+    , lsp-types                    ^>=2.4     , mtl     , opentelemetry                >=0.6.1     , optparse-applicative     , parallel+    , process     , prettyprinter                >=1.7     , prettyprinter-ansi-terminal     , random     , regex-tdfa                   >=1.3.1.0-    , row-types     , safe-exceptions     , sorted-list     , sqlite-simple@@ -108,13 +105,9 @@     , transformers     , unliftio                     >=0.2.6     , unliftio-core-    , unordered-containers         >=0.2.10.0+    , unordered-containers         >=0.2.21     , vector -  -- implicit-hie 0.1.3.0 introduced an unexpected behavioral change.-  -- https://github.com/Avi-D-coder/implicit-hie/issues/50-  -- to make sure ghcide behaves in a desirable way, we put implicit-hie-  -- fake dependency here.   if os(windows)     build-depends: Win32 @@ -122,24 +115,11 @@     build-depends: unix    default-extensions:-    BangPatterns     DataKinds-    DeriveFoldable-    DeriveFunctor-    DeriveGeneric-    DeriveTraversable-    FlexibleContexts-    GeneralizedNewtypeDeriving-    KindSignatures+    ExplicitNamespaces     LambdaCase-    NamedFieldPuns     OverloadedStrings     RecordWildCards-    ScopedTypeVariables-    StandaloneDeriving-    TupleSections-    TypeApplications-    TypeOperators     ViewPatterns    hs-source-dirs:     src session-loader@@ -152,6 +132,7 @@     Development.IDE.Core.FileStore     Development.IDE.Core.FileUtils     Development.IDE.Core.IdeConfiguration+    Development.IDE.Core.LookupMod     Development.IDE.Core.OfInterest     Development.IDE.Core.PluginUtils     Development.IDE.Core.PositionMapping@@ -163,9 +144,13 @@     Development.IDE.Core.Shake     Development.IDE.Core.Tracing     Development.IDE.Core.UseStale+    Development.IDE.Core.WorkerThread     Development.IDE.GHC.Compat     Development.IDE.GHC.Compat.Core+    Development.IDE.GHC.Compat.CmdLine+    Development.IDE.GHC.Compat.Driver     Development.IDE.GHC.Compat.Env+    Development.IDE.GHC.Compat.Error     Development.IDE.GHC.Compat.Iface     Development.IDE.GHC.Compat.Logger     Development.IDE.GHC.Compat.Outputable@@ -186,17 +171,20 @@     Development.IDE.LSP.Server     Development.IDE.Main     Development.IDE.Main.HeapStats-    Development.IDE.Monitoring.EKG     Development.IDE.Monitoring.OpenTelemetry     Development.IDE.Plugin     Development.IDE.Plugin.Completions     Development.IDE.Plugin.Completions.Types+    Development.IDE.Plugin.Completions.Logic     Development.IDE.Plugin.HLS     Development.IDE.Plugin.HLS.GhcIde     Development.IDE.Plugin.Test     Development.IDE.Plugin.TypeLenses     Development.IDE.Session+    Development.IDE.Session.Dependency     Development.IDE.Session.Diagnostics+    Development.IDE.Session.Ghc+    Development.IDE.Session.Implicit     Development.IDE.Spans.AtPoint     Development.IDE.Spans.Common     Development.IDE.Spans.Documentation@@ -212,75 +200,37 @@     Development.IDE.Types.Shake     Generics.SYB.GHC     Text.Fuzzy.Parallel+    Text.Fuzzy.Levenshtein    other-modules:     Development.IDE.Core.FileExists     Development.IDE.GHC.CPP     Development.IDE.GHC.Warnings-    Development.IDE.Plugin.Completions.Logic-    Development.IDE.Session.VersionCheck     Development.IDE.Types.Action--  ghc-options:-    -Wall -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors-    -Wunused-packages -fno-ignore-asserts+    Development.IDE.Session.OrderedSet    if flag(pedantic)-    -- We eventually want to build with Werror fully, but we haven't-    -- finished purging the warnings, so some are set to not be errors-    -- for now     ghc-options:-      -Werror -Wwarn=unused-packages -Wwarn=unrecognised-pragmas-      -Wwarn=dodgy-imports -Wwarn=missing-signatures-      -Wwarn=duplicate-exports -Wwarn=dodgy-exports-      -Wwarn=incomplete-patterns -Wwarn=overlapping-patterns-      -Wwarn=incomplete-record-updates--  -- ambiguous-fields is only understood by GHC >= 9.2, so we only disable it-  -- then. The above comment goes for here too -- this should be understood to-  -- be temporary until we can remove these warnings.-  if (impl(ghc >=9.2) && flag(pedantic))-    ghc-options: -Wwarn=ambiguous-fields--  if flag(ekg)-    build-depends:-      , ekg-core-      , ekg-wai--    cpp-options:   -DMONITORING_EKG--flag test-exe-  description: Build the ghcide-test-preprocessor executable-  default:     True--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 && <5--  if !flag(test-exe)-    buildable: False+      -Werror  flag executable   description: Build the ghcide executable   default:     True  executable ghcide-  default-language:   Haskell2010+  import: warnings+  default-language:   GHC2021   hs-source-dirs:     exe-  ghc-options:-    -threaded -Wall -Wincomplete-uni-patterns -Wno-name-shadowing-    -rtsopts "-with-rtsopts=-I0 -A128M -T"+  ghc-options:        -threaded -rtsopts "-with-rtsopts=-I0 -A128M -T" +   -- allow user RTS overrides   -- disable idle GC   -- increase nursery size   -- Enable collection of heap statistics   main-is:            Main.hs   build-depends:-    , base                  >=4 && <5+    , base                  >=4.16 && <5     , data-default     , extra     , ghcide@@ -296,154 +246,10 @@    autogen-modules:    Paths_ghcide   default-extensions:-    BangPatterns-    DeriveFunctor-    DeriveGeneric-    FlexibleContexts-    GeneralizedNewtypeDeriving     LambdaCase-    NamedFieldPuns     OverloadedStrings     RecordWildCards-    ScopedTypeVariables-    StandaloneDeriving-    TupleSections-    TypeApplications     ViewPatterns    if !flag(executable)     buildable: False--  if flag(ekg)-    build-depends:-      , ekg-core-      , ekg-wai--    cpp-options:   -DMONITORING_EKG--  if impl(ghc >=9)-    ghc-options: -Wunused-packages--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-    , async-    , base-    , containers-    , data-default-    , directory-    , extra-    , filepath-    , fuzzy-    , ghc-    , ghcide-    , hls-plugin-api-    , lens-    , list-t-    , lsp-    , lsp-test                ^>=0.16.0.0-    , lsp-types-    , monoid-subclasses-    , mtl-    , network-uri-    , QuickCheck-    , random-    , regex-tdfa              ^>=1.3.1-    , row-types-    , shake-    , sqlite-simple-    , stm-    , stm-containers-    , tasty-    , tasty-expected-failure-    , tasty-hunit             >=0.10-    , tasty-quickcheck-    , tasty-rerun-    , text-    , text-rope-    , unordered-containers--  ---------------------------------------------------------------  -- The MIN_VERSION_ghc 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_VERSION_ghc. Maybe a-  -- better solution can be found, but this is a quick solution-  -- which works for now.-  ---------------------------------------------------------------  if impl(ghc <9.2)-    build-depends:-      , record-dot-preprocessor-      , record-hasfield--  if impl(ghc <9.3)-    build-depends: ghc-typelits-knownnat--  hs-source-dirs:     test/cabal test/exe test/src-  ghc-options:-    -threaded -Wall -Wno-name-shadowing -O0-    -Wno-unticked-promoted-constructors -Wunused-packages--  main-is:            Main.hs-  other-modules:-    AsyncTests-    BootTests-    ClientSettingsTests-    CodeLensTests-    CompletionTests-    CPPTests-    CradleTests-    DependentFileTest-    Development.IDE.Test-    Development.IDE.Test.Diagnostic-    Development.IDE.Test.Runfiles-    DiagnosticTests-    ExceptionTests-    FindDefinitionAndHoverTests-    FuzzySearch-    GarbageCollectionTests-    HaddockTests-    HieDbRetry-    HighlightTests-    IfaceTests-    InitializeResponseTests-    LogType-    NonLspCommandLine-    OpenCloseTest-    OutlineTests-    PluginParsedResultTests-    PluginSimpleTests-    PositionMappingTests-    PreprocessorTests-    Progress-    ReferenceTests-    RootUriTests-    SafeTests-    SymlinkTests-    TestUtils-    THTests-    UnitTests-    WatchedFileTests--  -- Tests that have been pulled out of the main file-  default-extensions:-    BangPatterns-    DeriveFunctor-    DeriveGeneric-    FlexibleContexts-    GeneralizedNewtypeDeriving-    LambdaCase-    NamedFieldPuns-    OverloadedStrings-    RecordWildCards-    ScopedTypeVariables-    StandaloneDeriving-    TupleSections-    TypeApplications-    ViewPatterns
session-loader/Development/IDE/Session.hs view
@@ -1,1136 +1,1139 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE TypeFamilies              #-}--{-|-The logic for setting up a ghcide session by tapping into hie-bios.--}-module Development.IDE.Session-  (SessionLoadingOptions(..)-  ,CacheDirs(..)-  ,loadSession-  ,loadSessionWithOptions-  ,setInitialDynFlags-  ,getHieDbLoc-  ,runWithDb-  ,retryOnSqliteBusy-  ,retryOnException-  ,Log(..)-  ) where---- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses--- the real GHC library and the types are incompatible. Furthermore, when--- building with ghc-lib we need to make this Haskell agnostic, so no hie-bios!--import           Control.Concurrent.Async-import           Control.Concurrent.Strict-import           Control.Exception.Safe               as Safe-import           Control.Monad-import           Control.Monad.Extra-import           Control.Monad.IO.Class-import qualified Crypto.Hash.SHA1                     as H-import           Data.Aeson                           hiding (Error)-import           Data.Bifunctor-import qualified Data.ByteString.Base16               as B16-import qualified Data.ByteString.Char8                as B-import           Data.Default-import           Data.Either.Extra-import           Data.Function-import           Data.Hashable                        hiding (hash)-import qualified Data.HashMap.Strict                  as HM-import           Data.List-import           Data.List.NonEmpty                   (NonEmpty (..))-import qualified Data.List.NonEmpty                   as NE-import qualified Data.Map.Strict                      as Map-import           Data.Maybe-import           Data.Proxy-import qualified Data.Text                            as T-import           Data.Time.Clock-import           Data.Version-import           Development.IDE.Core.RuleTypes-import           Development.IDE.Core.Shake           hiding (Log, Priority,-                                                       knownTargets, withHieDb)-import qualified Development.IDE.GHC.Compat           as Compat-import           Development.IDE.GHC.Compat.Core      hiding (Target,-                                                       TargetFile, TargetModule,-                                                       Var, Warning, getOptions)-import qualified Development.IDE.GHC.Compat.Core      as GHC-import           Development.IDE.GHC.Compat.Env       hiding (Logger)-import           Development.IDE.GHC.Compat.Units     (UnitId)-import           Development.IDE.GHC.Util-import           Development.IDE.Graph                (Action)-import           Development.IDE.Session.VersionCheck-import           Development.IDE.Types.Diagnostics-import           Development.IDE.Types.Exports-import           Development.IDE.Types.HscEnvEq       (HscEnvEq, newHscEnvEq,-                                                       newHscEnvEqPreserveImportPaths)-import           Development.IDE.Types.Location-import           Development.IDE.Types.Options-import           GHC.Check-import qualified HIE.Bios                             as HieBios-import           HIE.Bios.Environment                 hiding (getCacheDir)-import           HIE.Bios.Types                       hiding (Log)-import qualified HIE.Bios.Types                       as HieBios-import           Hie.Implicit.Cradle                  (loadImplicitHieCradle)-import           Ide.Logger                           (Pretty (pretty),-                                                       Priority (Debug, Error, Info, Warning),-                                                       Recorder, WithPriority,-                                                       cmapWithPrio, logWith,-                                                       nest,-                                                       toCologActionWithPrio,-                                                       vcat, viaShow, (<+>))-import           Language.LSP.Protocol.Message-import           Language.LSP.Server-import           System.Directory-import qualified System.Directory.Extra               as IO-import           System.FilePath-import           System.Info--import           Control.Applicative                  (Alternative ((<|>)))-import           Data.Void--import           Control.Concurrent.STM.Stats         (atomically, modifyTVar',-                                                       readTVar, writeTVar)-import           Control.Concurrent.STM.TQueue-import           Control.DeepSeq-import           Control.Exception                    (evaluate)-import           Control.Monad.IO.Unlift              (MonadUnliftIO)-import           Data.Foldable                        (for_)-import           Data.HashMap.Strict                  (HashMap)-import           Data.HashSet                         (HashSet)-import qualified Data.HashSet                         as Set-import           Database.SQLite.Simple-import           Development.IDE.Core.Tracing         (withTrace)-import           Development.IDE.Session.Diagnostics  (renderCradleError)-import           Development.IDE.Types.Shake          (WithHieDb)-import           HieDb.Create-import           HieDb.Types-import           HieDb.Utils-import qualified System.Random                        as Random-import           System.Random                        (RandomGen)---- See Note [Guidelines For Using CPP In GHCIDE Import Statements]--#if !MIN_VERSION_ghc(9,4,0)-import           Data.IORef-#endif--data Log-  = LogSettingInitialDynFlags-  | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void)-  | LogGetInitialGhcLibDirDefaultCradleNone-  | LogHieDbRetry !Int !Int !Int !SomeException-  | LogHieDbRetriesExhausted !Int !Int !Int !SomeException-  | LogHieDbWriterThreadSQLiteError !SQLError-  | LogHieDbWriterThreadException !SomeException-  | LogInterfaceFilesCacheDir !FilePath-  | LogKnownFilesUpdated !(HashMap Target (HashSet NormalizedFilePath))-  | LogMakingNewHscEnv ![UnitId]-  | LogDLLLoadError !String-  | LogCradlePath !FilePath-  | LogCradleNotFound !FilePath-  | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath))-  | LogCradle !(Cradle Void)-  | LogNoneCradleFound FilePath-  | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)-  | LogHieBios HieBios.Log-deriving instance Show Log--instance Pretty Log where-  pretty = \case-    LogNoneCradleFound path ->-      "None cradle found for" <+> pretty path <+> ", ignoring the file"-    LogSettingInitialDynFlags ->-      "Setting initial dynflags..."-    LogGetInitialGhcLibDirDefaultCradleFail cradleError rootDirPath hieYamlPath cradle ->-      nest 2 $-        vcat-          [ "Couldn't load cradle for ghc libdir."-          , "Cradle error:" <+> viaShow cradleError-          , "Root dir path:" <+> pretty rootDirPath-          , "hie.yaml path:" <+> pretty hieYamlPath-          , "Cradle:" <+> viaShow cradle ]-    LogGetInitialGhcLibDirDefaultCradleNone ->-      "Couldn't load cradle. Cradle not found."-    LogHieDbRetry delay maxDelay retriesRemaining e ->-      nest 2 $-        vcat-          [ "Retrying hiedb action..."-          , "delay:" <+> pretty delay-          , "maximum delay:" <+> pretty maxDelay-          , "retries remaining:" <+> pretty retriesRemaining-          , "SQLite error:" <+> pretty (displayException e) ]-    LogHieDbRetriesExhausted baseDelay maxDelay retriesRemaining e ->-      nest 2 $-        vcat-          [ "Retries exhausted for hiedb action."-          , "base delay:" <+> pretty baseDelay-          , "maximum delay:" <+> pretty maxDelay-          , "retries remaining:" <+> pretty retriesRemaining-          , "Exception:" <+> pretty (displayException e) ]-    LogHieDbWriterThreadSQLiteError e ->-      nest 2 $-        vcat-          [ "HieDb writer thread SQLite error:"-          , pretty (displayException e) ]-    LogHieDbWriterThreadException e ->-      nest 2 $-        vcat-          [ "HieDb writer thread exception:"-          , pretty (displayException e) ]-    LogInterfaceFilesCacheDir path ->-      "Interface files cache directory:" <+> pretty path-    LogKnownFilesUpdated targetToPathsMap ->-      nest 2 $-        vcat-          [ "Known files updated:"-          , viaShow $ (HM.map . Set.map) fromNormalizedFilePath targetToPathsMap-          ]-    LogMakingNewHscEnv inPlaceUnitIds ->-      "Making new HscEnv. In-place unit ids:" <+> pretty (map show inPlaceUnitIds)-    LogDLLLoadError errorString ->-      "Error dynamically loading libm.so.6:" <+> pretty errorString-    LogCradlePath path ->-      "Cradle path:" <+> pretty path-    LogCradleNotFound path ->-      vcat-        [ "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for" <+> pretty path <> "."-        , "Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie)."-        , "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." ]-    LogSessionLoadingResult e ->-      "Session loading result:" <+> viaShow e-    LogCradle cradle ->-      "Cradle:" <+> viaShow cradle-    LogNewComponentCache componentCache ->-      "New component cache HscEnvEq:" <+> viaShow componentCache-    LogHieBios msg -> pretty msg---- | Bump this version number when making changes to the format of the data stored in hiedb-hiedbDataVersion :: String-hiedbDataVersion = "1"--data CacheDirs = CacheDirs-  { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath}--data SessionLoadingOptions = SessionLoadingOptions-  { findCradle             :: FilePath -> IO (Maybe FilePath)-  -- | Load the cradle with an optional 'hie.yaml' location.-  -- If a 'hie.yaml' is given, use it to load the cradle.-  -- Otherwise, use the provided project root directory to determine the cradle type.-  , loadCradle             :: Maybe FilePath -> 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    :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir)-#if !MIN_VERSION_ghc(9,3,0)-  , fakeUid                :: UnitId-    -- ^ unit id used to tag the internal component built by ghcide-    --   To reuse external interface files the unit ids must match,-    --   thus make sure to build them with `--this-unit-id` set to the-    --   same value as the ghcide fake uid-#endif-  }--instance Default SessionLoadingOptions where-    def =  SessionLoadingOptions-        {findCradle = HieBios.findCradle-        ,loadCradle = loadWithImplicitCradle-        ,getCacheDirs = getCacheDirsDefault-        ,getInitialGhcLibDir = getInitialGhcLibDirDefault-#if !MIN_VERSION_ghc(9,3,0)-        ,fakeUid = Compat.toUnitId (Compat.stringToUnit "main")-#endif-        }---- | Find the cradle for a given 'hie.yaml' configuration.------ If a 'hie.yaml' is given, the cradle is read from the config.---  If this config does not comply to the "hie.yaml"--- specification, an error is raised.------ If no location for "hie.yaml" is provided, the implicit config is used--- using the provided root directory for discovering the project.--- The implicit config uses different heuristics to determine the type--- of the project that may or may not be accurate.-loadWithImplicitCradle :: Maybe FilePath-                          -- ^ Optional 'hie.yaml' location. Will be used if given.-                          -> FilePath-                          -- ^ Root directory of the project. Required as a fallback-                          -- if no 'hie.yaml' location is given.-                          -> IO (HieBios.Cradle Void)-loadWithImplicitCradle mHieYaml rootDir = do-  case mHieYaml of-    Just yaml -> HieBios.loadCradle yaml-    Nothing   -> loadImplicitHieCradle $ addTrailingPathSeparator rootDir--getInitialGhcLibDirDefault :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir)-getInitialGhcLibDirDefault recorder rootDir = do-  hieYaml <- findCradle def (rootDir </> "a")-  cradle <- loadCradle def hieYaml rootDir-  libDirRes <- getRuntimeGhcLibDir (toCologActionWithPrio (cmapWithPrio LogHieBios recorder)) cradle-  case libDirRes of-      CradleSuccess libdir -> pure $ Just $ LibDir libdir-      CradleFail err -> do-        logWith recorder Error $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle-        pure Nothing-      CradleNone -> do-        logWith recorder Warning LogGetInitialGhcLibDirDefaultCradleNone-        pure Nothing---- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir-setInitialDynFlags :: Recorder (WithPriority Log) -> FilePath -> SessionLoadingOptions -> IO (Maybe LibDir)-setInitialDynFlags recorder rootDir SessionLoadingOptions{..} = do-  libdir <- getInitialGhcLibDir recorder rootDir-  dynFlags <- mapM dynFlagsForPrinting libdir-  logWith recorder Debug LogSettingInitialDynFlags-  mapM_ setUnsafeGlobalDynFlags dynFlags-  pure libdir---- | If the action throws exception that satisfies predicate then we sleep for--- a duration determined by the random exponential backoff formula,--- `uniformRandom(0, min (maxDelay, (baseDelay * 2) ^ retryAttempt))`, and try--- the action again for a maximum of `maxRetryCount` times.--- `MonadIO`, `MonadCatch` are used as constraints because there are a few--- HieDb functions that don't return IO values.-retryOnException-  :: (MonadIO m, MonadCatch m, RandomGen g, Exception e)-  => (e -> Maybe e) -- ^ only retry on exception if this predicate returns Just-  -> Recorder (WithPriority Log)-  -> Int -- ^ maximum backoff delay in microseconds-  -> Int -- ^ base backoff delay in microseconds-  -> Int -- ^ maximum number of times to retry-  -> g -- ^ random number generator-  -> m a -- ^ action that may throw exception-  -> m a-retryOnException exceptionPred recorder maxDelay !baseDelay !maxTimesRetry rng action = do-  result <- tryJust exceptionPred action-  case result of-    Left e-      | maxTimesRetry > 0 -> do-        -- multiply by 2 because baseDelay is midpoint of uniform range-        let newBaseDelay = min maxDelay (baseDelay * 2)-        let (delay, newRng) = Random.randomR (0, newBaseDelay) rng-        let newMaxTimesRetry = maxTimesRetry - 1-        liftIO $ do-          logWith recorder Warning $ LogHieDbRetry delay maxDelay newMaxTimesRetry (toException e)-          threadDelay delay-        retryOnException exceptionPred recorder maxDelay newBaseDelay newMaxTimesRetry newRng action--      | otherwise -> do-        liftIO $ do-          logWith recorder Warning $ LogHieDbRetriesExhausted baseDelay maxDelay maxTimesRetry (toException e)-          throwIO e--    Right b -> pure b---- | in microseconds-oneSecond :: Int-oneSecond = 1000000---- | in microseconds-oneMillisecond :: Int-oneMillisecond = 1000---- | default maximum number of times to retry hiedb call-maxRetryCount :: Int-maxRetryCount = 10--retryOnSqliteBusy :: (MonadIO m, MonadCatch m, RandomGen g)-                  => Recorder (WithPriority Log) -> g -> m a -> m a-retryOnSqliteBusy recorder rng action =-  let isErrorBusy e-        | SQLError{ sqlError = ErrorBusy } <- e = Just e-        | otherwise = Nothing-  in-    retryOnException isErrorBusy recorder oneSecond oneMillisecond maxRetryCount rng action--makeWithHieDbRetryable :: RandomGen g => Recorder (WithPriority Log) -> g -> HieDb -> WithHieDb-makeWithHieDbRetryable recorder rng hieDb f =-  retryOnSqliteBusy recorder rng (f hieDb)---- | 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 :: Recorder (WithPriority Log) -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO ()-runWithDb recorder fp k = do-  -- use non-deterministic seed because maybe multiple HLS start at same time-  -- and send bursts of requests-  rng <- Random.newStdGen-  -- Delete the database if it has an incompatible schema version-  retryOnSqliteBusy-    recorder-    rng-    (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp)--  withHieDb fp $ \writedb -> do-    -- the type signature is necessary to avoid concretizing the tyvar-    -- e.g. `withWriteDbRetryable initConn` without type signature will-    -- instantiate tyvar `a` to `()`-    let withWriteDbRetryable :: WithHieDb-        withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb-    withWriteDbRetryable initConn--    chan <- newTQueueIO--    withAsync (writerThread withWriteDbRetryable chan) $ \_ -> do-      withHieDb fp (\readDb -> k (makeWithHieDbRetryable recorder rng readDb) chan)-  where-    writerThread :: WithHieDb -> IndexQueue -> IO ()-    writerThread withHieDbRetryable chan = do-      -- Clear the index of any files that might have been deleted since the last run-      _ <- withHieDbRetryable deleteMissingRealFiles-      _ <- withHieDbRetryable garbageCollectTypeNames-      forever $ do-        l <- atomically $ readTQueue chan-        -- TODO: probably should let exceptions be caught/logged/handled by top level handler-        l withHieDbRetryable-          `Safe.catch` \e@SQLError{} -> do-            logWith recorder Error $ LogHieDbWriterThreadSQLiteError e-          `Safe.catchAny` \f -> do-            logWith recorder Error $ LogHieDbWriterThreadException f---getHieDbLoc :: FilePath -> IO FilePath-getHieDbLoc dir = do-  let db = intercalate "-" [dirHash, takeBaseName dir, Compat.ghcVersionStr, hiedbDataVersion] <.> "hiedb"-      dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir-  cDir <- IO.getXdgDirectory IO.XdgCache cacheDir-  createDirectoryIfMissing True cDir-  pure (cDir </> db)---- | Given a root directory, return a Shake 'Action' which setups an--- 'IdeGhcSession' given a file.--- Some of the many things this does:------ * Find the cradle for the file--- * Get the session options,--- * Get the GHC lib directory--- * Make sure the GHC compiletime and runtime versions match--- * Restart the Shake session------ This is the key function which implements multi-component support. All--- components mapping to the same hie.yaml file are mapped to the same--- HscEnv which is updated as new components are discovered.-loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Action IdeGhcSession)-loadSession recorder = loadSessionWithOptions recorder def--loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession)-loadSessionWithOptions recorder 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)-  -- 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{restartShakeSession, ideNc, knownTargetsVar, lspEnv-                      } <- getShakeExtras-    let invalidateShakeCache :: IO ()-        invalidateShakeCache = do-            void $ modifyVar' version succ-            join $ atomically $ recordDirtyKeys extras GhcSessionIO [emptyFilePath]--    IdeOptions{ optTesting = IdeTesting optTesting-              , optCheckProject = getCheckProject-              , 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)-          hasUpdate <- join $ atomically $ do-            known <- readTVar knownTargetsVar-            let known' = flip mapHashed known $ \k ->-                            HM.unionWith (<>) k $ HM.fromList $ map (second Set.fromList) knownTargets-                hasUpdate = if known /= known' then Just (unhashed known') else Nothing-            writeTVar knownTargetsVar known'-            logDirtyKeys <- recordDirtyKeys extras GetKnownTargets [emptyFilePath]-            return (logDirtyKeys >> pure hasUpdate)-          for_ hasUpdate $ \x ->-            logWith recorder Debug $ LogKnownFilesUpdated x--    -- 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 $ setOptions opts (hsc_dflags hscEnv)-          let df =-#if MIN_VERSION_ghc(9,3,0)-                case unitIdString (homeUnitId_ df') of-                     -- cabal uses main for the unit id of all executable packages-                     -- This makes multi-component sessions confused about what-                     -- options to use for that component.-                     -- Solution: hash the options and use that as part of the unit id-                     -- This works because there won't be any dependencies on the-                     -- executable unit.-                     "main" ->-                       let hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack $ componentOptions opts)-                           hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash))-                       in setHomeUnitId_ hashed_uid df'-                     _ -> df'-#else-                df'-#endif--          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 (homeUnitId_ df) df targets cfp opts dep_info-                                :| maybe [] snd oldDeps-                  -- Get all the unit-ids for things in this component-                  inplace = map rawComponentUnitId $ NE.toList new_deps--              new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do-                  -- Remove all inplace dependencies from package flags for-                  -- components in this HscEnv-#if MIN_VERSION_ghc(9,3,0)-                  let (df2, uids) = (rawComponentDynFlags, [])-#else-                  let (df2, uids) = _removeInplacePackages fakeUid inplace rawComponentDynFlags-#endif-                  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 recorder 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-              logWith recorder Info $ LogMakingNewHscEnv inplace-              hscEnvB <- emptyHscEnv ideNc libDir-              !newHscEnv <--                -- Add the options for the current component to the HscEnv-                evalGhcEnv hscEnvB $ do-                  _ <- setSessionDynFlags-#if !MIN_VERSION_ghc(9,3,0)-                          $ setHomeUnitId_ fakeUid-#endif-                          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, NE.toList new_deps) m, (newHscEnv, NE.head new_deps', NE.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 -> logWith recorder Error $ LogDLLLoadError 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 recorder optExtensions hieYaml _cfp hscEnv uids-          (cs, res) <- new_cache new-          -- Modified cache targets for everything else in the hie.yaml file-          -- which now uses the same EPS and so on-          cached_targets <- concatMapM (fmap fst . new_cache) old_deps--          let all_targets = cs ++ cached_targets--          void $ modifyVar' fileToFlags $-              Map.insert hieYaml (HM.fromList (concatMap toFlagsMap all_targets))-          void $ modifyVar' filesMap $-              flip HM.union (HM.fromList (zip (map fst $ concatMap toFlagsMap all_targets) (repeat hieYaml)))--          void $ extendKnownTargets all_targets--          -- Invalidate all the existing GhcSession build nodes by restarting the Shake session-          invalidateShakeCache--          -- The VFS doesn't change on cradle edits, re-use the old one.-          restartShakeSession VFSUnmodified "new component" []--          -- 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-                    shakeExtras <- getShakeExtras-                    let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces-                    liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>)--          return (second Map.keys res)--    let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])-        consultCradle hieYaml cfp = do-           lfpLog <- flip makeRelative cfp <$> getCurrentDirectory-           logWith recorder Info $ LogCradlePath lfpLog--           when (isNothing hieYaml) $-             logWith recorder Warning $ LogCradleNotFound lfpLog--           cradle <- loadCradle hieYaml dir-           -- TODO: Why are we repeating the same command we have on line 646?-           lfp <- flip makeRelative cfp <$> getCurrentDirectory--           when optTesting $ mRunLspT lspEnv $-            sendNotification (SMethod_CustomMethod (Proxy @"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) $-              withTrace "Load cradle" $ \addTag -> do-                  addTag "file" lfp-                  res <- cradleToOptsAndLibDir recorder cradle cfp-                  addTag "result" (show res)-                  return res--           logWith recorder Debug $ LogSessionLoadingResult 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 (\err' -> renderCradleError err' cradle ncfp) err, Nothing)-               void $ modifyVar' fileToFlags $-                    Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info))-               void $ modifyVar' filesMap $ HM.insert ncfp hieYaml-               return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err)--    -- This caches the mapping from hie.yaml + Mod.hs -> [String]-    -- Returns the Ghc session and the cradle dependencies-    let sessionOpts :: (Maybe FilePath, FilePath)-                    -> IO (IdeResult HscEnvEq, [FilePath])-        sessionOpts (hieYaml, file) = do-          v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags-          cfp <- makeAbsolute 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' <$> makeAbsolute file-            cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap-            hieYaml <- cradleLoc file-            sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.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-        asyncRes <- async $ getOptions file-        return (asyncRes, wait asyncRes)-      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 :: Recorder (WithPriority Log) -> Cradle Void -> FilePath-                      -> IO (Either [CradleError] (ComponentOptions, FilePath))-cradleToOptsAndLibDir recorder cradle file = do-    -- let noneCradleFoundMessage :: FilePath -> T.Text-    --     noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file"-    -- Start off by getting the session options-    logWith recorder Debug $ LogCradle cradle-    let logger = toCologActionWithPrio $ cmapWithPrio LogHieBios recorder-    cradleRes <- HieBios.getCompilerOptions logger file cradle-    case cradleRes of-        CradleSuccess r -> do-            -- Now get the GHC lib dir-            libDirRes <- getRuntimeGhcLibDir logger cradle-            case libDirRes of-                -- This is the successful path-                CradleSuccess libDir -> pure (Right (r, libDir))-                CradleFail err       -> return (Left [err])-                CradleNone           -> do-                    logWith recorder Info $ LogNoneCradleFound file-                    return (Left [])--        CradleFail err -> return (Left [err])-        CradleNone -> do-            logWith recorder Info $ LogNoneCradleFound file-            return (Left [])--#if MIN_VERSION_ghc(9,3,0)-emptyHscEnv :: NameCache -> FilePath -> IO HscEnv-#else-emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv-#endif-emptyHscEnv nc libDir = do-    env <- runGhc (Just libDir) getSession-    pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env)--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 modName) env dep = do-    let fps = [i </> moduleNameSlashes modName -<.> ext <> boot-              | ext <- exts-              , i <- is-              , boot <- ["", "-boot"]-              ]-    locs <- mapM (fmap toNormalizedFilePath' . makeAbsolute) fps-    return [TargetDetails (TargetModule modName) env dep locs]--- For a 'TargetFile' we consider all the possible module names-fromTargetId _ _ (GHC.TargetFile f _) env deps = do-    nf <- toNormalizedFilePath' <$> makeAbsolute f-    return [TargetDetails (TargetFile nf) env deps [nf]]--toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))]-toFlagsMap TargetDetails{..} =-    [ (l, (targetEnv, targetDepends)) | l <-  targetLocations]---#if MIN_VERSION_ghc(9,3,0)-setNameCache :: NameCache -> HscEnv -> HscEnv-#else-setNameCache :: IORef NameCache -> HscEnv -> HscEnv-#endif-setNameCache nc hsc = hsc { hsc_NC = nc }---- | Create a mapping from FilePaths to HscEnvEqs-newComponentCache-         :: Recorder (WithPriority Log)-         -> [String]       -- File extensions to consider-         -> Maybe FilePath -- Path to cradle-         -> NormalizedFilePath -- Path to file that caused the creation of this component-         -> HscEnv-         -> [(UnitId, DynFlags)]-         -> ComponentInfo-         -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo))-newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do-    let df = componentDynFlags ci-    hscEnv' <--#if MIN_VERSION_ghc(9,3,0)-      -- Set up a multi component session with the other units on GHC 9.4-        Compat.initUnits (map snd uids) (hscSetFlags df hsc_env)-#else-      -- This initializes the units for GHC 9.2-      -- Add the options for the current component to the HscEnv-      -- We want to call `setSessionDynFlags` instead of `hscSetFlags`-      -- because `setSessionDynFlags` also initializes the package database,-      -- which we need for any changes to the package flags in the dynflags-      -- to be visible.-      -- See #2693-      evalGhcEnv hsc_env $ do-        _ <- setSessionDynFlags $ df-        getSession-#endif--    let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath-    henv <- newFunc hscEnv' uids-    let targetEnv = ([], Just henv)-        targetDepends = componentDependencyInfo ci-        res = (targetEnv, targetDepends)-    logWith recorder Debug $ LogNewComponentCache res-    evaluate $ liftRnf rwhnf $ componentTargets ci--    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 :: MonadUnliftIO m => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags-setCacheDirs recorder CacheDirs{..} dflags = do-    logWith recorder Info $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir)-    pure $ dflags-          & maybe id setHiDir hiCacheDir-          & maybe id setHieDir hieCacheDir-          & maybe id setODir oCacheDir---- 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         :: UnitId-  -- | 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         :: UnitId-  -- | 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 :: [UnitId]-  -- | 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-    safeTryIO :: IO a -> IO (Either IOException a)-    safeTryIO = Safe.try--    do_one :: FilePath -> IO (FilePath, Maybe UTCTime)-    do_one fp = (fp,) . eitherToMaybe <$> safeTryIO (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 --Only used in ghc < 9.4-    :: UnitId     -- ^ fake uid to use for our internal component-    -> [UnitId]-    -> DynFlags-    -> (DynFlags, [UnitId])-_removeInplacePackages fake_uid us df = (setHomeUnitId_ fake_uid $-                                       df { packageFlags = ps }, uids)-  where-    (uids, ps) = Compat.filterInplaceUnits us (packageFlags df)---- | 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 $-          setBytecodeLinkerOptions $-          disableOptimisation $-          Compat.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.-    -- This only works for GHC <9.2-    -- For GHC >= 9.2, we need to modify the unit env in the hsc_dflags, which-    -- is done later in newComponentCache-    final_flags <- liftIO $ wrapPackageSetupException $ Compat.oldInitUnits dflags''-    return (final_flags, targets)--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"--------------------------------------------------------------------------------------------------------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 DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e)+{-# LANGUAGE TypeFamilies #-}++{-|+The logic for setting up a ghcide session by tapping into hie-bios.+-}+module Development.IDE.Session+  (SessionLoadingOptions(..)+  ,CacheDirs(..)+  ,loadSessionWithOptions+  ,getInitialGhcLibDirDefault+  ,getHieDbLoc+  ,retryOnSqliteBusy+  ,retryOnException+  ,SessionLoaderPendingBarrierVar(..)+  ,setSessionLoaderPendingBarrier+  ,clearSessionLoaderPendingBarrier+  ,Log(..)+  ,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.Strict+import           Control.Exception.Safe              as Safe+import           Control.Monad+import           Control.Monad.Extra                 as Extra+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Maybe           (MaybeT (MaybeT, runMaybeT))+import qualified Crypto.Hash.SHA1                    as H+import           Data.Aeson                          hiding (Error, Key)+import qualified Data.ByteString.Base16              as B16+import qualified Data.ByteString.Char8               as B+import           Data.Default+import           Data.Hashable                       hiding (hash)+import qualified Data.HashMap.Strict                 as HM+import           Data.List+import           Data.List.Extra                     as L+import qualified Data.Map.Strict                     as Map+import           Data.Maybe+import           Data.Proxy+import qualified Data.Text                           as T+import           Data.Version+import           Development.IDE.Core.RuleTypes+import           Development.IDE.Core.Shake          hiding (Log, knownTargets,+                                                      withHieDb)+import qualified Development.IDE.GHC.Compat          as Compat+import           Development.IDE.GHC.Compat.Core     hiding (Target, TargetFile,+                                                      TargetModule, Var,+                                                      Warning, getOptions)+import           Development.IDE.GHC.Compat.Env      hiding (Logger)+import           Development.IDE.GHC.Util+import           Development.IDE.Graph               (Action, Key)+import qualified Development.IDE.Session.Implicit    as GhcIde+import           Development.IDE.Types.Diagnostics+import           Development.IDE.Types.Exports+import           Development.IDE.Types.HscEnvEq      (HscEnvEq)+import           Development.IDE.Types.Location+import           Development.IDE.Types.Options+import qualified HIE.Bios                            as HieBios+import           HIE.Bios.Environment                hiding (getCacheDir)+import           HIE.Bios.Types                      hiding (Log)+import qualified HIE.Bios.Types                      as HieBios+import           Ide.Logger                          (Pretty (pretty),+                                                      Priority (Debug, Error, Info, Warning),+                                                      Recorder, WithPriority,+                                                      cmapWithPrio, logWith,+                                                      nest,+                                                      toCologActionWithPrio,+                                                      vcat, viaShow, (<+>))+import           Ide.Types                           (Config,+                                                      SessionLoadingPreferenceConfig (..),+                                                      sessionLoading)+import           Language.LSP.Protocol.Message+import           Language.LSP.Server+import           System.Directory+import qualified System.Directory.Extra              as IO+import           System.FilePath+import           System.Info++import           Control.Applicative                 (Alternative ((<|>)))+import           Data.Void++import           Control.Concurrent.STM.Stats        (atomically, modifyTVar',+                                                      readTVar, writeTVar)+import           Control.Monad.Trans.Cont            (ContT (ContT, runContT))+import           Data.Foldable                       (for_)+import           Data.HashMap.Strict                 (HashMap)+import           Data.HashSet                        (HashSet)+import qualified Data.HashSet                        as Set+import           Database.SQLite.Simple+import           Development.IDE.Core.Tracing        (withTrace)+import           Development.IDE.Core.WorkerThread+import           Development.IDE.Session.Dependency+import           Development.IDE.Session.Diagnostics (renderCradleError)+import           Development.IDE.Session.Ghc         hiding (Log)+import           Development.IDE.Types.Shake         (WithHieDb,+                                                      WithHieDbShield (..),+                                                      toNoFileKey)+import           HieDb.Create+import           HieDb.Types+import           Ide.PluginUtils                     (toAbsolute)+import qualified System.Random                       as Random+import           System.Random                       (RandomGen)+import           Text.ParserCombinators.ReadP        (readP_to_S)++import           Control.Concurrent.STM              (STM, TVar)+import qualified Control.Monad.STM                   as STM+import           Control.Monad.Trans.Reader+import qualified Development.IDE.Session.Ghc         as Ghc+import qualified Development.IDE.Session.OrderedSet  as S+import qualified Focus+import qualified StmContainers.Map                   as STM++data Log+  = LogSettingInitialDynFlags+  | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void)+  | LogGetInitialGhcLibDirDefaultCradleNone+  | LogHieDbRetry !Int !Int !Int !SomeException+  | LogHieDbRetriesExhausted !Int !Int !Int !SomeException+  | LogHieDbWriterThreadSQLiteError !SQLError+  | LogHieDbWriterThreadException !SomeException+  | LogKnownFilesUpdated !(HashMap Target (HashSet NormalizedFilePath))+  | LogCradlePath !FilePath+  | LogCradleNotFound !FilePath+  | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath, String))+  | LogCradle !(Cradle Void)+  | LogNoneCradleFound FilePath+  | LogHieBios HieBios.Log+  | LogSessionLoadingChanged+  | LogSessionWorkerThread LogWorkerThread+  | LogSessionNewLoadedFiles ![FilePath]+  | LogSessionReloadOnError FilePath ![FilePath]+  | LogGetOptionsLoop !FilePath+  | LogLookupSessionCache !FilePath+  | LogTime !String+  | LogSessionGhc Ghc.Log+deriving instance Show Log++instance Pretty Log where+  pretty = \case+    LogSessionWorkerThread msg -> pretty msg+    LogTime s -> "Time:" <+> pretty s+    LogLookupSessionCache path -> "Looking up session cache for" <+> pretty path+    LogGetOptionsLoop fp -> "Loop: getOptions for" <+> pretty fp+    LogSessionReloadOnError path files ->+      "Reloading file due to error in" <+> pretty path <+> "with files:" <+> pretty files+    LogSessionNewLoadedFiles files ->+      "New loaded files:" <+> pretty files+    LogNoneCradleFound path ->+      "None cradle found for" <+> pretty path <+> ", ignoring the file"+    LogSettingInitialDynFlags ->+      "Setting initial dynflags..."+    LogGetInitialGhcLibDirDefaultCradleFail cradleError rootDirPath hieYamlPath cradle ->+      nest 2 $+        vcat+          [ "Couldn't load cradle for ghc libdir."+          , "Cradle error:" <+> viaShow cradleError+          , "Root dir path:" <+> pretty rootDirPath+          , "hie.yaml path:" <+> pretty hieYamlPath+          , "Cradle:" <+> viaShow cradle ]+    LogGetInitialGhcLibDirDefaultCradleNone ->+      "Couldn't load cradle. Cradle not found."+    LogHieDbRetry delay maxDelay retriesRemaining e ->+      nest 2 $+        vcat+          [ "Retrying hiedb action..."+          , "delay:" <+> pretty delay+          , "maximum delay:" <+> pretty maxDelay+          , "retries remaining:" <+> pretty retriesRemaining+          , "SQLite error:" <+> pretty (displayException e) ]+    LogHieDbRetriesExhausted baseDelay maxDelay retriesRemaining e ->+      nest 2 $+        vcat+          [ "Retries exhausted for hiedb action."+          , "base delay:" <+> pretty baseDelay+          , "maximum delay:" <+> pretty maxDelay+          , "retries remaining:" <+> pretty retriesRemaining+          , "Exception:" <+> pretty (displayException e) ]+    LogHieDbWriterThreadSQLiteError e ->+      nest 2 $+        vcat+          [ "HieDb writer thread SQLite error:"+          , pretty (displayException e) ]+    LogHieDbWriterThreadException e ->+      nest 2 $+        vcat+          [ "HieDb writer thread exception:"+          , pretty (displayException e) ]+    LogKnownFilesUpdated targetToPathsMap ->+      nest 2 $+        vcat+          [ "Known files updated:"+          , viaShow $ (HM.map . Set.map) fromNormalizedFilePath targetToPathsMap+          ]+    LogCradlePath path ->+      "Cradle path:" <+> pretty path+    LogCradleNotFound path ->+      vcat+        [ "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for" <+> pretty path <> "."+        , "Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie)."+        , "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." ]+    LogSessionLoadingResult e ->+      "Session loading result:" <+> viaShow e+    LogCradle cradle ->+      "Cradle:" <+> viaShow cradle+    LogHieBios msg -> pretty msg+    LogSessionGhc msg -> pretty msg+    LogSessionLoadingChanged ->+      "Session Loading config changed, reloading the full session."++-- | Bump this version number when making changes to the format of the data stored in hiedb+hiedbDataVersion :: String+hiedbDataVersion = "2"++data SessionLoadingOptions = SessionLoadingOptions+  { findCradle             :: FilePath -> IO (Maybe FilePath)+  -- | Load the cradle with an optional 'hie.yaml' location.+  -- If a 'hie.yaml' is given, use it to load the cradle.+  -- Otherwise, use the provided project root directory to determine the cradle type.+  , loadCradle             :: Recorder (WithPriority Log) -> Maybe FilePath -> 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 -> Maybe B.ByteString -> [String] -> IO CacheDirs+  -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'+  , getInitialGhcLibDir    :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir)+  }++instance Default SessionLoadingOptions where+    def =  SessionLoadingOptions+        {findCradle = HieBios.findCradle+        ,loadCradle = loadWithImplicitCradle+        ,getCacheDirs = getCacheDirsDefault+        ,getInitialGhcLibDir = getInitialGhcLibDirDefault+        }++-- | Find the cradle for a given 'hie.yaml' configuration.+--+-- If a 'hie.yaml' is given, the cradle is read from the config.+--  If this config does not comply to the "hie.yaml"+-- specification, an error is raised.+--+-- If no location for "hie.yaml" is provided, the implicit config is used+-- using the provided root directory for discovering the project.+-- The implicit config uses different heuristics to determine the type+-- of the project that may or may not be accurate.+loadWithImplicitCradle+  :: Recorder (WithPriority Log)+  -> Maybe FilePath+  -- ^ Optional 'hie.yaml' location. Will be used if given.+  -> FilePath+  -- ^ Root directory of the project. Required as a fallback+  -- if no 'hie.yaml' location is given.+  -> IO (HieBios.Cradle Void)+loadWithImplicitCradle recorder mHieYaml rootDir = do+  let logger = toCologActionWithPrio (cmapWithPrio LogHieBios recorder)+  case mHieYaml of+    Just yaml -> HieBios.loadCradle logger yaml+    Nothing   -> GhcIde.loadImplicitCradle logger rootDir++getInitialGhcLibDirDefault :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir)+getInitialGhcLibDirDefault recorder rootDir = do+  hieYaml <- findCradle def (rootDir </> "a")+  cradle <- loadCradle def recorder hieYaml rootDir+  libDirRes <- getRuntimeGhcLibDir cradle+  case libDirRes of+      CradleSuccess libdir -> pure $ Just $ LibDir libdir+      CradleFail err -> do+        logWith recorder Error $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle+        pure Nothing+      CradleNone -> do+        logWith recorder Warning LogGetInitialGhcLibDirDefaultCradleNone+        pure Nothing++-- | If the action throws exception that satisfies predicate then we sleep for+-- a duration determined by the random exponential backoff formula,+-- `uniformRandom(0, min (maxDelay, (baseDelay * 2) ^ retryAttempt))`, and try+-- the action again for a maximum of `maxRetryCount` times.+-- `MonadIO`, `MonadCatch` are used as constraints because there are a few+-- HieDb functions that don't return IO values.+retryOnException+  :: (MonadIO m, MonadCatch m, RandomGen g, Exception e)+  => (e -> Maybe e) -- ^ only retry on exception if this predicate returns Just+  -> Recorder (WithPriority Log)+  -> Int -- ^ maximum backoff delay in microseconds+  -> Int -- ^ base backoff delay in microseconds+  -> Int -- ^ maximum number of times to retry+  -> g -- ^ random number generator+  -> m a -- ^ action that may throw exception+  -> m a+retryOnException exceptionPred recorder maxDelay !baseDelay !maxTimesRetry rng action = do+  result <- tryJust exceptionPred action+  case result of+    Left e+      | maxTimesRetry > 0 -> do+        -- multiply by 2 because baseDelay is midpoint of uniform range+        let newBaseDelay = min maxDelay (baseDelay * 2)+        let (delay, newRng) = Random.randomR (0, newBaseDelay) rng+        let newMaxTimesRetry = maxTimesRetry - 1+        liftIO $ do+          logWith recorder Warning $ LogHieDbRetry delay maxDelay newMaxTimesRetry (toException e)+          threadDelay delay+        retryOnException exceptionPred recorder maxDelay newBaseDelay newMaxTimesRetry newRng action++      | otherwise -> do+        liftIO $ do+          logWith recorder Warning $ LogHieDbRetriesExhausted baseDelay maxDelay maxTimesRetry (toException e)+          throwIO e++    Right b -> pure b++-- | in microseconds+oneSecond :: Int+oneSecond = 1000000++-- | in microseconds+oneMillisecond :: Int+oneMillisecond = 1000++-- | default maximum number of times to retry hiedb call+maxRetryCount :: Int+maxRetryCount = 10++retryOnSqliteBusy :: (MonadIO m, MonadCatch m, RandomGen g)+                  => Recorder (WithPriority Log) -> g -> m a -> m a+retryOnSqliteBusy recorder rng action =+  let isErrorBusy e+        | SQLError{ sqlError = ErrorBusy } <- e = Just e+        | otherwise = Nothing+  in+    retryOnException isErrorBusy recorder oneSecond oneMillisecond maxRetryCount rng action++makeWithHieDbRetryable :: RandomGen g => Recorder (WithPriority Log) -> g -> HieDb -> WithHieDb+makeWithHieDbRetryable recorder rng hieDb f =+  retryOnSqliteBusy recorder rng (f hieDb)++-- | 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+--+-- Also see Note [Serializing runs in separate thread]+runWithDb :: Recorder (WithPriority Log) -> FilePath -> ContT () IO (WithHieDbShield, IndexQueue)+runWithDb recorder fp = ContT $ \k -> do+  -- use non-deterministic seed because maybe multiple HLS start at same time+  -- and send bursts of requests+  rng <- Random.newStdGen+  -- Delete the database if it has an incompatible schema version+  retryOnSqliteBusy+    recorder+    rng+    (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp)++  withHieDb fp $ \writedb -> do+    -- the type signature is necessary to avoid concretizing the tyvar+    -- e.g. `withWriteDbRetryable initConn` without type signature will+    -- instantiate tyvar `a` to `()`+    let withWriteDbRetryable :: WithHieDb+        withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb+    withWriteDbRetryable (setupHieDb . getConn)+++    -- Clear the index of any files that might have been deleted since the last run+    _ <- withWriteDbRetryable deleteMissingRealFiles+    _ <- withWriteDbRetryable garbageCollectTypeNames++    runContT (withWorkerQueue (cmapWithPrio LogSessionWorkerThread recorder) "hiedb thread" (writer withWriteDbRetryable))+        $ \chan -> withHieDb fp (\readDb -> k (WithHieDbShield $ makeWithHieDbRetryable recorder rng readDb, chan))+  where+    writer withHieDbRetryable l = do+        -- TODO: probably should let exceptions be caught/logged/handled by top level handler+        l withHieDbRetryable+          `Safe.catch` \e@SQLError{} -> do+            logWith recorder Error $ LogHieDbWriterThreadSQLiteError e+          `Safe.catchAny` \f -> do+            logWith recorder Error $ LogHieDbWriterThreadException f+++getHieDbLoc :: FilePath -> IO FilePath+getHieDbLoc dir = do+  let db = intercalate "-" [dirHash, takeBaseName dir, Compat.ghcVersionStr, hiedbDataVersion] <.> "hiedb"+      dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir+  cDir <- IO.getXdgDirectory IO.XdgCache cacheDir+  createDirectoryIfMissing True cDir+  pure (cDir </> db)++-- Note [SessionState and batch load]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- SessionState manages the state for batch loading files in the session loader.+--+-- - When a new file needs to be loaded, it is added to the 'pendingFiles' set.+-- - The loader processes files from 'pendingFiles', attempting to load them in batches.+-- - (SBL1) If a file is already in 'failedFiles', it is loaded individually (single-file mode).+-- - (SBL2) Otherwise, the loader tries to load as many files as possible together (batch mode).+--+-- On success:+--   - (SBL3) All successfully loaded files are removed from 'pendingFiles' and 'failedFiles',+--     and added to 'loadedFiles'.+--+-- On failure:+--   - (SBL4) If loading a single file fails, it is added to 'failedFiles' and removed from 'loadedFiles' and 'pendingFiles'.+--   - (SBL5) If batch loading fails, all files attempted are added to 'failedFiles'.+--+-- This approach ensures efficient batch loading while isolating problematic files for individual handling.++-- SBL3+handleBatchLoadSuccess :: Foldable t => Recorder (WithPriority Log) -> SessionState -> Maybe FilePath -> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo) -> t TargetDetails -> IO ()+handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets =  do+  pendings <- getPendingFiles sessionState+  -- this_flags_map might contains files not in pendingFiles, take the intersection+  let newLoaded = pendings `Set.intersection` Set.fromList (fromNormalizedFilePath <$> HM.keys this_flags_map)+  atomically $ do+    STM.insert this_flags_map hieYaml (fileToFlags sessionState)+    insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets+  logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded+  atomically $ forM_ (Set.toList newLoaded) $ flip S.delete (pendingFiles sessionState)+  mapM_ (removeErrorLoadingFile sessionState) (Set.toList newLoaded)+  addCradleFiles sessionState newLoaded++-- SBL5+handleBatchLoadFailure :: SessionState -> [FilePath] -> IO ()+handleBatchLoadFailure sessionState files = do+  mapM_ (addErrorLoadingFile sessionState) files++-- SBL4+handleSingleLoadFailure :: SessionState -> FilePath -> IO ()+handleSingleLoadFailure sessionState file = do+  addErrorLoadingFile sessionState file+  atomically $ S.delete file (pendingFiles sessionState)+  removeCradleFile sessionState file++data SessionState = SessionState+  { loadedFiles  :: !(Var (HashSet FilePath))+  -- ^ Set of files that loaded successfully+  , failedFiles  :: !(Var (HashSet FilePath))+  -- ^ Set of files that we tried to load but failed+  -- for various reasons, such as cradle load errors+  , pendingFiles :: !(S.OrderedSet FilePath)+  -- ^ Files we are currently trying to load into the HLS session.+  , hscEnvs      :: !(Var HieMap)+  -- ^ Map @hie.yaml@ location to all components that have this @hie.yaml@ as+  -- the root location.+  , fileToFlags  :: !FlagsMap+  -- ^ Map @hie.yaml@ to all modules that have this @hie.yaml@ as the root location.+  , filesMap     :: !FilesMap+  -- ^ Maps a 'NormalizedFilePath' to its @hie.yaml@, the reverse of 'fileToFlags'.+  , version      :: !(Var Int)+    -- ^ Session loading version, incremented whenever the shake cache needs to be invalidated.+  , sessionLoadingPreferenceConfig :: !(Var (Maybe SessionLoadingPreferenceConfig))+    -- ^ How do we load files? The user can choose to load multiple components at once+    -- or to load only one component after the other.+    --+    -- Changing this value invalidates the entire shake session.+  }++newtype SessionLoaderPendingBarrierVar = SessionLoaderPendingBarrierVar (TVar (Maybe Int))+instance IsIdeGlobal SessionLoaderPendingBarrierVar++setSessionLoaderPendingBarrier :: IdeState -> Int -> IO ()+setSessionLoaderPendingBarrier ideState n = do+  SessionLoaderPendingBarrierVar barrier <- getIdeGlobalState ideState+  atomically $ writeTVar barrier (Just n)++clearSessionLoaderPendingBarrier :: IdeState -> IO ()+clearSessionLoaderPendingBarrier ideState = do+  SessionLoaderPendingBarrierVar barrier <- getIdeGlobalState ideState+  atomically $ writeTVar barrier Nothing++waitForSessionLoaderPendingBarrier :: TVar (Maybe Int) -> SessionState -> IO ()+waitForSessionLoaderPendingBarrier barrier state =+  -- Block the session-loader queue until we have enqueued enough pending files.+  -- This is used by tests to enforce true batch setup before consuming pending work.+  atomically $ do+    mTarget <- readTVar barrier+    case mTarget of+      Nothing -> pure ()+      Just targetSize -> do+        pending <- S.toHashSet (pendingFiles state)+        if Set.size pending < targetSize+          then STM.retry+          else writeTVar barrier Nothing++-- | Helper functions for SessionState management+-- These functions encapsulate common operations on the SessionState++-- | Add a file to the set of files with errors during loading+addErrorLoadingFile :: MonadIO m =>  SessionState -> FilePath -> m ()+addErrorLoadingFile state file =+  liftIO $ modifyVar_' (failedFiles state) (\xs -> return $ Set.insert file xs)++-- | Remove a file from the set of files with errors during loading+removeErrorLoadingFile :: MonadIO m => SessionState -> FilePath -> m ()+removeErrorLoadingFile state file =+  liftIO $ modifyVar_' (failedFiles state) (\xs -> return $ Set.delete file xs)++addCradleFiles :: MonadIO m => SessionState -> HashSet FilePath -> m ()+addCradleFiles state files =+  liftIO $ modifyVar_' (loadedFiles state) (\xs -> return $ files <> xs)++-- | Remove a file from the cradle files set+removeCradleFile :: MonadIO m =>  SessionState -> FilePath -> m ()+removeCradleFile state file =+  liftIO $ modifyVar_' (loadedFiles state) (\xs -> return $ Set.delete file xs)++-- | Clear error loading files and reset to empty set+clearErrorLoadingFiles :: MonadIO m => SessionState -> m ()+clearErrorLoadingFiles state =+  liftIO $ modifyVar_' (failedFiles state) (const $ return Set.empty)++-- | Clear cradle files and reset to empty set+clearCradleFiles :: MonadIO m => SessionState -> m ()+clearCradleFiles state =+  liftIO $ modifyVar_' (loadedFiles state) (const $ return Set.empty)++-- | Reset the file maps in the session state+resetFileMaps :: SessionState -> STM ()+resetFileMaps state = do+  STM.reset (filesMap state)+  STM.reset (fileToFlags state)++-- | Insert or update file flags for a specific hieYaml and normalized file path+insertFileFlags :: SessionState -> Maybe FilePath -> NormalizedFilePath -> (IdeResult HscEnvEq, DependencyInfo) -> STM ()+insertFileFlags state hieYaml ncfp flags =+  STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp flags)) hieYaml (fileToFlags state)++-- | Insert a file mapping from normalized path to hieYaml location+insertFileMapping :: SessionState -> Maybe FilePath -> NormalizedFilePath -> STM ()+insertFileMapping state hieYaml ncfp =+  STM.insert hieYaml ncfp (filesMap state)++-- | Remove a file from the pending file set+removeFromPending :: SessionState -> FilePath -> STM ()+removeFromPending state file =+  S.delete file (pendingFiles state)++-- | Add a file to the pending file set+addToPending :: SessionState -> FilePath -> STM ()+addToPending state file =+  S.insert file (pendingFiles state)++-- | Insert multiple file mappings at once+insertAllFileMappings :: SessionState -> [(Maybe FilePath, NormalizedFilePath)] -> STM ()+insertAllFileMappings state mappings =+  mapM_ (\(yaml, path) -> insertFileMapping state yaml path) mappings++-- | Increment the version counter+incrementVersion :: SessionState -> IO Int+incrementVersion state = modifyVar' (version state) succ++-- | Get files from the pending file set+getPendingFiles :: SessionState -> IO (HashSet FilePath)+getPendingFiles state = atomically $ S.toHashSet (pendingFiles state)++-- | Handle errors during session loading by recording file as having error and removing from pending+handleSingleFileProcessingError' :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> SessionM ()+handleSingleFileProcessingError' state hieYaml file e = do+  handleSingleFileProcessingError state hieYaml file [renderPackageSetupException file e] mempty++-- | Common pattern: Insert file flags, insert file mapping, and remove from pending+handleSingleFileProcessingError :: SessionState -> Maybe FilePath -> FilePath -> [FileDiagnostic] -> [FilePath] -> SessionM ()+handleSingleFileProcessingError state hieYaml file diags extraDepFiles = liftIO $ do+  dep <- getDependencyInfo $ maybeToList hieYaml <> extraDepFiles+  let ncfp = toNormalizedFilePath' file+  let flags = ((diags, Nothing), dep)+  handleSingleLoadFailure state file+  atomically $ do+    insertFileFlags state hieYaml ncfp flags+    insertFileMapping state hieYaml ncfp++-- | Get the set of extra files to load based on the current file path.+--+-- If the current file is in error loading files, we fallback to single loading mode (empty set)+-- Otherwise, we remove error files from pending files and also exclude the current file+getExtraFilesToLoad :: SessionState -> FilePath -> IO [FilePath]+getExtraFilesToLoad state cfp = do+  pendingFiles <- getPendingFiles state+  errorFiles <- readVar (failedFiles state)+  old_files <- readVar (loadedFiles state)+  -- if the file is in error loading files, we fall back to single loading mode+  return $+    Set.toList $+      if cfp `Set.member` errorFiles+        then Set.empty+        -- remove error files from pending files since error loading need to load one by one+        else (Set.delete cfp $ pendingFiles `Set.difference` errorFiles) <> old_files++-- | We allow users to specify a loading strategy.+-- Check whether this config was changed since the last time we have loaded+-- a session.+--+-- If the loading configuration changed, we likely should restart the session+-- in its entirety.+didSessionLoadingPreferenceConfigChange :: SessionState -> SessionM Bool+didSessionLoadingPreferenceConfigChange s = do+    clientConfig <- asks sessionClientConfig+    let biosSessionLoadingVar = sessionLoadingPreferenceConfig s+    mLoadingConfig <- liftIO $ readVar biosSessionLoadingVar+    case mLoadingConfig of+        Nothing -> do+            liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig))+            pure False+        Just loadingConfig -> do+            liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig))+            pure (loadingConfig /= sessionLoading clientConfig)++newSessionState :: IO SessionState+newSessionState = do+  -- Initialize SessionState+  sessionState <- SessionState+    <$> newVar (Set.fromList [])  -- loadedFiles+    <*> newVar (Set.fromList [])  -- failedFiles+    <*> S.newIO                     -- pendingFiles+    <*> newVar Map.empty            -- hscEnvs+    <*> STM.newIO                   -- fileToFlags+    <*> STM.newIO                   -- filesMap+    <*> newVar 0                    -- version+    <*> newVar Nothing              -- sessionLoadingPreferenceConfig+  return sessionState++-- | 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.++loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TaskQueue (IO ()) -> IO (Action IdeGhcSession)+loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do+  let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory]++  sessionState <- newSessionState+  let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar (version sessionState))++  -- 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+      let res' = toAbsolutePath <$> res+      return $ normalise <$> res'++  return $ do+    clientConfig <- getClientConfigAction+    extras@ShakeExtras{ideNc, knownTargetsVar+                      } <- getShakeExtras+    let invalidateShakeCache = do+            void $ incrementVersion sessionState+            return $ toNoFileKey GhcSessionIO++    ideOptions <- getIdeOptions+    SessionLoaderPendingBarrierVar pendingBarrier <- getIdeGlobalAction++    -- see Note [Serializing runs in separate thread]+    -- Start the 'getOptionsLoop' if the queue is empty+    liftIO $ atomically $+      Extra.whenM (isEmptyTaskQueue que) $ do+        let newSessionLoadingOptions = SessionLoadingOptions+              { findCradle = cradleLoc+              , ..+              }+            sessionShake = SessionShake+              { restartSession = restartShakeSession extras+              , invalidateCache = invalidateShakeCache+              , enqueueActions = shakeEnqueue extras+              }+            sessionEnv = SessionEnv+              { sessionLspContext = lspEnv extras+              , sessionRootDir = rootDir+              , sessionIdeOptions = ideOptions+              , sessionPendingBarrier = pendingBarrier+              , sessionClientConfig = clientConfig+              , sessionSharedNameCache = ideNc+              , sessionLoadingOptions = newSessionLoadingOptions+              }++        writeTaskQueue que (runReaderT (getOptionsLoop recorder sessionShake sessionState knownTargetsVar) sessionEnv)++    -- Each one of deps will be registered as a FileSystemWatcher in the GhcSession action+    -- so that we can get a workspace/didChangeWatchedFiles notification when a dep changes.+    -- The GlobPattern of a FileSystemWatcher can be absolute or relative.+    -- We use the absolute one because it is supported by more LSP clients.+    -- Here we make sure deps are absolute and later we use those absolute deps as GlobPattern.+    let absolutePathsCradleDeps (eq, deps) = (eq, fmap toAbsolutePath $ Map.keys deps)+    returnWithVersion $ \file -> do+      let absFile = toAbsolutePath file+      absolutePathsCradleDeps <$> lookupOrWaitCache recorder sessionState absFile++-- | Given a file, this function will return the HscEnv and the dependencies+-- it would look up the cache first, if the cache is not available, it would+-- submit a request to the getOptionsLoop to get the options for the file+-- and wait until the options are available+lookupOrWaitCache :: Recorder (WithPriority Log) -> SessionState -> FilePath -> IO (IdeResult HscEnvEq, DependencyInfo)+lookupOrWaitCache recorder sessionState absFile = do+  let ncfp = toNormalizedFilePath' absFile+  cacheResult <- maybeM+    (return Nothing)+    (guardedA (checkDependencyInfo . snd))+    (atomically $ do+      -- wait until target file is not in pendingFiles+      Extra.whenM (S.lookup absFile (pendingFiles sessionState)) STM.retry+      -- check if in the cache+      checkInCache sessionState ncfp)+++  logWith recorder Debug $ LogLookupSessionCache absFile++  case cacheResult of+    Just r -> return r+    Nothing -> do+      -- if not ok, we need to reload the session+      atomically $ addToPending sessionState absFile+      lookupOrWaitCache recorder sessionState absFile++checkInCache :: SessionState -> NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo))+checkInCache sessionState ncfp = runMaybeT $ do+  cachedHieYamlLocation <- MaybeT $ STM.lookup ncfp (filesMap sessionState)+  m <- MaybeT $ STM.lookup cachedHieYamlLocation (fileToFlags sessionState)+  MaybeT $ pure $ HM.lookup ncfp m++-- | Modify the shake state.+data SessionShake = SessionShake+  { restartSession :: VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()+  , invalidateCache :: IO Key+  , enqueueActions :: DelayedAction () -> IO (IO ())+  }++-- | Read-only data that the initialisation logic needs access to.+data SessionEnv = SessionEnv+  { sessionLspContext      :: Maybe (LanguageContextEnv Config)+  , sessionRootDir         :: FilePath+  , sessionIdeOptions      :: IdeOptions+  , sessionPendingBarrier  :: TVar (Maybe Int)+  , sessionClientConfig    :: Config+  , sessionSharedNameCache :: NameCache+  , sessionLoadingOptions  :: SessionLoadingOptions+  }++type SessionM = ReaderT SessionEnv IO++-- | The main function which gets options for a file.+--+-- The general approach is as follows:+-- 1. Find the 'hie.yaml' for the next file target, if there is any.+-- 2. Check in the cache, whether the given 'hie.yaml' was already loaded before+-- 3.1. If it wasn't, initialise a new session and continue with step 4.+-- 3.2. If it is loaded, check whether we need to reload the session, e.g. because the `.cabal` file was modified+-- 3.2.1. If we need to reload, remove the+--+-- See Note [SessionState and batch load] for an overview of the strategy.+getOptionsLoop :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> SessionM ()+getOptionsLoop recorder sessionShake sessionState knownTargetsVar = forever $ do+  pendingBarrier <- asks sessionPendingBarrier+  IdeTesting isTestMode <- asks (optTesting . sessionIdeOptions)+  when isTestMode $+    liftIO $ waitForSessionLoaderPendingBarrier pendingBarrier sessionState++  -- Get the next file to load+  file <- liftIO $ atomically $ S.readQueue (pendingFiles sessionState)+  logWith recorder Debug (LogGetOptionsLoop file)++  hieLoc <- findHieYamlForTarget (filesMap sessionState) file+  sessionOpts recorder sessionShake sessionState knownTargetsVar (hieLoc, file)+    `Safe.catch` handleSingleFileProcessingError' sessionState hieLoc file++findHieYamlForTarget :: FilesMap -> FilePath -> SessionM (Maybe FilePath)+findHieYamlForTarget filesMapping file = do+  let ncfp = toNormalizedFilePath' file+  cachedHieYamlLocation <- join <$> liftIO (atomically (STM.lookup ncfp filesMapping))+  sessionLoadingOptions <- asks sessionLoadingOptions+  hieYaml <- liftIO $ findCradle sessionLoadingOptions file+  pure $ cachedHieYamlLocation <|> hieYaml++-- | This caches the mapping from hie.yaml + Mod.hs -> [String]+-- Returns the Ghc session and the cradle dependencies+sessionOpts :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> (Maybe FilePath, FilePath) -> SessionM ()+sessionOpts recorder sessionShake sessionState knownTargetsVar (hieYaml, file) = do+  Extra.whenM (didSessionLoadingPreferenceConfigChange sessionState) $ do+    logWith recorder Info LogSessionLoadingChanged+    liftIO $ atomically $ resetFileMaps sessionState+    -- Don't even keep the name cache, we start from scratch here!+    liftIO $ modifyVar_ (hscEnvs sessionState) (const (return Map.empty))+    -- cleanup error loading files and cradle files+    clearErrorLoadingFiles sessionState+    clearCradleFiles sessionState+    cacheKey <- liftIO $ invalidateCache sessionShake+    liftIO $ restartSession sessionShake VFSUnmodified "didSessionLoadingPreferenceConfigChange" [] (return [cacheKey])++  v <- liftIO $ atomically $ STM.lookup hieYaml (fileToFlags sessionState)+  case v >>= HM.lookup (toNormalizedFilePath' file) of+    Just (_opts, old_di) -> do+      deps_ok <- liftIO $ checkDependencyInfo old_di+      if not deps_ok+        then do+          -- if deps are old, we can try to load the error files again+          removeErrorLoadingFile sessionState file+          removeCradleFile sessionState file+          -- If the dependencies are out of date then clear both caches and start+          -- again.+          liftIO $ atomically $ resetFileMaps sessionState+          -- Keep the same name cache+          liftIO $ modifyVar_ (hscEnvs sessionState) (return . Map.adjust (const []) hieYaml)+          -- This file needs to be reloaded!+          consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml file+        else do+          -- If deps are ok, we can just remove the file from pending files.+          -- This unblocks the STM waiting in 'lookupOrWaitCache'.+          liftIO $ atomically $ removeFromPending sessionState file+    Nothing ->+        -- This file has never been loaded before, so actually load it now!+        consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml file++consultCradle :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> Maybe FilePath -> FilePath -> SessionM ()+consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml cfp = do+  (cradle, eopts) <- loadCradleWithNotifications recorder sessionState hieYaml cfp++  logWith recorder Debug $ LogSessionLoadingResult eopts+  let ncfp = toNormalizedFilePath' cfp+  case eopts of+    -- The cradle gave us some options so get to work turning them+    -- into and HscEnv.+    Right (opts, libDir, version) -> do+      let compileTime = fullCompilerVersion+      case reverse $ readP_to_S parseVersion version of+        [] -> error $ "GHC version could not be parsed: " <> version+        ((runTime, _):_)+          | compileTime == runTime -> session recorder sessionShake sessionState knownTargetsVar (hieYaml, ncfp, opts, libDir)+          | otherwise -> handleSingleFileProcessingError' sessionState hieYaml cfp (GhcVersionMismatch{..})+    -- Failure case, either a cradle error or the none cradle+    Left err -> do+        -- what if the error to load file is one of old_files ?+        let attemptToLoadFiles = Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err+        old_files <- liftIO $ readVar (loadedFiles sessionState)+        let errorToLoadNewFiles = cfp : Set.toList (attemptToLoadFiles `Set.difference` old_files)+        if length errorToLoadNewFiles > 1+        then do+            -- We tried loading multiple files, but some failed to load!+            -- Unfortunately, 'hie-bios' is an all-or-nothing kind of deal,+            -- and we don't know whether some of the files could have been loaded,+            -- or none of them have been!+            -- To work around this, we try to remove the failing targets from the set of extra targets,+            -- to still get a fast reload.+            --+            -- How do we do this? We mark all of the extra target files as files that failed to+            -- to load and retry to load the original target.+            -- We decide the extra targets in 'getExtraFilesToLoad', which takes the+            -- set of failed targets into account.+            liftIO $ handleBatchLoadFailure sessionState errorToLoadNewFiles+            -- retry without other files+            logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles)+            consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml cfp+        else do+            -- We are only loading this file and it failed, so we definitely know,+            -- we can't load it.+            -- Add it to the list of permanently failed to load targets and do not retry!+            let res = map (\err' -> renderCradleError err' cradle ncfp) err+            handleSingleFileProcessingError sessionState hieYaml cfp res $ concatMap cradleErrorDependencies err++-- | Set up the GHC session for the new 'ComponentOptions' we have discovered.+--+-- The units found in these 'ComponentOptions' are merged with the set of existing home units,+-- replacing the older home unit with the new ones.+-- We update the GHC session to use a multiple home unit session, and restart the shake session accordingly.+session ::+    Recorder (WithPriority Log) ->+    SessionShake ->+    SessionState ->+    TVar (Hashed KnownTargets) ->+    (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) ->+    SessionM ()+session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, libDir) = do+  let initEmptyHscEnv = emptyHscEnvM libDir+  (new_components_info, old_components_info) <- packageSetup recorder sessionState initEmptyHscEnv (hieYaml, cfp, opts)++  -- For each component, now make a new HscEnvEq which contains the+  -- HscEnv for the hie.yaml file but the DynFlags for that component+  -- For GHC's supporting multi component sessions, we create a shared+  -- HscEnv but set the active component accordingly+  hscEnv <- initEmptyHscEnv+  ideOptions <- asks sessionIdeOptions+  let new_cache = newComponentCache (cmapWithPrio LogSessionGhc recorder) (optExtensions ideOptions) cfp hscEnv+  all_target_details <- liftIO $ new_cache old_components_info new_components_info+  (all_targets, this_flags_map) <- liftIO $ addErrorTargetIfUnknown all_target_details hieYaml cfp+  -- The VFS doesn't change on cradle edits, re-use the old one.+  -- Invalidate all the existing GhcSession build nodes by restarting the Shake session+  liftIO $ do+    checkProject <- optCheckProject ideOptions+    restartSession sessionShake VFSUnmodified "new component" [] $ do+        -- It is necessary to call 'handleBatchLoadSuccess' in restartSession+        -- to ensure the GhcSession rule does not return before a new session is started.+        -- Otherwise, invalid compilation results may propagate to downstream rules,+        -- potentially resulting in lost diagnostics and other issues.+        handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets+        keys2 <- invalidateCache sessionShake+        keys1 <- extendKnownTargets recorder knownTargetsVar all_targets+        -- Typecheck all files in the project on startup+        unless (null new_components_info || not checkProject) $ do+            cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets)+            void $ enqueueActions sessionShake $ mkDelayedAction "InitialLoad" Debug $ void $ do+                mmt <- uses GetModificationTime cfps'+                let cs_exist = catMaybes (zipWith (<$) cfps' mmt)+                modIfaces <- uses GetModIface cs_exist+                -- update exports map+                shakeExtras <- getShakeExtras+                let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces+                liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>)+        return [keys1, keys2]++-- | Create a new HscEnv from a hieYaml root and a set of options+packageSetup :: Recorder (WithPriority Log) -> SessionState -> SessionM HscEnv -> (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> SessionM ([ComponentInfo], [ComponentInfo])+packageSetup recorder sessionState newEmptyHscEnv (hieYaml, cfp, opts) = do+  getCacheDirs <- asks (getCacheDirs . sessionLoadingOptions)+  haddockparse <- asks (optHaddockParse . sessionIdeOptions)+  rootDir <- asks sessionRootDir+  -- Parse DynFlags for the newly discovered component+  hscEnv <- newEmptyHscEnv+  newTargetDfs <- liftIO $ evalGhcEnv hscEnv $ setOptions haddockparse cfp opts (hsc_dflags hscEnv) rootDir+  let deps = componentDependencies opts ++ maybeToList hieYaml+  dep_info <- liftIO $ getDependencyInfo (fmap (toAbsolute rootDir) 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)+  liftIO $ modifyVar (hscEnvs sessionState) $+    addComponentInfo (cmapWithPrio LogSessionGhc recorder) getCacheDirs dep_info newTargetDfs (hieYaml, cfp, opts)++addErrorTargetIfUnknown :: Foldable t => t [TargetDetails] -> Maybe FilePath -> NormalizedFilePath -> IO ([TargetDetails], HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))+addErrorTargetIfUnknown all_target_details hieYaml cfp = do+  let flags_map' = HM.fromList (concatMap toFlagsMap all_targets')+      all_targets' = concat all_target_details+  this_dep_info <- getDependencyInfo $ maybeToList hieYaml+  let (all_targets, this_flags_map) = case HM.lookup cfp flags_map' of+        Just _ -> (all_targets', flags_map')+        Nothing -> (this_target_details : all_targets', HM.insert cfp this_flags flags_map')+          where+                this_target_details = TargetDetails (TargetFile cfp) this_error_env this_dep_info [cfp]+                this_flags = (this_error_env, this_dep_info)+                this_error_env = ([this_error], Nothing)+                this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) cfp+                                (T.unlines+                                  [ "No cradle target found. Is this file listed in the targets of your cradle?"+                                  , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section"+                                  ])+                                Nothing+  pure (all_targets, this_flags_map)++-- | 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+extendKnownTargets :: Recorder (WithPriority Log) -> TVar (Hashed KnownTargets) -> [TargetDetails] -> IO Key+extendKnownTargets recorder knownTargetsVar newTargets = do+  knownTargets <- concatForM  newTargets $ \TargetDetails{..} ->+    case targetTarget of+      TargetFile f -> do+        -- If a target file has multiple possible locations, then we+        -- assume they are all separate file targets.+        -- This happens with '.hs-boot' files if they are in the root directory of the project.+        -- GHC reports options such as '-i. A' as 'TargetFile A.hs' instead of 'TargetModule A'.+        -- In 'fromTargetId', we dutifully look for '.hs-boot' files and add them to the+        -- targetLocations of the TargetDetails. Then we add everything to the 'knownTargetsVar'.+        -- However, when we look for a 'Foo.hs-boot' file in 'FindImports.hs', we look for either+        --+        --  * TargetFile Foo.hs-boot+        --  * TargetModule Foo+        --+        -- If we don't generate a TargetFile for each potential location, we will only have+        -- 'TargetFile Foo.hs' in the 'knownTargetsVar', thus not find 'TargetFile Foo.hs-boot'+        -- and also not find 'TargetModule Foo'.+        fs <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations+        pure $ map (\fp -> (TargetFile fp, Set.singleton fp)) (nubOrd (f:fs))+      TargetModule _ -> do+        found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations+        return [(targetTarget, Set.fromList found)]+  hasUpdate <- atomically $ do+    known <- readTVar knownTargetsVar+    let known' = flip mapHashed known $ \k -> unionKnownTargets k (mkKnownTargets knownTargets)+        hasUpdate = if known /= known' then Just (unhashed known') else Nothing+    writeTVar knownTargetsVar known'+    pure hasUpdate+  for_ hasUpdate $ \x ->+    logWith recorder Debug $ LogKnownFilesUpdated (targetMap x)+  return $ toNoFileKey GetKnownTargets+++loadCradleWithNotifications ::+  Recorder (WithPriority Log) ->+  SessionState ->+  Maybe FilePath ->+  FilePath ->+  SessionM (Cradle Void, Either [CradleError] (ComponentOptions, FilePath, String))+loadCradleWithNotifications recorder sessionState hieYaml cfp = do+  rootDir <- asks sessionRootDir+  let lfpLog = makeRelative rootDir cfp+  logWith recorder Info $ LogCradlePath lfpLog+  when (isNothing hieYaml) $+    logWith recorder Warning $ LogCradleNotFound lfpLog++  -- Find the 'Cradle' for the target+  loadingOptions <- asks sessionLoadingOptions+  cradle <- liftIO $ loadCradle loadingOptions recorder hieYaml rootDir++  -- Test notification for better observability.+  IdeTesting isTesting <- asks (optTesting . sessionIdeOptions)+  lspEnv <- asks sessionLspContext+  when isTesting $ mRunLspT lspEnv $+    sendNotification (SMethod_CustomMethod (Proxy @"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 lfpLog <> ")"++  sessionPref <- asks (sessionLoading . sessionClientConfig)+  extraToLoads <- liftIO $ getExtraFilesToLoad sessionState cfp+  -- Start loading the file!+  eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $+    withTrace "Load cradle" $ \addTag -> do+        addTag "file" lfpLog+        res <- liftIO $ cradleToOptsAndLibDir recorder sessionPref cradle cfp extraToLoads+        addTag "result" (show res)+        return res+  pure (cradle, eopts)+++-- | 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 :: Recorder (WithPriority Log) -> SessionLoadingPreferenceConfig -> Cradle Void -> FilePath -> [FilePath]+                      -> IO (Either [CradleError] (ComponentOptions, FilePath, String))+cradleToOptsAndLibDir recorder loadConfig cradle file old_fps = do+    -- let noneCradleFoundMessage :: FilePath -> T.Text+    --     noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file"+    -- Start off by getting the session options+    logWith recorder Debug $ LogCradle cradle+    cradleRes <- HieBios.getCompilerOptions file loadStyle cradle+    case cradleRes of+        CradleSuccess r -> do+            -- Now get the GHC lib dir+            libDirRes <- getRuntimeGhcLibDir cradle+            versionRes <- getRuntimeGhcVersion cradle+            case liftA2 (,) libDirRes versionRes of+                -- This is the successful path+                (CradleSuccess (libDir, version)) -> pure (Right (r, libDir, version))+                CradleFail err       -> return (Left [err])+                CradleNone           -> do+                    logWith recorder Info $ LogNoneCradleFound file+                    return (Left [])++        CradleFail err -> return (Left [err])+        CradleNone -> do+            logWith recorder Info $ LogNoneCradleFound file+            return (Left [])++    where+        loadStyle = case loadConfig of+            PreferSingleComponentLoading -> LoadFile+            PreferMultiComponentLoading  -> LoadWithContext old_fps++-- ----------------------------------------------------------------------------+-- Utilities+-- ----------------------------------------------------------------------------++emptyHscEnvM :: FilePath -> SessionM HscEnv+emptyHscEnvM libDir = do+  nc <- asks sessionSharedNameCache+  liftIO $ Ghc.emptyHscEnv nc libDir++toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))]+toFlagsMap TargetDetails{..} =+    [ (l, (targetEnv, targetDepends)) | l <-  targetLocations]++-- | Mapping from @hie.yaml@ to all components that have been loaded+-- from this @hie.yaml@ location.+--+-- See Note [Multi Cradle Dependency Info]+type HieMap = Map.Map (Maybe FilePath) [RawComponentInfo]++-- | Maps a @hie.yaml@ location to all its Target Filepaths and options.+-- Reverse of 'FilesMap'.+type FlagsMap = STM.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 = STM.Map NormalizedFilePath (Maybe FilePath)++-- | 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)++----------------------------------------------------------------------------------------------------++data PackageSetupException+    = PackageSetupException+        { message     :: !String+        }+    | GhcVersionMismatch+        { compileTime :: !Version+        , runTime     :: !Version+        }+    deriving (Eq, Show, Typeable)++instance Exception PackageSetupException++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 fullCompilerVersion+    , "failed to load packages:", message <> "."+    , "\nPlease ensure that ghcide is compiled with the same GHC installation as the project."]++renderPackageSetupException :: FilePath -> PackageSetupException -> FileDiagnostic+renderPackageSetupException fp e =+  ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) Nothing
+ session-loader/Development/IDE/Session/Dependency.hs view
@@ -0,0 +1,35 @@+module Development.IDE.Session.Dependency where++import           Control.Exception.Safe as Safe+import           Data.Either.Extra+import qualified Data.Map.Strict        as Map+import           Data.Time.Clock+import           System.Directory++type DependencyInfo = Map.Map FilePath (Maybe UTCTime)++-- | 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+    safeTryIO :: IO a -> IO (Either IOException a)+    safeTryIO = Safe.try++    do_one :: FilePath -> IO (FilePath, Maybe UTCTime)+    do_one fp = (fp,) . eitherToMaybe <$> safeTryIO (getModificationTime fp)
session-loader/Development/IDE/Session/Diagnostics.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric  #-}  module Development.IDE.Session.Diagnostics where import           Control.Applicative+import           Control.Lens import           Control.Monad import qualified Data.Aeson                        as Aeson import           Data.List@@ -18,32 +18,59 @@  data CradleErrorDetails =   CradleErrorDetails-    { cabalProjectFiles :: [FilePath]+    { cradleDependencies    :: [FilePath]     -- ^ files related to the cradle error     -- i.e. .cabal, cabal.project, etc.+    , structuredCradleError :: Maybe StructuredCradleError+    -- ^ structured information about the cradle error+    -- i.e. unknownModules error     } deriving (Show, Eq, Ord, Read, Generic, Aeson.ToJSON, Aeson.FromJSON) +data StructuredCradleError+  = UnknownModuleError UnknownModuleDetails+  deriving (Show, Eq, Ord, Read, Generic, Aeson.ToJSON, Aeson.FromJSON)++data UnknownModuleDetails =+  UnknownModuleDetails+    { moduleFilePath      :: FilePath+    , suggestedModuleName :: String+    } deriving (Show, Eq, Ord, Read, Generic, Aeson.ToJSON, Aeson.FromJSON)+ {- | Takes a cradle error, the corresponding cradle and the file path where   the cradle error occurred (of the file we attempted to load).   Depicts the cradle error in a user-friendly way. -} renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic-renderCradleError (CradleError deps _ec ms) cradle nfp-  | HieBios.isCabalCradle cradle =-      let (fp, showDiag, diag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage in-        (fp, showDiag, diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}})-  | otherwise = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage+renderCradleError cradleError cradle nfp =+  let noDetails =+        ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp (T.unlines $ map T.pack userFriendlyMessage) Nothing+  in+  if HieBios.isCabalCradle cradle+     then noDetails & fdLspDiagnosticL %~ \diag -> diag+            { _data_ = Just $ Aeson.toJSON CradleErrorDetails+                { cradleDependencies = absDeps+                , structuredCradleError = fmap UnknownModuleError mkUnknownModuleDetails+                }+            }+     else noDetails   where-    absDeps = fmap (cradleRootDir cradle </>) deps+    ms = cradleErrorStderr cradleError++    absDeps = fmap (cradleRootDir cradle </>) (cradleErrorDependencies cradleError)     userFriendlyMessage :: [String]     userFriendlyMessage-      | HieBios.isCabalCradle cradle = fromMaybe ms $ fileMissingMessage <|> mkUnknownModuleMessage+      | HieBios.isCabalCradle cradle = fromMaybe ms $ fileMissingMessage <|> (unknownModuleMessage (fromNormalizedFilePath nfp) <$ mkUnknownModuleDetails)       | otherwise = ms -    mkUnknownModuleMessage :: Maybe [String]-    mkUnknownModuleMessage+    -- Produce structured details when unknown module error is detected+    mkUnknownModuleDetails :: Maybe UnknownModuleDetails+    mkUnknownModuleDetails       | any (isInfixOf "Failed extracting script block:") ms =-          Just $ unknownModuleMessage (fromNormalizedFilePath nfp)+          let fp = fromNormalizedFilePath nfp+          in Just UnknownModuleDetails+               { moduleFilePath   = fp+               , suggestedModuleName = dropExtension (takeFileName fp)+               }       | otherwise = Nothing      fileMissingMessage :: Maybe [String]
+ session-loader/Development/IDE/Session/Ghc.hs view
@@ -0,0 +1,578 @@+{-# LANGUAGE CPP #-}+module Development.IDE.Session.Ghc where++import           Control.Monad+import           Control.Monad.Extra                as Extra+import           Control.Monad.IO.Class+import qualified Crypto.Hash.SHA1                   as H+import qualified Data.ByteString.Base16             as B16+import qualified Data.ByteString.Char8              as B+import           Data.Function+import           Data.List+import           Data.List.Extra                    as L+import           Data.List.NonEmpty                 (NonEmpty (..))+import qualified Data.List.NonEmpty                 as NE+import qualified Data.Map.Strict                    as Map+import           Data.Maybe+import qualified Data.Text                          as T+import           Development.IDE.Core.Shake         hiding (Log, knownTargets,+                                                     withHieDb)+import qualified Development.IDE.GHC.Compat         as Compat+import           Development.IDE.GHC.Compat.CmdLine+import           Development.IDE.GHC.Compat.Core    hiding (Target, TargetFile,+                                                     TargetModule, Var, Warning,+                                                     getOptions)+import qualified Development.IDE.GHC.Compat.Core    as GHC+import           Development.IDE.GHC.Compat.Env     hiding (Logger)+import           Development.IDE.GHC.Compat.Units   (UnitId)+import           Development.IDE.GHC.Util+import           Development.IDE.Types.Diagnostics+import           Development.IDE.Types.HscEnvEq     (HscEnvEq, newHscEnvEq)+import           Development.IDE.Types.Location+import           GHC.ResponseFile+import qualified HIE.Bios.Cradle.Utils              as HieBios+import           HIE.Bios.Environment               hiding (getCacheDir)+import           HIE.Bios.Types                     hiding (Log)+import           Ide.Logger                         (Pretty (pretty),+                                                     Priority (Debug, Error, Info),+                                                     Recorder, WithPriority,+                                                     logWith, viaShow, (<+>))+import           System.Directory+import           System.FilePath+import           System.Info+++import           Control.DeepSeq+import           Control.Exception                  (evaluate)+import           Control.Monad.IO.Unlift            (MonadUnliftIO)+import qualified Data.Set                           as OS+import qualified Development.IDE.GHC.Compat.Util    as Compat+import           Development.IDE.Session.Dependency+import           Development.IDE.Types.Options+import           GHC.Data.Graph.Directed+import           Ide.PluginUtils                    (toAbsolute)++import           GHC.Driver.Env                     (hsc_all_home_unit_ids)+import           GHC.Driver.Errors.Types+import           GHC.Types.Error                    (errMsgDiagnostic,+                                                     singleMessage)+import           GHC.Unit.State+++#if MIN_VERSION_ghc(9,13,0)+import           GHC.Driver.Make                    (checkHomeUnitsClosed)+#endif++data Log+  = LogInterfaceFilesCacheDir !FilePath+  | LogMakingNewHscEnv ![UnitId]+  | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)+  | LogDLLLoadError !String+deriving instance Show Log++instance Pretty Log where+  pretty = \case+    LogInterfaceFilesCacheDir path ->+      "Interface files cache directory:" <+> pretty path+    LogMakingNewHscEnv inPlaceUnitIds ->+      "Making new HscEnv. In-place unit ids:" <+> pretty (map show inPlaceUnitIds)+    LogNewComponentCache componentCache ->+      "New component cache HscEnvEq:" <+> viaShow componentCache+    LogDLLLoadError errorString ->+      "Error dynamically loading libm.so.6:" <+> pretty errorString+-- | Configuration info for a particular home unit.+data HomeUnitConfig = HomeUnitConfig+  {+  -- | The dynamic flags to compile this specific unit.+    homeUnitDynFlags :: DynFlags+  -- | All the targets for this unit.+  , homeUnitTargets  :: [GHC.Target]+  -- | Optional hash seed to differentiate home units+  -- with same `-this-unit-id`. Used when `-this-unit-id` is "main",+  -- which is common when loading a single target.+  , homeUnitHash     :: Maybe B.ByteString+  }+-- This is pristine information about a component+data RawComponentInfo = RawComponentInfo+  { rawComponentUnitId         :: UnitId+  -- | 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+  -- | An optional hash seed generated in 'setOptions' for the unit id "main".+  , rawComponentHash           :: Maybe B.ByteString+  }++-- This is processed information about the component, in particular the dynflags will be modified.+data ComponentInfo = ComponentInfo+  { componentUnitId         :: UnitId+  -- | Processed DynFlags. Does not contain inplace packages such as local+  -- libraries. Can be used to actually load this Component.+  , componentDynFlags       :: DynFlags+  -- | 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+  }+++unit_flags :: [Flag (CmdLineP [String])]+unit_flags = [defFlag "unit"  (SepArg addUnit)]++addUnit :: String -> EwM (CmdLineP [String]) ()+addUnit unit_str = liftEwM $ do+  units <- getCmdLineState+  putCmdLineState (unit_str : units)+++-- | Create a mapping from FilePaths to HscEnvEqs+-- This combines all the components we know about into+-- an appropriate session, which is a multi component+-- session on GHC 9.4++newComponentCache+         :: Recorder (WithPriority Log)+         -> [String]           -- ^ File extensions to consider+         -> NormalizedFilePath -- ^ Path to file that caused the creation of this component+         -> HscEnv             -- ^ An empty HscEnv+         -> [ComponentInfo]    -- ^ New components to be loaded+         -> [ComponentInfo]    -- ^ old, already existing components+         -> IO [ [TargetDetails] ]+newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do+    let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis)+        -- When we have multiple components with the same uid,+        -- prefer the new one over the old.+        -- However, we might have added some targets to the old unit+        -- (see special target), so preserve those+        unionCIs new_ci old_ci = new_ci { componentTargets = componentTargets new_ci ++ componentTargets old_ci }+        mkMap = Map.fromListWith unionCIs . map (\ci -> (componentUnitId ci, ci))+    let dfs = map componentDynFlags $ Map.elems cis+        uids = Map.keys cis+    logWith recorder Info $ LogMakingNewHscEnv uids+    hscEnv' <- -- Set up a multi component session with the other units on GHC 9.4+              Compat.initUnits dfs hsc_env++#if MIN_VERSION_ghc(9,13,0)+    let closure_errs_raw = checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv')+        closure_errs = concatMap (Compat.bagToList . Compat.getMessages) closure_errs_raw+#else+    let closure_errs = maybeToList $ checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv')+#endif+        closure_err_to_multi_err err =+            ideErrorWithSource+                (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp+                (T.pack (Compat.printWithoutUniques (singleMessage err)))+                (Just (fmap GhcDriverMessage err))+        multi_errs = map closure_err_to_multi_err closure_errs+        bad_units = OS.fromList $ concat $ do+            x <- map errMsgDiagnostic closure_errs+            DriverHomePackagesNotClosed us <- pure x+            pure us+        isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units+    -- 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+    -- We need to do this after the call to setSessionDynFlags initialises+    -- the loader+    when (os == "linux") $ do+      initObjLinker hscEnv'+      res <- loadDLL hscEnv' "libm.so.6"+      case res of+        Nothing  -> pure ()+        Just err -> logWith recorder Error $ LogDLLLoadError err++    forM (Map.elems cis) $ \ci -> do+      let df = componentDynFlags ci+      thisEnv <- do+            -- In GHC 9.4 we have multi component support, and we have initialised all the units+            -- above.+            -- We just need to set the current unit here+            pure $ hscSetActiveUnitId (homeUnitId_ df) hscEnv'+      henv <- newHscEnvEq thisEnv+      let targetEnv = (if isBad ci then multi_errs else [], Just henv)+          targetDepends = componentDependencyInfo ci+      logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends)+      evaluate $ liftRnf rwhnf $ componentTargets ci++      let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends+      ctargets <- concatMapM mk (componentTargets ci)++      return (L.nubOrdOn targetTarget ctargets)++-- | Throws if package flags are unsatisfiable+setOptions :: GhcMonad m+    => OptHaddockParse+    -> NormalizedFilePath+    -> ComponentOptions+    -> DynFlags+    -> FilePath -- ^ root dir, see Note [Root Directory]+    -> m (NonEmpty HomeUnitConfig)+setOptions haddockOpt cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do+    ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts)+    case NE.nonEmpty units of+      Just us -> initMulti us+      Nothing -> do+        (HomeUnitConfig df targets mHash) <- initOne (map unLoc theOpts')+        -- 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.+        --+        -- When we have a singleComponent that is caused to be loaded due to a+        -- file, we assume the file is part of that component. This is useful+        -- for bare GHC sessions, such as many of the ones used in the testsuite+        --+        -- We don't do this when we have multiple components, because each+        -- component better list all targets or there will be anarchy.+        -- It is difficult to know which component to add our file to in+        -- that case.+        -- Multi unit arguments are likely to come from cabal, which+        -- does list all targets.+        --+        -- If we don't end up with a target for the current file in the end, then+        -- we will report it as an error for that file+        let abs_fp = toAbsolute rootDir (fromNormalizedFilePath cfp)+        let special_target = Compat.mkSimpleTarget df abs_fp+        pure $ HomeUnitConfig df (special_target : targets) mHash :| []+    where+      initMulti unitArgFiles =+        forM unitArgFiles $ \f -> do+          args <- liftIO $ expandResponse [f]+          -- The reponse files may contain arguments like "+RTS",+          -- and hie-bios doesn't expand the response files of @-unit@ arguments.+          -- Thus, we need to do the stripping here.+          initOne $ HieBios.removeRTS $ HieBios.removeVerbosityOpts args+      initOne this_opts = do+        (dflags', targets') <- addCmdOpts this_opts dflags+        let (dflags'',mHash) =+                case unitIdString (homeUnitId_ dflags') of+                     -- cabal uses main for the unit id of all executable packages+                     -- This makes multi-component sessions confused about what+                     -- options to use for that component.+                     -- Solution: hash the options and use that as part of the unit id+                     -- This works because there won't be any dependencies on the+                     -- executable unit.+                     "main" ->+                       let hashBytes =H.finalize $ H.updates H.init (map B.pack this_opts)+                           hash =  B.unpack $ B16.encode hashBytes+                           hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash))+                       in (setHomeUnitId_ hashed_uid dflags', Just hashBytes)+                     _ -> (dflags', Nothing)++        let targets = makeTargetsAbsolute root targets'+            root = case workingDirectory dflags'' of+              Nothing   -> compRoot+              Just wdir -> compRoot </> wdir+        let dflags''' =+              setWorkingDirectory root $+              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 $+              setBytecodeLinkerOptions $+              enableOptHaddock haddockOpt $+              disableOptimisation $+              Compat.setUpTypedHoles $+              makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory+              dflags''+        return (HomeUnitConfig dflags''' targets mHash)++addComponentInfo ::+  MonadUnliftIO m =>+  Recorder (WithPriority Log) ->+  (String -> Maybe B.ByteString -> [String] -> IO CacheDirs) ->+  DependencyInfo ->+  NonEmpty HomeUnitConfig->+  (Maybe FilePath, NormalizedFilePath, ComponentOptions) ->+  Map.Map (Maybe FilePath) [RawComponentInfo] ->+  m (Map.Map (Maybe FilePath) [RawComponentInfo], ([ComponentInfo], [ComponentInfo]))+addComponentInfo recorder getCacheDirs dep_info newDynFlags (hieYaml, cfp, opts) 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 = fmap (\(HomeUnitConfig df targets mHash) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info mHash) newDynFlags+      all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps+      -- Get all the unit-ids for things in this component++  all_deps' <- forM all_deps $ \RawComponentInfo{..} -> do+    let prefix = show rawComponentUnitId+    -- See Note [Avoiding bad interface files]+    let cacheDirOpts = componentOptions opts+    cacheDirs <- liftIO $ getCacheDirs prefix rawComponentHash cacheDirOpts+    processed_df <- setCacheDirs recorder cacheDirs rawComponentDynFlags+    -- 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+      { componentUnitId = rawComponentUnitId+      , componentDynFlags = processed_df+      , componentTargets = rawComponentTargets+      , componentFP = rawComponentFP+      , componentCOptions = rawComponentCOptions+      , componentDependencyInfo = rawComponentDependencyInfo+      }+  -- Modify the map so the hieYaml now maps to the newly updated+  -- ComponentInfos+  -- Returns+  -- . The information for the new component which caused this cache miss+  -- . The modified information (without -inplace flags) for+  --   existing packages+  let (new,old) = NE.splitAt (NE.length new_deps) all_deps'+  pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old))++setIgnoreInterfacePragmas :: DynFlags -> DynFlags+setIgnoreInterfacePragmas df =+    gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges++disableOptimisation :: DynFlags -> DynFlags+disableOptimisation df = updOptLevel 0 df++-- | We always compile with '-haddock' unless explicitly disabled.+--+-- This avoids inconsistencies when doing recompilation checking which was+-- observed in https://github.com/haskell/haskell-language-server/issues/4511+enableOptHaddock :: OptHaddockParse -> DynFlags -> DynFlags+enableOptHaddock HaddockParse d   = gopt_set d Opt_Haddock+enableOptHaddock NoHaddockParse d = d++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}++data CacheDirs = CacheDirs+  { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath}++{- 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+```++and many more.++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 :: MonadUnliftIO m => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags+setCacheDirs recorder CacheDirs{..} dflags = do+    logWith recorder Info $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir)+    pure $ dflags+          & maybe id setHiDir hiCacheDir+          & maybe id setHieDir hieCacheDir+          & maybe id setODir oCacheDir++-- | Append the hash to the unit id to create unique cache folders.+--+-- This function generates a single, unified hash.+-- If an optional base hash (@mFirstHash@) is provided—which+-- is common for a single target with `-this-unit-id` as "main"-+-- we set the prefix to "main", extract the context generated+-- from the @mFirstHash@, and update the @opts@ into the same hash.+--+-- This guarantees a unique cache folder for different GHC+-- options(avoiding incompatible interface files) while+-- keeping the path short and clean.+getCacheDirsDefault :: String -> Maybe B.ByteString -> [String] -> IO CacheDirs+getCacheDirsDefault prefix mFirstHash 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.+        prefix' = if isJust mFirstHash then "main" else prefix+        basectx = case mFirstHash of+          Just h  -> H.updates H.init [h]+          Nothing -> H.init+        opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates basectx (map B.pack opts)++setNameCache :: NameCache -> HscEnv -> HscEnv+setNameCache nc hsc = hsc { hsc_NC = nc }++-- | Sub directory for the cache path+cacheDir :: String+cacheDir = "ghcide"++emptyHscEnv :: NameCache -> FilePath -> IO HscEnv+emptyHscEnv nc libDir = do+    -- We call setSessionDynFlags so that the loader is initialised+    -- We need to do this before we call initUnits.+    env <- liftIO $ runGhc (Just libDir) $+      getSessionDynFlags >>= setSessionDynFlags >> getSession+    pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env)++-- ----------------------------------------------------------------------------+-- Target Details+-- ----------------------------------------------------------------------------++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 modName) env dep = do+    let fps = [i </> moduleNameSlashes modName -<.> ext <> boot+              | ext <- exts+              , i <- is+              , boot <- ["", "-boot"]+              ]+    let locs = fmap toNormalizedFilePath' fps+    return [TargetDetails (TargetModule modName) env dep locs]+-- For a 'TargetFile' we consider all the possible module names+fromTargetId _ _ (GHC.TargetFile f _) env deps = do+    let nf = toNormalizedFilePath' f+    let other+          | "-boot" `isSuffixOf` f = toNormalizedFilePath' (L.dropEnd 5 $ fromNormalizedFilePath nf)+          | otherwise = toNormalizedFilePath' (fromNormalizedFilePath nf ++ "-boot")+    return [TargetDetails (TargetFile nf) env deps [nf, other]]++-- ----------------------------------------------------------------------------+-- Backwards compatibility+-- ----------------------------------------------------------------------------++#if MIN_VERSION_ghc(9,13,0)+-- Moved back to implementation in GHC.+checkHomeUnitsClosed' ::  UnitEnv -> OS.Set UnitId -> [DriverMessages]+checkHomeUnitsClosed' ue _ = checkHomeUnitsClosed ue+#else+-- This function checks the important property that if both p and q are home units+-- then any dependency of p, which transitively depends on q is also a home unit.+-- GHC had an implementation of this function, but it was horribly inefficient+-- We should move back to the GHC implementation on compilers where+-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12162 is included+checkHomeUnitsClosed' ::  UnitEnv -> OS.Set UnitId -> Maybe (Compat.MsgEnvelope DriverMessage)+checkHomeUnitsClosed' ue home_id_set+    | OS.null bad_unit_ids = Nothing+    | otherwise = Just (GHC.mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (OS.toList bad_unit_ids))+  where+    bad_unit_ids = upwards_closure OS.\\ home_id_set+    rootLoc = mkGeneralSrcSpan (Compat.fsLit "<command line>")++    graph :: Graph (Node UnitId UnitId)+    graph = graphFromEdgedVerticesUniq graphNodes++    -- downwards closure of graph+    downwards_closure+      = graphFromEdgedVerticesUniq [ DigraphNode uid uid (OS.toList deps)+                                   | (uid, deps) <- Map.toList (allReachable graph node_key)]++    inverse_closure = transposeG downwards_closure++    upwards_closure = OS.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- OS.toList home_id_set]++    all_unit_direct_deps :: UniqMap UnitId (OS.Set UnitId)+    all_unit_direct_deps+      = unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue+      where+        go rest this this_uis =+           plusUniqMap_C OS.union+             (addToUniqMap_C OS.union external_depends this (OS.fromList this_deps))+             rest+           where+             external_depends = mapUniqMap (OS.fromList . unitDepends)+#if !MIN_VERSION_ghc(9,7,0)+                              $ listToUniqMap $ Map.toList+#endif++                              $ unitInfoMap this_units+             this_units = homeUnitEnv_units this_uis+             this_deps = [ Compat.toUnitId unit | (unit,Just _) <- explicitUnits this_units]++    graphNodes :: [Node UnitId UnitId]+    graphNodes = go OS.empty home_id_set+      where+        go done todo+          = case OS.minView todo of+              Nothing -> []+              Just (uid, todo')+                | OS.member uid done -> go done todo'+                | otherwise -> case lookupUniqMap all_unit_direct_deps uid of+                    Nothing -> pprPanic "uid not found" (Compat.ppr (uid, all_unit_direct_deps))+                    Just depends ->+                      let todo'' = (depends OS.\\ done) `OS.union` todo'+                      in DigraphNode uid uid (OS.toList depends) : go (OS.insert uid done) todo''+#endif
+ session-loader/Development/IDE/Session/Implicit.hs view
@@ -0,0 +1,155 @@+module Development.IDE.Session.Implicit+  ( loadImplicitCradle+  ) where+++import           Control.Applicative       ((<|>))+import           Control.Exception         (handleJust)+import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Maybe+import           Data.Bifunctor+import           Data.Functor              ((<&>))+import           Data.Maybe+import           Data.Void+import           System.Directory          hiding (findFile)+import           System.FilePath+import           System.IO.Error++import           Colog.Core                (LogAction (..), WithSeverity (..))+import           HIE.Bios.Config+import           HIE.Bios.Cradle           (defaultCradle, getCradle)+import           HIE.Bios.Types            hiding (ActionName (..))++import           Hie.Cabal.Parser+import           Hie.Locate+import qualified Hie.Yaml                  as Implicit++loadImplicitCradle :: Show a => LogAction IO (WithSeverity Log) -> FilePath -> IO (Cradle a)+loadImplicitCradle l wfile = do+  is_dir <- doesDirectoryExist wfile+  let wdir | is_dir = wfile+           | otherwise = takeDirectory wfile+  cfg <- runMaybeT (implicitConfig wdir)+  case cfg of+    Just bc -> getCradle l absurd bc+    Nothing -> return $ defaultCradle l wdir++-- | Wraps up the cradle inferred by @inferCradleTree@ as a @CradleConfig@ with no dependencies+implicitConfig :: FilePath -> MaybeT IO (CradleConfig a, FilePath)+implicitConfig = (fmap . first) (CradleConfig noDeps) . inferCradleTree+  where+  noDeps :: [FilePath]+  noDeps = []+++inferCradleTree :: FilePath -> MaybeT IO (CradleTree a, FilePath)+inferCradleTree start_dir =+       maybeItsBios+   -- If we have both a config file (cabal.project/stack.yaml) and a work dir+   -- (dist-newstyle/.stack-work), prefer that+   <|> (cabalExecutable >> cabalConfigDir start_dir >>= \dir -> cabalWorkDir dir >> pure (simpleCabalCradle dir))+   <|> (stackExecutable >> stackConfigDir start_dir >>= \dir -> stackWorkDir dir >> stackCradle dir)+   -- If we have a cabal.project OR we have a .cabal and dist-newstyle, prefer cabal+   <|> (cabalExecutable >> (cabalConfigDir start_dir <|> cabalFileAndWorkDir) <&> simpleCabalCradle)+   -- If we have a stack.yaml, use stack+   <|> (stackExecutable >> stackConfigDir start_dir >>= stackCradle)+   -- If we have a cabal file, use cabal+   <|> (cabalExecutable >> cabalFileDir start_dir <&> simpleCabalCradle)++  where+  maybeItsBios = (\wdir -> (Bios (Program $ wdir </> ".hie-bios") Nothing Nothing, wdir)) <$> biosWorkDir start_dir++  cabalFileAndWorkDir = cabalFileDir start_dir >>= (\dir -> cabalWorkDir dir >> pure dir)++-- | Generate a stack cradle given a filepath.+--+-- Since we assume there was proof that this file belongs to a stack cradle+-- we look immediately for the relevant @*.cabal@ and @stack.yaml@ files.+-- We do not look for package.yaml, as we assume the corresponding .cabal has+-- been generated already.+--+-- We parse the @stack.yaml@ to find relevant @*.cabal@ file locations, then+-- we parse the @*.cabal@ files to generate a mapping from @hs-source-dirs@ to+-- component names.+stackCradle :: FilePath -> MaybeT IO (CradleTree a, FilePath)+stackCradle fp = do+  pkgs <- stackYamlPkgs fp+  pkgsWithComps <- liftIO $ catMaybes <$> mapM (nestedPkg fp) pkgs+  let yaml = fp </> "stack.yaml"+  pure $ (,fp) $ case pkgsWithComps of+    [] -> Stack (StackType Nothing (Just yaml))+    ps -> StackMulti mempty $ do+      Package n cs <- ps+      c <- cs+      let (prefix, comp) = Implicit.stackComponent n c+      pure (prefix, StackType (Just comp) (Just yaml))++-- | By default, we generate a simple cabal cradle which is equivalent to the+-- following hie.yaml:+--+-- @+--   cradle:+--     cabal:+-- @+--+-- Note, this only works reliable for reasonably modern cabal versions >= 3.2.+simpleCabalCradle :: FilePath -> (CradleTree a, FilePath)+simpleCabalCradle fp = (Cabal $ CabalType Nothing Nothing, fp)++cabalExecutable :: MaybeT IO FilePath+cabalExecutable = MaybeT $ findExecutable "cabal"++stackExecutable :: MaybeT IO FilePath+stackExecutable = MaybeT $ findExecutable "stack"++biosWorkDir :: FilePath -> MaybeT IO FilePath+biosWorkDir = findFileUpwards (".hie-bios" ==)++cabalWorkDir :: FilePath -> MaybeT IO ()+cabalWorkDir wdir = do+  check <- liftIO $ doesDirectoryExist (wdir </> "dist-newstyle")+  unless check $ fail "No dist-newstyle"++stackWorkDir :: FilePath -> MaybeT IO ()+stackWorkDir wdir = do+  check <- liftIO $ doesDirectoryExist (wdir </> ".stack-work")+  unless check $ fail "No .stack-work"++cabalConfigDir :: FilePath -> MaybeT IO FilePath+cabalConfigDir = findFileUpwards (\fp -> fp == "cabal.project" || fp == "cabal.project.local")++cabalFileDir :: FilePath -> MaybeT IO FilePath+cabalFileDir = findFileUpwards (\fp -> takeExtension fp == ".cabal")++stackConfigDir :: FilePath -> MaybeT IO FilePath+stackConfigDir = findFileUpwards isStack+  where+    isStack name = name == "stack.yaml"++-- | Searches upwards for the first directory containing a file to match+-- the predicate.+findFileUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath+findFileUpwards p dir = do+  cnts <-+    liftIO+    $ handleJust+        -- Catch permission errors+        (\(e :: IOError) -> if isPermissionError e then Just [] else Nothing)+        pure+        (findFile p dir)++  case cnts of+    [] | dir' == dir -> fail "No cabal files"+            | otherwise   -> findFileUpwards p dir'+    _ : _ -> return dir+  where dir' = takeDirectory dir++-- | Sees if any file in the directory matches the predicate+findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath]+findFile p dir = do+  b <- doesDirectoryExist dir+  if b then getFiles >>= filterM doesPredFileExist else return []+  where+    getFiles = filter p <$> getDirectoryContents dir+    doesPredFileExist file = doesFileExist $ dir </> file
+ session-loader/Development/IDE/Session/OrderedSet.hs view
@@ -0,0 +1,54 @@+module Development.IDE.Session.OrderedSet where++import           Control.Concurrent.STM        (STM, TQueue, newTQueueIO)+import           Control.Concurrent.STM.TQueue (readTQueue, writeTQueue)+import           Control.Monad                 (when)+import           Data.Hashable                 (Hashable)+import qualified Data.HashSet+import qualified Focus+import qualified ListT                         as LT+import qualified StmContainers.Set             as S+import           StmContainers.Set             (Set)+++data OrderedSet a = OrderedSet+  { insertionOrder :: TQueue a+  , elements       :: Set a+  }++-- | Insert an element into the ordered set.+-- If the element is not already present, it is added to both the queue and set.+-- If the element already exists, ignore it+insert :: Hashable a => a -> OrderedSet a -> STM ()+insert a (OrderedSet que s) = do+    (_, inserted) <- S.focus (Focus.testingIfInserts $ Focus.insert ()) a s+    -- if already in the set+    when inserted $ writeTQueue que a++newIO :: Hashable a => IO (OrderedSet a)+newIO = do+    que <- newTQueueIO+    s <- S.newIO+    return (OrderedSet que s)++-- | Read the first element from the queue.+-- If an element is not in the set, it means it has been deleted,+-- so we retry until we find a valid element that exists in the set.+readQueue :: Hashable a => OrderedSet a -> STM a+readQueue rs@(OrderedSet que s) = do+                f <- readTQueue que+                b <- S.lookup f s+                -- retry if no files are left in the queue+                if b then return f else readQueue rs++lookup :: Hashable a => a -> OrderedSet a -> STM Bool+lookup a (OrderedSet _ s) = S.lookup a s++-- | Delete an element from the set.+-- The queue is not modified directly; stale entries are filtered out lazily+-- during reading operations (see 'readQueue').+delete :: Hashable a => a -> OrderedSet a -> STM ()+delete a (OrderedSet _ s) = S.delete a s++toHashSet :: Hashable a => OrderedSet a -> STM (Data.HashSet.HashSet a)+toHashSet (OrderedSet _ s) = Data.HashSet.fromList <$> LT.toList (S.listT s)
− session-loader/Development/IDE/Session/VersionCheck.hs 
@@ -1,15 +0,0 @@-{-# 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           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--ghcVersionChecker :: GhcVersionChecker-ghcVersionChecker = $$(makeGhcVersionChecker (return GHC.Paths.libdir))
src/Development/IDE.hs view
@@ -10,7 +10,9 @@                                                              getDefinition,                                                              getTypeDefinition) import           Development.IDE.Core.FileExists       as X (getFileExists)-import           Development.IDE.Core.FileStore        as X (getFileContents)+import           Development.IDE.Core.FileStore        as X (getFileContents,+                                                             getFileModTimeContents,+                                                             getUriContents) import           Development.IDE.Core.IdeConfiguration as X (IdeConfiguration (..),                                                              isWorkspaceFile) import           Development.IDE.Core.OfInterest       as X (getFilesOfInterestUntracked)@@ -31,7 +33,7 @@                                                              defineNoDiagnostics,                                                              getClientConfig,                                                              getPluginConfigAction,-                                                             ideLogger,+                                                             ideLogger, rootDir,                                                              runIdeAction,                                                              shakeExtras, use,                                                              useNoFile,@@ -50,7 +52,6 @@ import           Development.IDE.Plugin                as X import           Development.IDE.Types.Diagnostics     as X import           Development.IDE.Types.HscEnvEq        as X (HscEnvEq (..),-                                                             hscEnv,-                                                             hscEnvWithImportPaths)+                                                             hscEnv) import           Development.IDE.Types.Location        as X import           Ide.Logger                            as X
src/Development/IDE/Core/Actions.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE RankNTypes   #-} {-# LANGUAGE TypeFamilies #-} module Development.IDE.Core.Actions ( getAtPoint , getDefinition , getTypeDefinition+, getImplementationDefinition , highlightAtPoint , refsAtPoint , workspaceSymbols@@ -17,36 +17,26 @@ import           Data.Maybe import qualified Data.Text                            as T import           Data.Tuple.Extra+import           Development.IDE.Core.LookupMod       (lookupMod) import           Development.IDE.Core.OfInterest import           Development.IDE.Core.PluginUtils 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           hiding (writeHieFile)+import           Development.IDE.GHC.Compat           (DynFlags (..),+                                                       ms_hspp_opts) import           Development.IDE.Graph import qualified Development.IDE.Spans.AtPoint        as AtPoint import           Development.IDE.Types.HscEnvEq       (hscEnv) import           Development.IDE.Types.Location+import           GHC.Iface.Ext.Types                  (Identifier) import qualified HieDb import           Language.LSP.Protocol.Types          (DocumentHighlight (..),                                                        SymbolInformation (..),                                                        normalizedFilePathToUri,                                                        uriToNormalizedFilePath) ---- | 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-  -> Unit-  -> Bool -- ^ Is this file a boot file?-  -> MaybeT IdeAction Uri-lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing-- -- IMPORTANT NOTE : make sure all rules `useWithStaleFastMT`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@@ -61,62 +51,80 @@   opts <- liftIO $ getIdeOptionsIO ide    (hf, mapping) <- useWithStaleFastMT GetHieAst file+  shakeExtras <- lift askShake+   env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file-  dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file)+  modSummary <- fst <$> useWithStaleFastMT GetModSummary file+  dkMap <- lift $ maybe (DKMap mempty mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file)+  let enabledExtensions = extensionFlags (ms_hspp_opts (msrModSummary modSummary))    !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)-  MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf dkMap env pos' --- | For each Location, determine if we have the PositionMapping--- for the correct file. If not, get the correct position mapping--- and then apply the position mapping to the location.-toCurrentLocations+  MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$>+    AtPoint.atPoint opts shakeExtras hf dkMap env pos' enabledExtensions++-- | Converts locations in the source code to their current positions,+-- taking into account changes that may have occurred due to edits.+toCurrentLocation   :: PositionMapping   -> NormalizedFilePath-  -> [Location]-  -> IdeAction [Location]-toCurrentLocations mapping file = mapMaybeM go+  -> Location+  -> IdeAction (Maybe Location)+toCurrentLocation mapping file (Location uri range) =+  -- The Location we are going to might be in a different+  -- file than the one we are calling gotoDefinition from.+  -- So we check that the location file matches the file+  -- we are in.+  if nUri == normalizedFilePathToUri file+  -- The Location matches the file, so use the PositionMapping+  -- we have.+  then pure $ Location uri <$> toCurrentRange mapping range+  -- The Location does not match the file, so get the correct+  -- PositionMapping and use that instead.+  else do+    otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do+      otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri+      useWithStaleFastMT GetHieAst otherLocationFile+    pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping)   where-    go :: Location -> IdeAction (Maybe Location)-    go (Location uri range) =-      -- The Location we are going to might be in a different-      -- file than the one we are calling gotoDefinition from.-      -- So we check that the location file matches the file-      -- we are in.-      if nUri == normalizedFilePathToUri file-      -- The Location matches the file, so use the PositionMapping-      -- we have.-      then pure $ Location uri <$> toCurrentRange mapping range-      -- The Location does not match the file, so get the correct-      -- PositionMapping and use that instead.-      else do-        otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do-          otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri-          useWithStaleFastMT GetHieAst otherLocationFile-        pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping)-      where-        nUri :: NormalizedUri-        nUri = toNormalizedUri uri+    nUri :: NormalizedUri+    nUri = toNormalizedUri uri  -- | Goto Definition.-getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])+getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, Identifier)]) getDefinition file pos = runMaybeT $ do     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask     opts <- liftIO $ getIdeOptionsIO ide-    (HAR _ hf _ _ _, mapping) <- useWithStaleFastMT GetHieAst file+    (hf, mapping) <- useWithStaleFastMT GetHieAst file     (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file     !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)-    locations <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'-    MaybeT $ Just <$> toCurrentLocations mapping file locations+    locationsWithIdentifier <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'+    mapMaybeM (\(location, identifier) -> do+      fixedLocation <- MaybeT $ toCurrentLocation mapping file location+      pure $ Just (fixedLocation, identifier)+      ) locationsWithIdentifier -getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])++getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, Identifier)]) getTypeDefinition file pos = runMaybeT $ do     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask     opts <- liftIO $ getIdeOptionsIO ide     (hf, mapping) <- useWithStaleFastMT GetHieAst file     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)-    locations <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos'-    MaybeT $ Just <$> toCurrentLocations mapping file locations+    locationsWithIdentifier <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos'+    mapMaybeM (\(location, identifier) -> do+      fixedLocation <- MaybeT $ toCurrentLocation mapping file location+      pure $ Just (fixedLocation, identifier)+      ) locationsWithIdentifier++getImplementationDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])+getImplementationDefinition file pos = runMaybeT $ do+    ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask+    opts <- liftIO $ getIdeOptionsIO ide+    (hf, mapping) <- useWithStaleFastMT GetHieAst file+    !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)+    locs <- AtPoint.gotoImplementation withHieDb (lookupMod hiedbWriter) opts hf pos'+    traverse (MaybeT . toCurrentLocation mapping file) locs  highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight]) highlightAtPoint file pos = runMaybeT $ do
src/Development/IDE/Core/Compile.hs view
@@ -1,1766 +1,1800 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP        #-}-{-# LANGUAGE GADTs      #-}-{-# LANGUAGE RankNTypes #-}---- | 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-  , RecompilationInfo(..)-  , loadModulesHome-  , getDocsBatch-  , lookupName-  , mergeEnvs-  , ml_core_file-  , coreFileToLinkable-  , TypecheckHelpers(..)-  , sourceTypecheck-  , sourceParser-  , shareUsages-  ) where--import           Prelude                           hiding (mod)-import           Control.Monad.IO.Class-import           Control.Concurrent.Extra-import           Control.Concurrent.STM.Stats      hiding (orElse)-import           Control.DeepSeq                   (NFData (..), force,-                                                    rnf)-import           Control.Exception                 (evaluate)-import           Control.Exception.Safe-import           Control.Lens                      hiding (List, (<.>), pre)-import           Control.Monad.Except-import           Control.Monad.Extra-import           Control.Monad.Trans.Except-import qualified Control.Monad.Trans.State.Strict  as S-import           Data.Aeson                        (toJSON)-import           Data.Bifunctor                    (first, second)-import           Data.Binary-import qualified Data.ByteString                   as BS-import           Data.Coerce-import qualified Data.DList                        as DL-import           Data.Functor-import           Data.Generics.Aliases-import           Data.Generics.Schemes-import qualified Data.HashMap.Strict               as HashMap-import           Data.IntMap                       (IntMap)-import           Data.IORef-import           Data.List.Extra-import qualified Data.Map.Strict                   as Map-import           Data.Proxy                        (Proxy(Proxy))-import           Data.Maybe-import qualified Data.Text                         as T-import           Data.Time                         (UTCTime (..))-import           Data.Tuple.Extra                  (dupe)-import           Data.Unique                       as Unique-import           Debug.Trace-import           Development.IDE.Core.FileStore    (resetInterfaceStore)-import           Development.IDE.Core.Preprocessor-import           Development.IDE.Core.RuleTypes-import           Development.IDE.Core.Shake-import           Development.IDE.Core.Tracing      (withTrace)-import           Development.IDE.GHC.Compat        hiding (loadInterface,-                                                    parseHeader, parseModule,-                                                    tcRnModule, writeHieFile)-import qualified Development.IDE.GHC.Compat        as Compat-import qualified Development.IDE.GHC.Compat        as GHC-import qualified Development.IDE.GHC.Compat.Util   as Util-import           Development.IDE.GHC.CoreFile-import           Development.IDE.GHC.Error-import           Development.IDE.GHC.Orphans       ()-import           Development.IDE.GHC.Util-import           Development.IDE.GHC.Warnings-import           Development.IDE.Types.Diagnostics-import           Development.IDE.Types.Location-import           Development.IDE.Types.Options-import           GHC                               (ForeignHValue,-                                                    GetDocsFailure (..),-                                                    parsedSource)-import qualified GHC.LanguageExtensions            as LangExt-import           GHC.Serialized-import           HieDb                             hiding (withHieDb)-import qualified Language.LSP.Server               as LSP-import           Language.LSP.Protocol.Types                (DiagnosticTag (..))-import qualified Language.LSP.Protocol.Types                as LSP-import qualified Language.LSP.Protocol.Message            as LSP-import           System.Directory-import           System.FilePath-import           System.IO.Extra                   (fixIO, newTempFileWithin)---- See Note [Guidelines For Using CPP In GHCIDE Import Statements]--import           GHC.Tc.Gen.Splice----import qualified GHC                               as G--#if !MIN_VERSION_ghc(9,3,0)-import           GHC                               (ModuleGraph)-#endif--import           GHC.Types.ForeignStubs-import           GHC.Types.HpcInfo-import           GHC.Types.TypeEnv--#if !MIN_VERSION_ghc(9,3,0)-import           Data.Map                          (Map)-import           GHC                               (GhcException (..))-import           Unsafe.Coerce-#endif--#if MIN_VERSION_ghc(9,3,0)-import qualified Data.Set                          as Set-#endif--#if MIN_VERSION_ghc(9,5,0)-import           GHC.Driver.Config.CoreToStg.Prep-import           GHC.Core.Lint.Interactive-#endif--#if MIN_VERSION_ghc(9,7,0)-import           Data.Foldable                     (toList)-import           GHC.Unit.Module.Warnings-#else-import           Development.IDE.Core.FileStore    (shareFilePath)-#endif----Simple constants to make sure the source is consistently named-sourceTypecheck :: T.Text-sourceTypecheck = "typecheck"-sourceParser :: T.Text-sourceParser = "parser"---- | 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-    -> Unit-    -> IO (Either [FileDiagnostic] [UnitId])-computePackageDeps env pkg = do-    case lookupUnit env pkg of-        Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $-            T.pack $ "unknown package: " ++ show pkg]-        Just pkgInfo -> return $ Right $ unitDepends pkgInfo--newtype TypecheckHelpers-  = TypecheckHelpers-  { getLinkables       :: [NormalizedFilePath] -> IO [LinkableResult] -- ^ hls-graph action to get linkables for files-  }--typecheckModule :: IdeDefer-                -> HscEnv-                -> TypecheckHelpers-                -> ParsedModule-                -> IO (IdeResult TcModuleResult)-typecheckModule (IdeDefer defer) hsc tc_helpers pm = do-        let modSummary = pm_mod_summary pm-            dflags = ms_hspp_opts modSummary-        initialized <- catchSrcErrors (hsc_dflags hsc) "typecheck (initialize plugins)"-                                      (initPlugins hsc modSummary)-        case initialized of-          Left errs -> return (errs, Nothing)-          Right (modSummary', hscEnv) -> do-            (warnings, etcm) <- withWarnings sourceTypecheck $ \tweak ->-                let-                  session = tweak (hscSetFlags dflags hscEnv)-                   -- TODO: maybe settings ms_hspp_opts is unnecessary?-                  mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session}-                in-                  catchSrcErrors (hsc_dflags hscEnv) sourceTypecheck $ do-                    tcRnModule session tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary''}-            let errorPipeline = unDefer . hideDiag dflags . tagDiag-                diags = map errorPipeline warnings-                deferredError = any fst diags-            case etcm of-              Left errs -> return (map snd diags ++ errs, Nothing)-              Right tcm -> return (map snd diags, Just $ tcm{tmrDeferredError = deferredError})-    where-        demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id---- | Install hooks to capture the splices as well as the runtime module dependencies-captureSplicesAndDeps :: TypecheckHelpers -> HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, ModuleEnv BS.ByteString)-captureSplicesAndDeps TypecheckHelpers{..} env k = do-  splice_ref <- newIORef mempty-  dep_ref <- newIORef emptyModuleEnv-  res <- k (hscSetHooks (addSpliceHook splice_ref . addLinkableDepHook dep_ref $ hsc_hooks env) env)-  splices <- readIORef splice_ref-  needed_mods <- readIORef dep_ref-  return (res, splices, needed_mods)-  where-    addLinkableDepHook :: IORef (ModuleEnv BS.ByteString) -> Hooks -> Hooks-    addLinkableDepHook var h = h { hscCompileCoreExprHook = Just (compile_bco_hook var) }--    -- We want to record exactly which linkables/modules the typechecker needed at runtime-    -- This is useful for recompilation checking.-    -- See Note [Recompilation avoidance in the presence of TH]-    ---    -- From hscCompileCoreExpr' in GHC-    -- To update, copy hscCompileCoreExpr' (the implementation of-    -- hscCompileCoreExprHook) verbatim, and add code to extract all the free-    -- names in the compiled bytecode, recording the modules that those names-    -- come from in the IORef,, as these are the modules on whose implementation-    -- we depend.-    compile_bco_hook :: IORef (ModuleEnv BS.ByteString) -> HscEnv -> SrcSpan -> CoreExpr-#if MIN_VERSION_ghc(9,3,0)-                     -> IO (ForeignHValue, [Linkable], PkgsLoaded)-#else-                     -> IO ForeignHValue-#endif-    compile_bco_hook var hsc_env srcspan ds_expr-      = do { let dflags = hsc_dflags hsc_env--             {- Simplify it -}-           ; simpl_expr <- simplifyExpr dflags hsc_env ds_expr--             {- Tidy it (temporary, until coreSat does cloning) -}-           ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr--             {- Prepare for codegen -}-           ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr--             {- Lint if necessary -}-           ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr---           ; let iNTERACTIVELoc = G.ModLocation{ ml_hs_file   = Nothing,-                                        ml_hi_file   = panic "hscCompileCoreExpr':ml_hi_file",-                                        ml_obj_file  = panic "hscCompileCoreExpr':ml_obj_file",-#if MIN_VERSION_ghc(9,3,0)-                                        ml_dyn_obj_file = panic "hscCompileCoreExpr':ml_dyn_obj_file",-                                        ml_dyn_hi_file  = panic "hscCompileCoreExpr':ml_dyn_hi_file",-#endif-                                        ml_hie_file  = panic "hscCompileCoreExpr':ml_hie_file"-                                        }-           ; let ictxt = hsc_IC hsc_env--           ; (binding_id, stg_expr, _, _) <--               myCoreToStgExpr (hsc_logger hsc_env)-                               (hsc_dflags hsc_env)-                               ictxt-#if MIN_VERSION_ghc(9,3,0)-                               True -- for bytecode-#endif-                               (icInteractiveModule ictxt)-                               iNTERACTIVELoc-                               prepd_expr--             {- Convert to BCOs -}-           ; bcos <- byteCodeGen hsc_env-                       (icInteractiveModule ictxt)-                       stg_expr-                       [] Nothing--            -- Exclude wired-in names because we may not have read-            -- their interface files, so getLinkDeps will fail-            -- All wired-in names are in the base package, which we link-            -- by default, so we can safely ignore them here.--            -- Find the linkables for the modules we need-           ; let needed_mods = mkUniqSet [-#if MIN_VERSION_ghc(9,3,0)-                                           mod -- We need the whole module for 9.4 because of multiple home units modules may have different unit ids-#else-                                           moduleName mod -- On <= 9.2, just the name is enough because all unit ids will be the same-#endif--                                         | n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos-                                         , Just mod <- [nameModule_maybe n] -- Names from other modules-                                         , not (isWiredInName n) -- Exclude wired-in names-                                         , moduleUnitId mod `elem` home_unit_ids -- Only care about stuff from the home package set-                                         ]-                 home_unit_ids =-#if MIN_VERSION_ghc(9,3,0)-                    map fst (hugElts $ hsc_HUG hsc_env)-#else-                    [homeUnitId_ dflags]-#endif-                 mods_transitive = getTransitiveMods hsc_env needed_mods--                 -- If we don't support multiple home units, ModuleNames are sufficient because all the units will be the same-                 mods_transitive_list =-#if MIN_VERSION_ghc(9,3,0)-                                         mapMaybe nodeKeyToInstalledModule $ Set.toList mods_transitive-#else-                                        -- Non det OK as we will put it into maps later anyway-                                         map (Compat.installedModule (homeUnitId_ dflags)) $ nonDetEltsUniqSet mods_transitive-#endif--#if MIN_VERSION_ghc(9,3,0)-           ; moduleLocs <- readIORef (fcModuleCache $ hsc_FC hsc_env)-#else-           ; moduleLocs <- readIORef (hsc_FC hsc_env)-#endif-           ; lbs <- getLinkables [toNormalizedFilePath' file-                                 | installedMod <- mods_transitive_list-                                 , let ifr = fromJust $ lookupInstalledModuleEnv moduleLocs installedMod-                                       file = case ifr of-                                         InstalledFound loc _ ->-                                           fromJust $ ml_hs_file loc-                                         _ -> panic "hscCompileCoreExprHook: module not found"-                                 ]-           ; let hsc_env' = loadModulesHome (map linkableHomeMod lbs) hsc_env--#if MIN_VERSION_ghc(9,3,0)-             {- load it -}-           ; (fv_hvs, lbss, pkgs) <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos-           ; let hval = ((expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs), lbss, pkgs)-#else-             {- load it -}-           ; fv_hvs <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos-           ; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs)-#endif--           ; modifyIORef' var (flip extendModuleEnvList [(mi_module $ hm_iface hm, linkableHash lb) | lb <- lbs, let hm = linkableHomeMod lb])-           ; return hval }--#if MIN_VERSION_ghc(9,3,0)-    -- TODO: support backpack-    nodeKeyToInstalledModule :: NodeKey -> Maybe InstalledModule-    -- We shouldn't get boot files here, but to be safe, never map them to an installed module-    -- because boot files don't have linkables we can load, and we will fail if we try to look-    -- for them-    nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = Nothing-    nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB moduleName _) uid)) = Just $ mkModule uid moduleName-    nodeKeyToInstalledModule _ = Nothing-    moduleToNodeKey :: Module -> NodeKey-    moduleToNodeKey mod = NodeKey_Module $ ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnitId mod)-#endif--    -- Compute the transitive set of linkables required-    getTransitiveMods hsc_env needed_mods-#if MIN_VERSION_ghc(9,3,0)-      = Set.unions (Set.fromList (map moduleToNodeKey mods) : [ dep | m <- mods-                                                              , Just dep <- [Map.lookup (moduleToNodeKey m) (mgTransDeps (hsc_mod_graph hsc_env))]-                                                              ])-      where mods = nonDetEltsUniqSet needed_mods -- OK because we put them into a set immediately after-#else-      = go emptyUniqSet needed_mods-      where-        hpt = hsc_HPT hsc_env-        go seen new-          | isEmptyUniqSet new = seen-          | otherwise = go seen' new'-            where-              seen' = seen `unionUniqSets` new-              new'  = new_deps `minusUniqSet` seen'-              new_deps = unionManyUniqSets [ mkUniqSet $ getDependentMods $ hm_iface mod_info-                                           | mod_info <- eltsUDFM $ udfmIntersectUFM hpt (getUniqSet new)]-#endif--    -- | Add a Hook to the DynFlags which captures and returns the-    -- typechecked splices before they are run. This information-    -- is used for hover.-    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-  -> TypecheckHelpers -- ^ Program linkables not to unload-  -> ParsedModule-  -> IO TcModuleResult-tcRnModule hsc_env tc_helpers pmod = do-  let ms = pm_mod_summary pmod-      hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env--  ((tc_gbl_env', mrn_info), splices, mod_env)-      <- captureSplicesAndDeps tc_helpers hsc_env_tmp $ \hscEnvTmp ->-             do  hscTypecheckRename hscEnvTmp 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"--      -- Serialize mod_env so we can read it from the interface-      mod_env_anns = map (\(mod, hash) -> Annotation (ModuleTarget mod) $ toSerialized BS.unpack hash)-                         (moduleEnvToList mod_env)-      tc_gbl_env = tc_gbl_env' { tcg_ann_env = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns }-  pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env)----- Note [Clearing mi_globals after generating an iface]--- GHC populates the mi_global field in interfaces for GHCi if we are using the bytecode--- interpreter.--- However, this field is expensive in terms of heap usage, and we don't use it in HLS--- anywhere. So we zero it out.--- The field is not serialized or deserialised from disk, so we don't need to remove it--- while reading an iface from disk, only if we just generated an iface in memory--------- | See https://github.com/haskell/haskell-language-server/issues/3450--- GHC's recompilation avoidance in the presense of TH is less precise than--- HLS. To avoid GHC from pessimising HLS, we filter out certain dependency information--- that we track ourselves. See also Note [Recompilation avoidance in the presence of TH]-filterUsages :: [Usage] -> [Usage]-#if MIN_VERSION_ghc(9,3,0)-filterUsages = filter $ \case UsageHomeModuleInterface{} -> False-                              _ -> True-#else-filterUsages = id-#endif---- | Mitigation for https://gitlab.haskell.org/ghc/ghc/-/issues/22744--- Important to do this immediately after reading the unit before--- anything else has a chance to read `mi_usages`-shareUsages :: ModIface -> ModIface-shareUsages iface-  = iface--- Fixed upstream in GHC 9.8-#if !MIN_VERSION_ghc(9,7,0)-      {mi_usages = usages}-  where usages = map go (mi_usages iface)-        go usg@UsageFile{} = usg {usg_file_path = fp}-          where !fp = shareFilePath (usg_file_path usg)-        go usg = usg-#endif---mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult-mkHiFileResultNoCompile session tcm = do-  let hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) session-      ms = pm_mod_summary $ tmrParsed tcm-      tcGblEnv = tmrTypechecked tcm-  details <- makeSimpleDetails hsc_env_tmp tcGblEnv-  sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv-  iface' <- mkIfaceTc hsc_env_tmp sf details ms-#if MIN_VERSION_ghc(9,5,0)-                      Nothing-#endif-                      tcGblEnv-  let iface = iface' { mi_globals = Nothing, mi_usages = filterUsages (mi_usages iface') } -- See Note [Clearing mi_globals after generating an iface]-  pure $! mkHiFileResult ms iface details (tmrRuntimeModules tcm) Nothing--mkHiFileResultCompile-    :: ShakeExtras-    -> HscEnv-    -> TcModuleResult-    -> ModGuts-    -> IO (IdeResult HiFileResult)-mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do-  let session = hscSetFlags (ms_hspp_opts ms) session'-      ms = pm_mod_summary $ tmrParsed tcm--  (details, guts) <- do-        -- write core file-        -- give variables unique OccNames-        tidy_opts <- initTidyOpts session-        (guts, details) <- tidyProgram tidy_opts simplified_guts-        pure (details, guts)--  let !partial_iface = force $ mkPartialIface session-#if MIN_VERSION_ghc(9,5,0)-                                              (cg_binds guts)-#endif-                                              details-#if MIN_VERSION_ghc(9,3,0)-                                              ms-#endif-                                              simplified_guts--  final_iface' <- mkFullIface session partial_iface Nothing-#if MIN_VERSION_ghc(9,4,2)-                    Nothing-#endif-  let final_iface = final_iface' {mi_globals = Nothing, mi_usages = filterUsages (mi_usages final_iface')} -- See Note [Clearing mi_globals after generating an iface]--  -- Write the core file now-  core_file <- do-        let core_fp  = ml_core_file $ ms_location ms-            core_file = codeGutsToCoreFile iface_hash guts-            iface_hash = getModuleHash final_iface-        core_hash1 <- atomicFileWrite se core_fp $ \fp ->-          writeBinCoreFile fp core_file-        -- We want to drop references to guts and read in a serialized, compact version-        -- of the core file from disk (as it is deserialised lazily)-        -- This is because we don't want to keep the guts in memory for every file in-        -- the project as it becomes prohibitively expensive-        -- The serialized file however is much more compact and only requires a few-        -- hundred megabytes of memory total even in a large project with 1000s of-        -- modules-        (coreFile, !core_hash2) <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp-        pure $ assert (core_hash1 == core_hash2)-             $ Just (coreFile, fingerprintToBS core_hash2)--  -- Verify core file by roundtrip testing and comparison-  IdeOptions{optVerifyCoreFile} <- getIdeOptionsIO se-  case core_file of-    Just (core, _) | optVerifyCoreFile -> do-      let core_fp = ml_core_file $ ms_location ms-      traceIO $ "Verifying " ++ core_fp-      let CgGuts{cg_binds = unprep_binds, cg_tycons = tycons } = guts-          mod = ms_mod ms-          data_tycons = filter isDataTyCon tycons-      CgGuts{cg_binds = unprep_binds'} <- coreFileToCgGuts session final_iface details core--#if MIN_VERSION_ghc(9,5,0)-      cp_cfg <- initCorePrepConfig session-#endif--      let corePrep = corePrepPgm-#if MIN_VERSION_ghc(9,5,0)-                       (hsc_logger session) cp_cfg (initCorePrepPgmConfig (hsc_dflags session) (interactiveInScope $ hsc_IC session))-#else-                       session-#endif-                       mod (ms_location ms)--      -- Run corePrep first as we want to test the final version of the program that will-      -- get translated to STG/Bytecode-#if MIN_VERSION_ghc(9,3,0)-      prepd_binds-#else-      (prepd_binds , _)-#endif-        <- corePrep unprep_binds data_tycons-#if MIN_VERSION_ghc(9,3,0)-      prepd_binds'-#else-      (prepd_binds', _)-#endif-        <- corePrep unprep_binds' data_tycons-      let binds  = noUnfoldings $ (map flattenBinds . (:[])) prepd_binds-          binds' = noUnfoldings $ (map flattenBinds . (:[])) prepd_binds'--          -- diffBinds is unreliable, sometimes it goes down the wrong track.-          -- This fixes the order of the bindings so that it is less likely to do so.-          diffs2 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go binds binds'-          -- diffs1 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go (map (:[]) $ concat binds) (map (:[]) $ concat binds')-          -- diffs3  = flip S.evalState (mkRnEnv2 emptyInScopeSet) $ go (concat binds) (concat binds')--          diffs = diffs2-          go x y = S.state $ \s -> diffBinds True s x y--          -- The roundtrip doesn't preserver OtherUnfolding or occInfo, but neither are of these-          -- are used for generate core or bytecode, so we can safely ignore them-          -- SYB is slow but fine given that this is only used for testing-          noUnfoldings = everywhere $ mkT $ \v -> if isId v-            then-              let v' = if isOtherUnfolding (realIdUnfolding v) then (setIdUnfolding v noUnfolding) else v-                in setIdOccInfo v' noOccInfo-            else v-          isOtherUnfolding (OtherCon _) = True-          isOtherUnfolding _            = False---      when (not $ null diffs) $-        panicDoc "verify core failed!" (vcat $ punctuate (text "\n\n") diffs) -- ++ [ppr binds , ppr binds']))-    _ -> pure ()--  pure ([], Just $! mkHiFileResult ms final_iface details (tmrRuntimeModules tcm) core_file)--  where-    dflags = hsc_dflags session'-    source = "compile"-    catchErrs x = x `catches`-      [ Handler $ return . (,Nothing) . diagFromGhcException source dflags-      , Handler $ return . (,Nothing) . diagFromString source DiagnosticSeverity_Error (noSpan "<internal>")-      . (("Error during " ++ T.unpack source) ++) . show @SomeException-      ]---- | 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-                 -- Breakpoints don't survive roundtripping from disk-                 -- and this trips up the verify-core-files check-                 -- They may also lead to other problems.-                 -- We have to setBackend ghciBackend in 9.8 as otherwise-                 -- non-exported definitions are stripped out.-                 -- However, setting this means breakpoints are generated.-                 -- Solution: prevent breakpoing generation by unsetting-                 -- Opt_InsertBreakpoints-               let session' = tweak $ flip hscSetFlags session-#if MIN_VERSION_ghc(9,7,0)-                                    $ flip gopt_unset Opt_InsertBreakpoints-                                    $ setBackend ghciBackend-#endif-                                    $ ms_hspp_opts ms-               -- TODO: maybe settings ms_hspp_opts is unnecessary?-               -- MP: the flags in ModSummary should be right, if they are wrong then-               -- the correct place to fix this is when the ModSummary is created.-               desugar <- hscDesugar session' (ms { ms_hspp_opts = hsc_dflags session' }) 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 env' = tweak (hscSetFlags (ms_hspp_opts summary) session)-                          target = platformDefaultBackend (hsc_dflags env')-                          newFlags = setBackend target $ updOptLevel 0 $ setOutputFile-#if MIN_VERSION_ghc(9,3,0)-                              (Just dot_o)-#else-                              dot_o-#endif-                            $ hsc_dflags env'-                          session' = hscSetFlags newFlags session-#if MIN_VERSION_ghc(9,4,2)-                      (outputFilename, _mStub, _foreign_files, _cinfos, _stgcinfos) <- hscGenHardCode session' guts-#else-                      (outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts-#endif-                                (ms_location summary)-                                fp-                      obj <- compileFile session' driverNoStop (outputFilename, Just (As False))-#if MIN_VERSION_ghc(9,3,0)-                      case obj of-                        Nothing -> throwGhcExceptionIO $ Panic "compileFile didn't generate object code"-                        Just x -> pure x-#else-                      return obj-#endif-              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)--newtype CoreFileTime = CoreFileTime UTCTime--generateByteCode :: CoreFileTime -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)-generateByteCode (CoreFileTime time) hscEnv summary guts = do-    fmap (either (, Nothing) (second Just)) $-          catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do-              (warnings, (_, bytecode, sptEntries)) <--                withWarnings "bytecode" $ \_tweak -> do-                      let session = _tweak (hscSetFlags (ms_hspp_opts summary) hscEnv)-                          -- TODO: maybe settings ms_hspp_opts is unnecessary?-                          summary' = summary { ms_hspp_opts = hsc_dflags session }-                      hscInteractive session (mkCgInteractiveGuts guts)-                                (ms_location summary')-              let unlinked = BCOs bytecode sptEntries-              let linkable = LM time (ms_mod summary) [unlinked]-              pure (map snd warnings, linkable)--demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule-demoteTypeErrorsToWarnings =-  (update_pm_mod_summary . update_hspp_opts) demoteTEsToWarns where--  demoteTEsToWarns :: DynFlags -> DynFlags-  -- convert the errors into warnings, and also check the warnings are enabled-  demoteTEsToWarns = (`wopt_set` Opt_WarnDeferredTypeErrors)-                   . (`wopt_set` Opt_WarnTypedHoles)-                   . (`wopt_set` Opt_WarnDeferredOutOfScopeVariables)-                   . (`gopt_set` Opt_DeferTypeErrors)-                   . (`gopt_set` Opt_DeferTypedHoles)-                   . (`gopt_set` Opt_DeferOutOfScopeVariables)--update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary-update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}--update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule-update_pm_mod_summary up pm =-  pm{pm_mod_summary = up $ pm_mod_summary pm}--#if MIN_VERSION_ghc(9,3,0)-unDefer :: (Maybe DiagnosticReason, FileDiagnostic) -> (Bool, FileDiagnostic)-unDefer (Just (WarningWithFlag Opt_WarnDeferredTypeErrors)         , fd) = (True, upgradeWarningToError fd)-unDefer (Just (WarningWithFlag Opt_WarnTypedHoles)                 , fd) = (True, upgradeWarningToError fd)-unDefer (Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables), fd) = (True, upgradeWarningToError fd)-#else-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)-#endif-unDefer ( _                                        , fd) = (False, fd)--upgradeWarningToError :: FileDiagnostic -> FileDiagnostic-upgradeWarningToError (nfp, sh, fd) =-  (nfp, sh, fd{_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message fd}) where-  warn2err :: T.Text -> T.Text-  warn2err = T.intercalate ": error:" . T.splitOn ": warning:"--#if MIN_VERSION_ghc(9,3,0)-hideDiag :: DynFlags -> (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)-hideDiag originalFlags (w@(Just (WarningWithFlag warning)), (nfp, _sh, fd))-#else-hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)-hideDiag originalFlags (w@(Reason warning), (nfp, _sh, fd))-#endif-  | not (wopt warning originalFlags)-  = (w, (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-    , Opt_WarnUnusedRecordWildcards-    , Opt_WarnInaccessibleCode-#if !MIN_VERSION_ghc(9,7,0)-    , Opt_WarnWarningsDeprecations-#endif-    ]---- | Add a unnecessary/deprecated tag to the required diagnostics.-#if MIN_VERSION_ghc(9,3,0)-tagDiag :: (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)-#else-tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)-#endif--#if MIN_VERSION_ghc(9,7,0)-tagDiag (w@(Just (WarningWithCategory cat)), (nfp, sh, fd))-  | cat == defaultWarningCategory -- default warning category is for deprecations-  = (w, (nfp, sh, fd { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags fd) }))-tagDiag (w@(Just (WarningWithFlags warnings)), (nfp, sh, fd))-  | tags <- mapMaybe requiresTag (toList warnings)-  = (w, (nfp, sh, fd { _tags = Just $ tags ++ concat (_tags fd) }))-#elif MIN_VERSION_ghc(9,3,0)-tagDiag (w@(Just (WarningWithFlag warning)), (nfp, sh, fd))-  | Just tag <- requiresTag warning-  = (w, (nfp, sh, fd { _tags = Just $ tag : concat (_tags fd) }))-#else-tagDiag (w@(Reason warning), (nfp, sh, fd))-  | Just tag <- requiresTag warning-  = (w, (nfp, sh, fd { _tags = Just $ tag : concat (_tags fd) }))-#endif-  where-    requiresTag :: WarningFlag -> Maybe DiagnosticTag-#if !MIN_VERSION_ghc(9,7,0)-    -- doesn't exist on 9.8, we use WarningWithCategory instead-    requiresTag Opt_WarnWarningsDeprecations-      = Just DiagnosticTag_Deprecated-#endif-    requiresTag wflag  -- deprecation was already considered above-      | wflag `elem` unnecessaryDeprecationWarningFlags-      = Just DiagnosticTag_Unnecessary-    requiresTag _ = Nothing--- 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}---- | Also resets the interface store-atomicFileWrite :: ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO a-atomicFileWrite se targetPath write = do-  let dir = takeDirectory targetPath-  createDirectoryIfMissing True dir-  (tempFilePath, cleanUp) <- newTempFileWithin dir-  (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)) >> pure x)-    `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 = Util.listToBag (map (mkVarBind unitDataConId) (spliceExpressions $ tmrTopLevelSplices tcm))-        real_binds = tcg_binds $ tmrTypechecked tcm-        ts = tmrTypechecked tcm :: TcGblEnv-        top_ev_binds = tcg_ev_binds ts :: Util.Bag EvBind-        insts = tcg_insts ts :: [ClsInst]-        tcs = tcg_tcs ts :: [TyCon]-    run ts $-#if MIN_VERSION_ghc(9,3,0)-      pure $ Just $-#else-      Just <$>-#endif-          GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs-  where-    dflags = hsc_dflags hscEnv-    run _ts = -- ts is only used in GHC 9.2-#if !MIN_VERSION_ghc(9,3,0)-        fmap (join . snd) . liftIO . initDs hscEnv _ts-#else-        id-#endif--spliceExpressions :: Splices -> [LHsExpr GhcTc]-spliceExpressions 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 notifying 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 -> Util.Fingerprint -> Compat.HieFile -> IO ()-indexHieFile se mod_summary srcPath !hash hf = do- IdeOptions{optProgressStyle} <- getIdeOptionsIO se- atomically $ do-  pending <- readTVar indexPending-  case HashMap.lookup srcPath pending of-    Just pendingHash | pendingHash == hash -> pure () -- An index is already scheduled-    _ -> do-      -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around-      let !hf' = hf{hie_hs_src = mempty}-      modifyTVar' indexPending $ HashMap.insert srcPath hash-      writeTQueue indexQueue $ \withHieDb -> 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-          pendingOps <- readTVar indexPending-          pure $ case HashMap.lookup srcPath pendingOps 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-          -- Using bracket, so even if an exception happen during withHieDb call,-          -- the `post` (which clean the progress indicator) will still be called.-          bracket_ (pre optProgressStyle) post $-            withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf')-  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 style = 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.ProgressToken . LSP.InR . T.pack . show . hashUnique <$> liftIO Unique.newUnique-              -- TODO: Wait for the progress create response to use the token-              _ <- LSP.sendRequest LSP.SMethod_WindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ())-              LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams u $-                toJSON $ LSP.WorkDoneProgressBegin-                  { _kind = LSP.AString @"begin"-                  ,  _title = "Indexing"-                  , _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-        progressFrac :: Double-        progressFrac = fromIntegral done / fromIntegral (done + remaining)-        progressPct :: LSP.UInt-        progressPct = floor $ 100 * progressFrac--      whenJust (lspEnv se) $ \env -> whenJust tok $ \token -> LSP.runLspT env $-        LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams token $-          toJSON $-            case style of-                Percentage -> LSP.WorkDoneProgressReport-                    { _kind = LSP.AString @"report"-                    , _cancellable = Nothing-                    , _message = Nothing-                    , _percentage = Just progressPct-                    }-                Explicit -> LSP.WorkDoneProgressReport-                    { _kind = LSP.AString @"report"-                    , _cancellable = Nothing-                    , _message = Just $-                        T.pack " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..."-                    , _percentage = Nothing-                    }-                NoProgress -> LSP.WorkDoneProgressReport-                  { _kind = LSP.AString @"report"-                  , _cancellable = Nothing-                  , _message = Nothing-                  , _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.SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $-            toJSON $ fromNormalizedFilePath srcPath-      whenJust mdone $ \done ->-        modifyVar_ indexProgressToken $ \tok -> do-          whenJust (lspEnv se) $ \env -> LSP.runLspT env $-            whenJust tok $ \token ->-              LSP.sendNotification LSP.SMethod_Progress  $ LSP.ProgressParams token $-                toJSON $-                LSP.WorkDoneProgressEnd-                  { _kind = LSP.AString @"end"-                  , _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 se targetPath $ flip GHC.writeHieFile hf-    hash <- Util.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 :: ShakeExtras -> HscEnv -> HiFileResult -> IO [FileDiagnostic]-writeHiFile se hscEnv tc =-  handleGenerationErrors dflags "interface write" $ do-    atomicFileWrite se targetPath $ \fp ->-      writeIfaceFile hscEnv fp modIface-  where-    modIface = hirModIface 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 DiagnosticSeverity_Error (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 DiagnosticSeverity_Error (noSpan "<internal>")-    . (("Error during " ++ T.unpack source) ++) . show @SomeException-    ]----- Merge the HPTs, module graphs and FinderCaches--- See Note [GhcSessionDeps] in Development.IDE.Core.Rules--- Add the current ModSummary to the graph, along with the--- HomeModInfo's of all direct dependencies (by induction hypothesis all--- transitive dependencies will be contained in envs)-mergeEnvs :: HscEnv -> ModuleGraph -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv-mergeEnvs env mg ms extraMods envs = do-#if MIN_VERSION_ghc(9,3,0)-    let im  = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))-        ifr = InstalledFound (ms_location ms) im-        curFinderCache = Compat.extendInstalledModuleEnv Compat.emptyInstalledModuleEnv im ifr-    newFinderCache <- concatFC curFinderCache (map hsc_FC envs)-    return $! loadModulesHome extraMods $-      let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in-      (hscUpdateHUG (const newHug) env){-          hsc_FC = newFinderCache,-          hsc_mod_graph = mg-      }--    where-        mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b-        mergeHUE a b = a { homeUnitEnv_hpt = mergeUDFM (homeUnitEnv_hpt a) (homeUnitEnv_hpt b) }-        mergeUDFM = plusUDFM_C combineModules--        combineModules a b-          | HsSrcFile <- mi_hsc_src (hm_iface a) = a-          | otherwise = b--        -- Prefer non-boot files over non-boot files-        -- otherwise we can get errors like https://gitlab.haskell.org/ghc/ghc/-/issues/19816-        -- if a boot file shadows over a non-boot file-        combineModuleLocations a@(InstalledFound ml _) _ | Just fp <- ml_hs_file ml, not ("boot" `isSuffixOf` fp) = a-        combineModuleLocations _ b = b--        concatFC :: FinderCacheState -> [FinderCache] -> IO FinderCache-        concatFC cur xs = do-          fcModules <- mapM (readIORef . fcModuleCache) xs-          fcFiles <- mapM (readIORef . fcFileCache) xs-          fcModules' <- newIORef $! foldl' (plusInstalledModuleEnv combineModuleLocations) cur fcModules-          fcFiles' <- newIORef $! Map.unions fcFiles-          pure $ FinderCache fcModules' fcFiles'--#else-    prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs-    let im  = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))-        ifr = InstalledFound (ms_location ms) im-    newFinderCache <- newIORef $! Compat.extendInstalledModuleEnv prevFinderCache im ifr-    return $! loadModulesHome extraMods $-      env{-          hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs,-          hsc_FC = newFinderCache,-          hsc_mod_graph = mg-      }--    where-        mergeUDFM = plusUDFM_C combineModules-        combineModules a b-          | HsSrcFile <- mi_hsc_src (hm_iface a) = a-          | otherwise = b-    -- required because 'FinderCache':-    --  1) doesn't have a 'Monoid' instance,-    --  2) is abstract and doesn't export constructors-    -- To work around this, we coerce to the underlying type-    -- To remove this, I plan to upstream the missing Monoid instance-        concatFC :: [FinderCache] -> FinderCache-        concatFC = unsafeCoerce (mconcat @(Map InstalledModule InstalledFindResult))-#endif--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 Util.StringBuffer-  -> ExceptT [FileDiagnostic] IO ModSummaryResult--- modTime is only used in GHC < 9.4-getModSummaryFromImports env fp _modTime mContents = do--- src_hash is only used in GHC >= 9.4-    (contents, opts, ppEnv, _src_hash) <- preprocessor env fp mContents--    let dflags = hsc_dflags ppEnv--    -- 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 `Util.orElse` mAIN_NAME--        (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps--        -- GHC.Prim doesn't exist physically, so don't go looking for it.-        -- ghc_prim_imports is only used in GHC >= 9.4-        (ordinary_imps, _ghc_prim_imports)-          = partition ((/= 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) = (-#if !MIN_VERSION_ghc(9,3,0)-                               fmap sl_fs-#endif-                               (ideclPkgQual i)-                             , reLoc $ ideclName i)--        msrImports = implicit_imports ++ imps--#if MIN_VERSION_ghc(9,3,0)-        rn_pkg_qual = renameRawPkgQual (hsc_unit_env ppEnv)-        rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))-        srcImports = rn_imps $ map convImport src_idecls-        textualImports = rn_imps $ map convImport (implicit_imports ++ ordinary_imps)-        ghc_prim_import = not (null _ghc_prim_imports)-#else-        srcImports = map convImport src_idecls-        textualImports = map convImport (implicit_imports ++ ordinary_imps)-#endif---    -- Force bits that might keep the string buffer and DynFlags alive unnecessarily-    liftIO $ evaluate $ rnf srcImports-    liftIO $ evaluate $ rnf textualImports---    modLoc <- liftIO $ if mod == mAIN_NAME-        -- specially in tests it's common to have lots of nameless modules-        -- mkHomeModLocation will map them to the same hi/hie locations-        then mkHomeModLocation dflags (pathToModuleName fp) fp-        else mkHomeModLocation dflags mod fp--    let modl = mkHomeModule (hscHomeUnit ppEnv) mod-        sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile-        msrModSummary2 =-            ModSummary-                { ms_mod          = modl-                , ms_hie_date     = Nothing-#if MIN_VERSION_ghc(9,3,0)-                , ms_dyn_obj_date    = Nothing-                , ms_ghc_prim_import = ghc_prim_import-                , ms_hs_hash      = _src_hash--#else-                , ms_hs_date      = _modTime-#endif-                , ms_hsc_src      = sourceType-                -- The contents are used by the GetModSummary rule-                , ms_hspp_buf     = Just contents-                , ms_hspp_file    = fp-                , ms_hspp_opts    = dflags-                , ms_iface_date   = Nothing-                , ms_location     = withBootSuffix sourceType modLoc-                , ms_obj_date     = Nothing-                , ms_parsed_mod   = Nothing-                , ms_srcimps      = srcImports-                , ms_textual_imps = textualImports-                }--    msrFingerprint <- liftIO $ computeFingerprint opts msrModSummary2-    (msrModSummary, msrHscEnv) <- liftIO $ initPlugins ppEnv msrModSummary2-    return ModSummaryResult{..}-    where-        -- Compute a fingerprint from the contents of `ModSummary`,-        -- eliding the timestamps, the preprocessed source and other non relevant fields-        computeFingerprint opts ModSummary{..} = do-            fingerPrintImports <- fingerprintFromPut $ do-                  put $ Util.uniq $ moduleNameFS $ moduleName ms_mod-                  forM_ (ms_srcimps ++ ms_textual_imps) $ \(mb_p, m) -> do-                    put $ Util.uniq $ moduleNameFS $ unLoc m-#if MIN_VERSION_ghc(9,3,0)-                    case mb_p of-                      G.NoPkgQual -> pure ()-                      G.ThisPkg uid  -> put $ getKey $ getUnique uid-                      G.OtherPkg uid -> put $ getKey $ getUnique uid-#else-                    whenJust mb_p $ put . Util.uniq-#endif-            return $! Util.fingerprintFingerprints $-                    [ Util.fingerprintString fp-                    , fingerPrintImports-                    ] ++ map Util.fingerprintString opts----- | Parse only the module header-parseHeader-       :: Monad m-       => DynFlags -- ^ flags to use-       -> FilePath  -- ^ the filename (for source locations)-       -> Util.StringBuffer -- ^ Haskell module source text (full Unicode is supported)-#if MIN_VERSION_ghc(9,5,0)-       -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs))-#else-       -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule))-#endif-parseHeader dflags filename contents = do-   let loc  = mkRealSrcLoc (Util.mkFastString filename) 1 1-   case unP Compat.parseHeader (initParserState (initParserOpts dflags) contents loc) of-     PFailedWithErrorMessages msgs ->-        throwE $ diagFromErrMsgs sourceParser dflags $ msgs dflags-     POk pst rdr_module -> do-        let (warns, errs) = renderMessages $ getPsMessages 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 sourceParser dflags errs--        let warnings = diagFromErrMsgs sourceParser 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 (Util.mkFastString filename) 1 1-       dflags = ms_hspp_opts ms-       contents = fromJust $ ms_hspp_buf ms-   case unP Compat.parseModule (initParserState (initParserOpts dflags) contents loc) of-     PFailedWithErrorMessages msgs -> throwE $ diagFromErrMsgs sourceParser dflags $ msgs dflags-     POk pst rdr_module ->-         let-             hpm_annotations = mkApiAnns pst-             psMessages = getPsMessages pst dflags-         in-           do-               let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module--               unless (null errs) $-                  throwE $ diagFromStrings sourceParser DiagnosticSeverity_Error errs--               let preproc_warnings = diagFromStrings sourceParser DiagnosticSeverity_Warning preproc_warns-               (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed psMessages-               let (warns, errors) = renderMessages msgs--               -- 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 errors) $-                 throwE $ diagFromErrMsgs sourceParser dflags errors---               -- 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-#if MIN_VERSION_ghc(9,3,0)-                   TempDir tmp_dir = tmpDir dflags-#else-                   tmp_dir = tmpDir dflags-#endif-                   srcs0 = nubOrd $ filter (not . (tmp_dir `isPrefixOf`))-                                  $ filter (/= n_hspp)-                                  $ map normalise-                                  $ filter (not . isPrefixOf "<")-                                  $ map Util.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 ms parsed' srcs2 hpm_annotations-                   warnings = diagFromErrMsgs sourceParser 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---{- Note [Recompilation avoidance in the presence of TH]--Most versions of GHC we currently support don't have a working implementation of-code unloading for object code, and no version of GHC supports this on certain-platforms like Windows. This makes it completely infeasible for interactive use,-as symbols from previous compiles will shadow over all future compiles.--This means that we need to use bytecode when generating code for Template-Haskell. Unfortunately, we can't serialize bytecode, so we will always need-to recompile when the IDE starts. However, we can put in place a much tighter-recompilation avoidance scheme for subsequent compiles:--1. If the source file changes, then we always need to recompile-   a. For files of interest, we will get explicit `textDocument/change` events-   that will let us invalidate our build products-   b. For files we read from disk, we can detect source file changes by-   comparing the `mtime` of the source file with the build product (.hi/.o) file-   on disk.-2. If GHC's recompilation avoidance scheme based on interface file hashes says-   that we need to recompile, the we need to recompile.-3. If the file in question requires code generation then, we need to recompile-   if we don't have the appropriate kind of build products.-   a. If we already have the build products in memory, and the conditions 1 and-   2 above hold, then we don't need to recompile-   b. If we are generating object code, then we can also search for it on-   disk and ensure it is up to date. Notably, we did _not_ previously re-use-   old bytecode from memory when `hls-graph`/`shake` decided to rebuild the-   `HiFileResult` for some reason--4. If the file in question used Template Haskell on the previous compile, then-we need to recompile if any `Linkable` in its transitive closure changed. This-sounds bad, but it is possible to make some improvements. In particular, we only-need to recompile if any of the `Linkable`s actually used during the previous-compile change.--How can we tell if a `Linkable` was actually used while running some TH?--GHC provides a `hscCompileCoreExprHook` which lets us intercept bytecode as-it is being compiled and linked. We can inspect the bytecode to see which-`Linkable` dependencies it requires, and record this for use in-recompilation checking.-We record all the home package modules of the free names that occur in the-bytecode. The `Linkable`s required are then the transitive closure of these-modules in the home-package environment. This is the same scheme as used by-GHC to find the correct things to link in before running bytecode.--This works fine if we already have previous build products in memory, but-what if we are reading an interface from disk? Well, we can smuggle in the-necessary information (linkable `Module`s required as well as the time they-were generated) using `Annotation`s, which provide a somewhat general purpose-way to serialise arbitrary information along with interface files.--Then when deciding whether to recompile, we need to check that the versions-(i.e. hashes) of the linkables used during a previous compile match whatever is-currently in the HPT.--As we always generate Linkables from core files, we use the core file hash-as a (hopefully) deterministic measure of whether the Linkable has changed.-This is better than using the object file hash (if we have one) because object-file generation is not deterministic.--}--data RecompilationInfo m-  = RecompilationInfo-  { source_version :: FileVersion-  , old_value   :: Maybe (HiFileResult, FileVersion)-  , get_file_version :: NormalizedFilePath -> m (Maybe FileVersion)-  , get_linkable_hashes :: [NormalizedFilePath] -> m [BS.ByteString]-  , regenerate  :: Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface-  }---- | Either a regular GHC linkable or a core file that--- can be later turned into a proper linkable-data IdeLinkable = GhcLinkable !Linkable | CoreLinkable !UTCTime !CoreFile--instance NFData IdeLinkable where-  rnf (GhcLinkable lb)      = rnf lb-  rnf (CoreLinkable time _) = rnf time--ml_core_file :: ModLocation -> FilePath-ml_core_file ml = ml_hi_file ml <.> "core"---- | Returns an up-to-date module interface, regenerating if needed.---   Assumes file exists.---   Requires the 'HscEnv' to be set up with dependencies--- See Note [Recompilation avoidance in the presence of TH]-loadInterface-  :: (MonadIO m, MonadMask m)-  => HscEnv-  -> ModSummary-  -> Maybe LinkableType-  -> RecompilationInfo m-  -> m ([FileDiagnostic], Maybe HiFileResult)-loadInterface session ms linkableNeeded RecompilationInfo{..} = do-    let sessionWithMsDynFlags = hscSetFlags (ms_hspp_opts ms) session-        mb_old_iface = hirModIface . fst <$> old_value-        mb_old_version = snd <$> old_value--        core_file = ml_core_file (ms_location ms)-        iface_file = ml_hi_file (ms_location ms)--        !mod = ms_mod ms--    mb_dest_version <- case mb_old_version of-      Just ver -> pure $ Just ver-      Nothing  -> get_file_version (toNormalizedFilePath' iface_file)--    -- The source is modified if it is newer than the destination (iface file)-    -- A more precise check for the core file is performed later-    let _sourceMod = case mb_dest_version of -- sourceMod is only used in GHC < 9.4-          Nothing -> SourceModified -- destination file doesn't exist, assume modified source-          Just dest_version-            | source_version <= dest_version -> SourceUnmodified-            | otherwise -> SourceModified--    -- old_iface is only used in GHC >= 9.4-    _old_iface <- case mb_old_iface of-      Just iface -> pure (Just iface)-      Nothing -> do-        -- ncu and read_dflags are only used in GHC >= 9.4-        let _ncu = hsc_NC sessionWithMsDynFlags-            _read_dflags = hsc_dflags sessionWithMsDynFlags-#if MIN_VERSION_ghc(9,3,0)-        read_result <- liftIO $ readIface _read_dflags _ncu mod iface_file-#else-        read_result <- liftIO $ initIfaceCheck (text "readIface") sessionWithMsDynFlags-                              $ readIface mod iface_file-#endif-        case read_result of-          Util.Failed{} -> return Nothing-          -- important to call `shareUsages` here before checkOldIface-          -- consults `mi_usages`-          Util.Succeeded iface -> return $ Just (shareUsages iface)--    -- If mb_old_iface is nothing then checkOldIface will load it for us-    -- given that the source is unmodified-    (recomp_iface_reqd, mb_checked_iface)-#if MIN_VERSION_ghc(9,3,0)-      <- liftIO $ checkOldIface sessionWithMsDynFlags ms _old_iface >>= \case-        UpToDateItem x -> pure (UpToDate, Just x)-        OutOfDateItem reason x -> pure (NeedsRecompile reason, x)-#else-      <- liftIO $ checkOldIface sessionWithMsDynFlags ms _sourceMod mb_old_iface-#endif--    let do_regenerate _reason = withTrace "regenerate interface" $ \setTag -> do-          setTag "Module" $ moduleNameString $ moduleName mod-          setTag "Reason" $ showReason _reason-          liftIO $ traceMarkerIO $ "regenerate interface " ++ show (moduleNameString $ moduleName mod, showReason _reason)-          regenerate linkableNeeded--    case (mb_checked_iface, recomp_iface_reqd) of-      (Just iface, UpToDate) -> do-             details <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface-             -- parse the runtime dependencies from the annotations-             let runtime_deps-                   | not (mi_used_th iface) = emptyModuleEnv-                   | otherwise = parseRuntimeDeps (md_anns details)-             -- Peform the fine grained recompilation check for TH-             maybe_recomp <- checkLinkableDependencies session get_linkable_hashes runtime_deps-             case maybe_recomp of-               Just msg -> do_regenerate msg-               Nothing-                 | isJust linkableNeeded -> handleErrs $ do-                   (coreFile@CoreFile{cf_iface_hash}, core_hash) <- liftIO $-                     readBinCoreFile (mkUpdater $ hsc_NC session) core_file-                   if cf_iface_hash == getModuleHash iface-                   then return ([], Just $ mkHiFileResult ms iface details runtime_deps (Just (coreFile, fingerprintToBS core_hash)))-                   else do_regenerate (recompBecause "Core file out of date (doesn't match iface hash)")-                 | otherwise -> return ([], Just $ mkHiFileResult ms iface details runtime_deps Nothing)-                 where handleErrs = flip catches-                         [Handler $ \(e :: IOException) -> do_regenerate (recompBecause $ "Reading core file failed (" ++ show e ++ ")")-                         ,Handler $ \(e :: GhcException) -> case e of-                            Signal _ -> throw e-                            Panic _  -> throw e-                            _        -> do_regenerate (recompBecause $ "Reading core file failed (" ++ show e ++ ")")-                         ]-      (_, _reason) -> do_regenerate _reason---- | Find the runtime dependencies by looking at the annotations--- serialized in the iface--- The bytestrings are the hashes of the core files for modules we--- required to run the TH splices in the given module.--- See Note [Recompilation avoidance in the presence of TH]-parseRuntimeDeps :: [ModIfaceAnnotation] -> ModuleEnv BS.ByteString-parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns-  where-    go (Annotation (ModuleTarget mod) payload)-      | Just bs <- fromSerialized BS.pack payload-      = Just (mod, bs)-    go _ = Nothing---- | checkLinkableDependencies compares the core files in the build graph to--- the runtime dependencies of the module, to check if any of them are out of date--- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH--- See Note [Recompilation avoidance in the presence of TH]-checkLinkableDependencies :: MonadIO m => HscEnv -> ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)-checkLinkableDependencies hsc_env get_linkable_hashes runtime_deps = do-#if MIN_VERSION_ghc(9,3,0)-  moduleLocs <- liftIO $ readIORef (fcModuleCache $ hsc_FC hsc_env)-#else-  moduleLocs <- liftIO $ readIORef (hsc_FC hsc_env)-#endif-  let go (mod, hash) = do-        ifr <- lookupInstalledModuleEnv moduleLocs $ Compat.installedModule (toUnitId $ moduleUnit mod) (moduleName mod)-        case ifr of-          InstalledFound loc _ -> do-            hs <- ml_hs_file loc-            pure (toNormalizedFilePath' hs,hash)-          _ -> Nothing-      hs_files = mapM go (moduleEnvToList runtime_deps)-  case hs_files of-    Nothing -> error "invalid module graph"-    Just fs -> do-      store_hashes <- get_linkable_hashes (map fst fs)-      let out_of_date = [core_file | ((core_file, expected_hash), actual_hash) <- zip fs store_hashes, expected_hash /= actual_hash]-      case out_of_date of-        [] -> pure Nothing-        _ -> pure $ Just $ recompBecause-              $ "out of date runtime dependencies: " ++ intercalate ", " (map show out_of_date)--recompBecause :: String -> RecompileRequired-recompBecause =-#if MIN_VERSION_ghc(9,3,0)-                NeedsRecompile .-#endif-                RecompBecause-#if MIN_VERSION_ghc(9,3,0)-              . CustomReason-#endif--#if MIN_VERSION_ghc(9,3,0)-data SourceModified = SourceModified | SourceUnmodified deriving (Eq, Ord, Show)-#endif--showReason :: RecompileRequired -> String-showReason UpToDate          = "UpToDate"-#if MIN_VERSION_ghc(9,3,0)-showReason (NeedsRecompile MustCompile)    = "MustCompile"-showReason (NeedsRecompile s) = printWithoutUniques s-#else-showReason MustCompile       = "MustCompile"-showReason (RecompBecause s) = s-#endif--mkDetailsFromIface :: HscEnv -> ModIface -> IO ModDetails-mkDetailsFromIface session iface = do-  fixIO $ \details -> do-    let !hsc' = hscUpdateHPT (\hpt -> addToHpt hpt (moduleName $ mi_module iface) (HomeModInfo iface details emptyHomeModInfoLinkable)) session-    initIfaceLoad hsc' (typecheckIface iface)--coreFileToCgGuts :: HscEnv -> ModIface -> ModDetails -> CoreFile -> IO CgGuts-coreFileToCgGuts session iface details core_file = do-  let act hpt = addToHpt hpt (moduleName this_mod)-                             (HomeModInfo iface details emptyHomeModInfoLinkable)-      this_mod = mi_module iface-  types_var <- newIORef (md_types details)-  let hsc_env' = hscUpdateHPT act (session {-#if MIN_VERSION_ghc(9,3,0)-        hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])-#else-        hsc_type_env_var = Just (this_mod, types_var)-#endif-        })-  core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckCoreFile this_mod types_var core_file-      -- Implicit binds aren't saved, so we need to regenerate them ourselves.-  let _implicit_binds = concatMap getImplicitBinds tyCons -- only used if GHC < 9.6-      tyCons = typeEnvTyCons (md_types details)-#if MIN_VERSION_ghc(9,5,0)-  -- In GHC 9.6, the implicit binds are tidied and part of core_binds-  pure $ CgGuts this_mod tyCons core_binds [] NoStubs [] mempty (emptyHpcInfo False) Nothing []-#elif MIN_VERSION_ghc(9,3,0)-  pure $ CgGuts this_mod tyCons (_implicit_binds ++ core_binds) [] NoStubs [] mempty (emptyHpcInfo False) Nothing []-#else-  pure $ CgGuts this_mod tyCons (_implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False) Nothing []-#endif--coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> UTCTime -> IO ([FileDiagnostic], Maybe HomeModInfo)-coreFileToLinkable linkableType session ms iface details core_file t = do-  cgi_guts <- coreFileToCgGuts session iface details core_file-  (warns, lb) <- case linkableType of-    BCOLinkable    -> fmap (maybe emptyHomeModInfoLinkable justBytecode) <$> generateByteCode (CoreFileTime t) session ms cgi_guts-    ObjectLinkable -> fmap (maybe emptyHomeModInfoLinkable justObjects) <$> generateObjectCode session ms cgi_guts-  pure (warns, Just $ HomeModInfo iface details lb) -- TODO wz1000 handle emptyHomeModInfoLinkable---- | 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-  -> [Name]-#if MIN_VERSION_ghc(9,3,0)-  -> IO [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]-#else-  -> IO [Either String (Maybe HsDocString, IntMap HsDocString)]-#endif-getDocsBatch hsc_env _names = do-    res <- initIfaceLoad hsc_env $ forM _names $ \name ->-        case nameModule_maybe name of-            Nothing -> return (Left $ NameHasNoModule name)-            Just mod -> do-             ModIface {-#if MIN_VERSION_ghc(9,3,0)-                        mi_docs = Just Docs{ docs_mod_hdr = mb_doc_hdr-                                      , docs_decls = dmap-                                      , docs_args = amap-                                      }-#else-                        mi_doc_hdr = mb_doc_hdr-                      , mi_decl_docs = DeclDocMap dmap-                      , mi_arg_docs = ArgDocMap amap-#endif-                      } <- loadSysInterface (text "getModuleInterface") mod-#if MIN_VERSION_ghc(9,3,0)-             if isNothing mb_doc_hdr && isNullUniqMap dmap && isNullUniqMap amap-#else-             if isNothing mb_doc_hdr && Map.null dmap && null amap-#endif-               then pure (Left (NoDocsInIface mod $ compiled name))-               else pure (Right (-#if MIN_VERSION_ghc(9,3,0)-                                  lookupUniqMap dmap name,-#else-                                  Map.lookup name dmap ,-#endif-#if MIN_VERSION_ghc(9,3,0)-                                  lookupWithDefaultUniqMap amap mempty name))-#else-                                  Map.findWithDefault mempty name amap))-#endif-    return $ map (first $ T.unpack . printOutputable) res-  where-    compiled n =-      -- TODO: Find a more direct indicator.-      case nameSrcLoc n of-        RealSrcLoc {}   -> False-        UnhelpfulLoc {} -> True---- | 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-           -> Name-           -> IO (Maybe TyThing)-lookupName _ name-  | Nothing <- nameModule_maybe name = pure Nothing-lookupName hsc_env name = exceptionHandle $ do-  mb_thing <- liftIO $ lookupType hsc_env name-  case mb_thing of-    x@(Just _) -> return x-    Nothing-      | x@(Just thing) <- wiredInNameTyThing_maybe name-      -> do when (needWiredInHomeIface thing)-                 (initIfaceLoad hsc_env (loadWiredInHomeIface name))-            return x-      | otherwise -> do-        res <- initIfaceLoad hsc_env $ importDecl name-        case res of-          Util.Succeeded x -> return (Just x)-          _ -> return Nothing-  where-    exceptionHandle x = x `catch` \(_ :: IOEnvFailure) -> pure Nothing--pathToModuleName :: FilePath -> ModuleName-pathToModuleName = mkModuleName . map rep-  where-      rep c | isPathSeparator c = '_'-      rep ':' = '_'-      rep c = c--{- Note [Guidelines For Using CPP In GHCIDE Import Statements]-  GHCIDE's interface with GHC is extensive, and unfortunately, because we have-  to work with multiple versions of GHC, we have several files that need to use-  a lot of CPP. In order to simplify the CPP in the import section of every file-  we have a few specific guidelines for using CPP in these sections.--  - We don't want to nest CPP clauses, nor do we want to use else clauses. Both-  nesting and else clauses end up drastically complicating the code, and require-  significant mental stack to unwind.--  - CPP clauses should be placed at the end of the imports section. The clauses-  should be ordered by the GHC version they target from earlier to later versions,-  with negative if clauses coming before positive if clauses of the same -  version. (If you think about which GHC version a clause activates for this -  should make sense `!MIN_VERSION_GHC(9,0,0)` refers to 8.10 and lower which is-  a earlier version than `MIN_VERSION_GHC(9,0,0)` which refers to versions 9.0 -  and later). In addition there should be a space before and after each CPP-  clause.--  - In if clauses that use `&&` and depend on more than one statement, the -  positive statement should come before the negative statement. In addition the-  clause should come after the single positive clause for that GHC version.--  - There shouldn't be multiple identical CPP statements. The use of odd or even -  GHC numbers is identical, with the only preference being to use what is-  already there. (i.e. (`MIN_VERSION_GHC(9,2,0)` and `MIN_VERSION_GHC(9,1,0)` +{-# LANGUAGE CPP   #-}+{-# LANGUAGE GADTs #-}++-- | 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+  , RecompilationInfo(..)+  , loadModulesHome+  , getDocsBatch+  , lookupName+  , mergeEnvs+  , ml_core_file+  , coreFileToLinkable+  , TypecheckHelpers(..)+  , sourceTypecheck+  , sourceParser+  , shareUsages+  , setNonHomeFCHook+  ) where++import           Control.Concurrent.STM.Stats                 hiding (orElse)+import           Control.DeepSeq                              (NFData (..),+                                                               force, rnf)+import           Control.Exception                            (evaluate)+import           Control.Exception.Safe+import           Control.Lens                                 hiding (List, pre,+                                                               (<.>))+import           Control.Monad.Extra+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Except+import qualified Control.Monad.Trans.State.Strict             as S+import           Data.Aeson                                   (toJSON)+import           Data.Bifunctor                               (first, second)+import           Data.Binary+import qualified Data.ByteString                              as BS+import           Data.Coerce+import qualified Data.DList                                   as DL+import           Data.Functor+import           Data.Generics.Aliases+import           Data.Generics.Schemes+import qualified Data.HashMap.Strict                          as HashMap+import           Data.IntMap                                  (IntMap)+import           Data.IORef+import           Data.List.Extra+import qualified Data.Map.Strict                              as Map+import           Data.Maybe+import           Data.Proxy                                   (Proxy (Proxy))+import qualified Data.Text                                    as T+import           Data.Time                                    (UTCTime (..))+import           Data.Tuple.Extra                             (dupe)+import           Debug.Trace+import           Development.IDE.Core.FileStore               (resetInterfaceStore)+import           Development.IDE.Core.Preprocessor+import           Development.IDE.Core.ProgressReporting       (progressUpdate)+import           Development.IDE.Core.RuleTypes+import           Development.IDE.Core.Shake+import           Development.IDE.Core.WorkerThread            (writeTaskQueue)+import           Development.IDE.Core.Tracing                 (withTrace)+import qualified Development.IDE.GHC.Compat                   as Compat+import qualified Development.IDE.GHC.Compat                   as GHC+import           Development.IDE.GHC.Compat.Driver            (hscTypecheckRenameWithDiagnostics)+import qualified Development.IDE.GHC.Compat.Util              as Util+import           Development.IDE.GHC.CoreFile+import           Development.IDE.GHC.Error+import           Development.IDE.GHC.Orphans                  ()+import           Development.IDE.GHC.Util+import           Development.IDE.GHC.Warnings+import           Development.IDE.Import.DependencyInformation+import           Development.IDE.Types.Diagnostics+import           Development.IDE.Types.Location+import           Development.IDE.Types.Options+import           GHC                                          (ForeignHValue,+                                                               GetDocsFailure (..),+                                                               ModLocation (..),+                                                               parsedSource)+import qualified GHC.LanguageExtensions                       as LangExt+import           GHC.Serialized+import           HieDb                                        hiding (withHieDb)+import qualified Language.LSP.Protocol.Message                as LSP+import           Language.LSP.Protocol.Types                  (DiagnosticTag (..))+import qualified Language.LSP.Server                          as LSP+import           Prelude                                      hiding (mod)+import           System.Directory+import           System.FilePath+import           System.IO.Extra                              (fixIO,+                                                               newTempFileWithin)++import qualified Data.Set                                     as Set+import qualified GHC                                          as G+import           GHC.Core.Lint.Interactive+import           GHC.Driver.Config.CoreToStg.Prep+import           GHC.Iface.Ext.Types                          (HieASTs)+import qualified GHC.Runtime.Loader                           as Loader+import           GHC.Tc.Gen.Splice+import           GHC.Types.Error+import           GHC.Types.ForeignStubs+import           GHC.Types.HpcInfo+import           GHC.Types.TypeEnv++-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if MIN_VERSION_ghc(9,7,0)+import           Data.Foldable                                (toList)+import           GHC.Unit.Module.Warnings+#else+import           Development.IDE.Core.FileStore               (shareFilePath)+#endif++#if MIN_VERSION_ghc(9,10,0)+import           Development.IDE.GHC.Compat                   hiding (assert,+                                                               loadInterface,+                                                               parseHeader,+                                                               parseModule,+                                                               tcRnModule,+                                                               writeHieFile)+#else+import           Development.IDE.GHC.Compat                   hiding+                                                              (loadInterface,+                                                               parseHeader,+                                                               parseModule,+                                                               tcRnModule,+                                                               writeHieFile)+#endif++#if MIN_VERSION_ghc(9,11,0)+import qualified Data.List.NonEmpty                           as NE+import           Data.Time                                    (getCurrentTime)+import           GHC.Driver.Env                               (hsc_all_home_unit_ids)+import           GHC.Iface.Ext.Types                          (NameEntityInfo)+#endif++#if MIN_VERSION_ghc(9,13,0)+import           GHC.Driver.Env                               (hscInsertHPT, setModuleGraph)+import           GHC.Unit.Home.Graph                          (UnitEnvGraph(..), unitEnv_assocs)+import           GHC.Unit.Home.PackageTable                   (hptInternalTableRef, hptInternalTableFromRef)+import           GHC.Unit.Module.ModIface                     (IfaceTopEnv(..))+import           GHC.Types.Avail                              (emptyDetOrdAvails)+import           GHC.Types.Basic                              (ImportLevel(..), convImportLevel)+#endif++#if MIN_VERSION_ghc(9,12,0)+import           Development.IDE.Import.FindImports+#endif++--Simple constants to make sure the source is consistently named+sourceTypecheck :: T.Text+sourceTypecheck = "typecheck"+sourceParser :: T.Text+sourceParser = "parser"++-- | 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+    -> Unit+    -> IO (Either [FileDiagnostic] [UnitId])+computePackageDeps env pkg = do+    case lookupUnit env pkg of+        Nothing ->+          return $ Left+            [ ideErrorText+                (toNormalizedFilePath' noFilePath)+                (T.pack $ "unknown package: " ++ show pkg)+            ]+        Just pkgInfo -> return $ Right $ unitDepends pkgInfo++data TypecheckHelpers+  = TypecheckHelpers+  { getLinkables   :: [NormalizedFilePath] -> IO [LinkableResult] -- ^ hls-graph action to get linkables for files+  , getModuleGraph :: IO DependencyInformation+  }++typecheckModule :: IdeDefer+                -> HscEnv+                -> TypecheckHelpers+                -> ParsedModule+                -> IO (IdeResult TcModuleResult)+typecheckModule (IdeDefer defer) hsc tc_helpers pm = do+        let modSummary = pm_mod_summary pm+            dflags = ms_hspp_opts modSummary+        initialized <- catchSrcErrors (hsc_dflags hsc) "typecheck (initialize plugins)"+                                      (Loader.initializePlugins (hscSetFlags (ms_hspp_opts modSummary) hsc))+        case initialized of+          Left errs -> return (errs, Nothing)+          Right hscEnv -> do+            etcm <-+                let+                   -- TODO: maybe setting ms_hspp_opts is unnecessary?+                  mod_summary' = modSummary { ms_hspp_opts = hsc_dflags hscEnv}+                in+                  catchSrcErrors (hsc_dflags hscEnv) sourceTypecheck $ do+                    tcRnModule hscEnv tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary'}+            case etcm of+              Left errs -> return (errs, Nothing)+              Right tcm ->+                let addReason diag =+                      map (Just (diagnosticReason (errMsgDiagnostic diag)),) $+                        diagFromErrMsg sourceTypecheck (hsc_dflags hscEnv) diag+                    errorPipeline = map (unDefer . hideDiag dflags . tagDiag) . addReason+                    diags = concatMap errorPipeline $ Compat.getMessages $ tmrWarnings tcm+                    deferredError = any fst diags+                in+                return (map snd diags, Just $ tcm{tmrDeferredError = deferredError})+    where+        demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id++-- | Install hooks to capture the splices as well as the runtime module dependencies+captureSplicesAndDeps :: TypecheckHelpers -> HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, ModuleEnv BS.ByteString)+captureSplicesAndDeps TypecheckHelpers{..} env k = do+  splice_ref <- newIORef mempty+  dep_ref <- newIORef emptyModuleEnv+  res <- k (hscSetHooks (addSpliceHook splice_ref . addLinkableDepHook dep_ref $ hsc_hooks env) env)+  splices <- readIORef splice_ref+  needed_mods <- readIORef dep_ref+  return (res, splices, needed_mods)+  where+    addLinkableDepHook :: IORef (ModuleEnv BS.ByteString) -> Hooks -> Hooks+    addLinkableDepHook var h = h { hscCompileCoreExprHook = Just (compile_bco_hook var) }++    -- We want to record exactly which linkables/modules the typechecker needed at runtime+    -- This is useful for recompilation checking.+    -- See Note [Recompilation avoidance in the presence of TH]+    --+    -- From hscCompileCoreExpr' in GHC+    -- To update, copy hscCompileCoreExpr' (the implementation of+    -- hscCompileCoreExprHook) verbatim, and add code to extract all the free+    -- names in the compiled bytecode, recording the modules that those names+    -- come from in the IORef,, as these are the modules on whose implementation+    -- we depend.+    compile_bco_hook :: IORef (ModuleEnv BS.ByteString) -> HscEnv -> SrcSpan -> CoreExpr+                     -> IO (ForeignHValue, [Linkable], PkgsLoaded)+    compile_bco_hook var hsc_env srcspan ds_expr+      = do { let dflags = hsc_dflags hsc_env++             {- Simplify it -}+           ; simpl_expr <- simplifyExpr dflags hsc_env ds_expr++             {- Tidy it (temporary, until coreSat does cloning) -}+           ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr++             {- Prepare for codegen -}+           ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr++             {- Lint if necessary -}+           ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr+++           ; let iNTERACTIVELoc = G.ModLocation{ ml_hs_file   = Nothing,+                                        ml_hi_file   = panic "hscCompileCoreExpr':ml_hi_file",+                                        ml_obj_file  = panic "hscCompileCoreExpr':ml_obj_file",+                                        ml_dyn_obj_file = panic "hscCompileCoreExpr':ml_dyn_obj_file",+                                        ml_dyn_hi_file  = panic "hscCompileCoreExpr':ml_dyn_hi_file",+                                        ml_hie_file  = panic "hscCompileCoreExpr':ml_hie_file"+                                        }+           ; let ictxt = hsc_IC hsc_env++           ; (binding_id, stg_expr, _, _) <-+               myCoreToStgExpr (hsc_logger hsc_env)+                               (hsc_dflags hsc_env)+                               ictxt+                               True -- for bytecode+                               (icInteractiveModule ictxt)+                               iNTERACTIVELoc+                               prepd_expr++             {- Convert to BCOs -}+           ; bcos <- byteCodeGen hsc_env+                       (icInteractiveModule ictxt)+                       stg_expr+                       [] Nothing+#if MIN_VERSION_ghc(9,11,0)+                       [] -- spt_entries+#endif++            -- Exclude wired-in names because we may not have read+            -- their interface files, so getLinkDeps will fail+            -- All wired-in names are in the base package, which we link+            -- by default, so we can safely ignore them here.++            -- Find the linkables for the modules we need+           ; let needed_mods = mkUniqSet [+                                           mod -- We need the whole module for 9.4 because of multiple home units modules may have different unit ids++                                         | n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos+                                         , not (isWiredInName n) -- Exclude wired-in names+                                         , Just mod <- [nameModule_maybe n] -- Names from other modules+                                         , moduleUnitId mod `elem` home_unit_ids -- Only care about stuff from the home package set+                                         ]+                 home_unit_ids =+#if MIN_VERSION_ghc(9,13,0)+                    map fst (unitEnv_assocs $ hsc_HUG hsc_env)+#else+                    map fst (hugElts $ hsc_HUG hsc_env)+#endif+                 mods_transitive = getTransitiveMods hsc_env needed_mods++                 -- If we don't support multiple home units, ModuleNames are sufficient because all the units will be the same+                 mods_transitive_list =+                                         mapMaybe nodeKeyToInstalledModule $ Set.toList mods_transitive++           ; moduleLocs <- getModuleGraph+           ; lbs <- getLinkables [file+                                 | installedMod <- mods_transitive_list+                                 , let file = fromJust $ lookupModuleFile (installedMod { moduleUnit = RealUnit (Definite $ moduleUnit installedMod) }) moduleLocs+                                 ]+#if MIN_VERSION_ghc(9,13,0)+           ; hsc_env' <- loadModulesHome (map linkableHomeMod lbs) hsc_env+#else+           ; let hsc_env' = loadModulesHome (map linkableHomeMod lbs) hsc_env+#endif++             {- load it -}+#if MIN_VERSION_ghc(9,11,0)+           ; bco_time <- getCurrentTime+           ; (fv_hvs, lbss, pkgs) <- loadDecls (hscInterp hsc_env') hsc_env' srcspan $+                Linkable bco_time (icInteractiveModule ictxt) $ NE.singleton $ BCOs bcos+#else+           ; (fv_hvs, lbss, pkgs) <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos+#endif+#if MIN_VERSION_ghc(9,13,0)+           ; let hval = (expectJust $ lookup (idName binding_id) fv_hvs, lbss, pkgs)+#else+           ; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs, lbss, pkgs)+#endif++           ; modifyIORef' var (flip extendModuleEnvList [(mi_module $ hm_iface hm, linkableHash lb) | lb <- lbs, let hm = linkableHomeMod lb])+           ; return hval }++    -- TODO: support backpack+    nodeKeyToInstalledModule :: NodeKey -> Maybe InstalledModule+    -- We shouldn't get boot files here, but to be safe, never map them to an installed module+    -- because boot files don't have linkables we can load, and we will fail if we try to look+    -- for them+    nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = Nothing+    nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB moduleName _) uid)) = Just $ mkModule uid moduleName+    nodeKeyToInstalledModule _ = Nothing+    moduleToNodeKey :: Module -> NodeKey+    moduleToNodeKey mod = NodeKey_Module $ ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnitId mod)++    -- Compute the transitive set of linkables required+    getTransitiveMods hsc_env needed_mods+#if MIN_VERSION_ghc(9,13,0)+      = Set.unions (Set.fromList (map moduleToNodeKey mods) : [ Set.fromList $ map mkNodeKey dep+                                                              | m <- mods+                                                              , Just dep <-+                                                                  [mgReachable (hsc_mod_graph hsc_env) (moduleToNodeKey m)]+                                                              ])+      where mods = nonDetEltsUniqSet needed_mods -- OK because we put them into a set immediately after+#else+      = Set.unions (Set.fromList (map moduleToNodeKey mods) : [ dep | m <- mods+                                                              , Just dep <- [Map.lookup (moduleToNodeKey m) (mgTransDeps (hsc_mod_graph hsc_env))]+                                                              ])+      where mods = nonDetEltsUniqSet needed_mods -- OK because we put them into a set immediately after+#endif++    -- | Add a Hook to the DynFlags which captures and returns the+    -- typechecked splices before they are run. This information+    -- is used for hover.+    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+  -> TypecheckHelpers -- ^ Program linkables not to unload+  -> ParsedModule+  -> IO TcModuleResult+tcRnModule hsc_env tc_helpers pmod = do+  let ms = pm_mod_summary pmod+      hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env++  (((tc_gbl_env', mrn_info), warning_messages), splices, mod_env)+      <- captureSplicesAndDeps tc_helpers hsc_env_tmp $ \hscEnvTmp ->+             do  hscTypecheckRenameWithDiagnostics hscEnvTmp ms $+                          HsParsedModule { hpm_module = parsedSource pmod+                                         , hpm_src_files = pm_extra_src_files pmod+                                         }+  let rn_info = case mrn_info of+        Just x  -> x+        Nothing -> error "no renamed info tcRnModule"++      -- Serialize mod_env so we can read it from the interface+      mod_env_anns = map (\(mod, hash) -> Annotation (ModuleTarget mod) $ toSerialized BS.unpack hash)+                         (moduleEnvToList mod_env)+      tc_gbl_env = tc_gbl_env' { tcg_ann_env = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns }+  pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env warning_messages)+++-- Note [Clearing mi_globals after generating an iface]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- GHC populates the mi_global field in interfaces for GHCi if we are using the bytecode+-- interpreter.+-- However, this field is expensive in terms of heap usage, and we don't use it in HLS+-- anywhere. So we zero it out.+-- The field is not serialized or deserialised from disk, so we don't need to remove it+-- while reading an iface from disk, only if we just generated an iface in memory+--++++-- | See https://github.com/haskell/haskell-language-server/issues/3450+-- GHC's recompilation avoidance in the presense of TH is less precise than+-- HLS. To avoid GHC from pessimising HLS, we filter out certain dependency information+-- that we track ourselves. See also Note [Recompilation avoidance in the presence of TH]+filterUsages :: [Usage] -> [Usage]+filterUsages = filter $ \case UsageHomeModuleInterface{} -> False+                              _ -> True++-- | Mitigation for https://gitlab.haskell.org/ghc/ghc/-/issues/22744+-- Important to do this immediately after reading the unit before+-- anything else has a chance to read `mi_usages`+shareUsages :: ModIface -> ModIface+shareUsages iface+  = iface+-- Fixed upstream in GHC 9.8+#if !MIN_VERSION_ghc(9,7,0)+      {mi_usages = usages}+  where usages = map go (mi_usages iface)+        go usg@UsageFile{} = usg {usg_file_path = fp}+          where !fp = shareFilePath (usg_file_path usg)+        go usg = usg+#endif+++mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult+mkHiFileResultNoCompile session tcm = do+  let hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) session+      ms = pm_mod_summary $ tmrParsed tcm+      tcGblEnv = tmrTypechecked tcm+  details <- makeSimpleDetails hsc_env_tmp tcGblEnv+  sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv+  iface' <- mkIfaceTc hsc_env_tmp sf details ms Nothing tcGblEnv+  -- See Note [Clearing mi_globals after generating an iface]+  let iface = iface'+#if MIN_VERSION_ghc(9,13,0)+                & set_mi_top_env (IfaceTopEnv emptyDetOrdAvails [])+#elif MIN_VERSION_ghc(9,11,0)+                & set_mi_top_env Nothing+                & set_mi_usages (filterUsages (mi_usages iface'))+#else+                { mi_globals = Nothing, mi_usages = filterUsages (mi_usages iface') }+#endif+  pure $! mkHiFileResult ms iface details (tmrRuntimeModules tcm) Nothing++mkHiFileResultCompile+    :: ShakeExtras+    -> HscEnv+    -> TcModuleResult+    -> ModGuts+    -> IO (IdeResult HiFileResult)+mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do+  let session = hscSetFlags (ms_hspp_opts ms) session'+      ms = pm_mod_summary $ tmrParsed tcm++  (details, guts) <- do+        -- write core file+        -- give variables unique OccNames+        tidy_opts <- initTidyOpts session+        (guts, details) <- tidyProgram tidy_opts simplified_guts+        pure (details, guts)++#if MIN_VERSION_ghc(9,13,0)+  partial_iface <- mkPartialIface session+                                  (cg_binds guts)+                                  details+                                  ms+                                  (tcg_import_decls (tmrTypechecked tcm))+                                  simplified_guts+#else+  let !partial_iface = force $ mkPartialIface session+                                              (cg_binds guts)+                                              details+                                              ms+#if MIN_VERSION_ghc(9,11,0)+                                              (tcg_import_decls (tmrTypechecked tcm))+#endif+                                              simplified_guts+#endif++  final_iface' <- mkFullIface session partial_iface Nothing+                    Nothing+#if MIN_VERSION_ghc(9,11,0)+                    NoStubs []+#endif+  -- See Note [Clearing mi_globals after generating an iface]+  let final_iface = final_iface'+#if MIN_VERSION_ghc(9,13,0)+                      & set_mi_top_env (IfaceTopEnv emptyDetOrdAvails [])+#elif MIN_VERSION_ghc(9,11,0)+                      & set_mi_top_env Nothing+                      & set_mi_usages (filterUsages (mi_usages final_iface'))+#else+                      {mi_globals = Nothing, mi_usages = filterUsages (mi_usages final_iface')}+#endif++  -- Write the core file now+  core_file <- do+        let core_fp  = ml_core_file $ ms_location ms+            core_file = codeGutsToCoreFile iface_hash guts+            iface_hash = getModuleHash final_iface+        core_hash1 <- atomicFileWrite se core_fp $ \fp ->+          writeBinCoreFile (hsc_dflags session) fp core_file+        -- We want to drop references to guts and read in a serialized, compact version+        -- of the core file from disk (as it is deserialised lazily)+        -- This is because we don't want to keep the guts in memory for every file in+        -- the project as it becomes prohibitively expensive+        -- The serialized file however is much more compact and only requires a few+        -- hundred megabytes of memory total even in a large project with 1000s of+        -- modules+        (coreFile, !core_hash2) <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp+        pure $ assert (core_hash1 == core_hash2)+             $ Just (coreFile, fingerprintToBS core_hash2)++  -- Verify core file by roundtrip testing and comparison+  IdeOptions{optVerifyCoreFile} <- getIdeOptionsIO se+  case core_file of+    Just (core, _) | optVerifyCoreFile -> do+      let core_fp = ml_core_file $ ms_location ms+      traceIO $ "Verifying " ++ core_fp+      let CgGuts{cg_binds = unprep_binds, cg_tycons = tycons } = guts+          mod = ms_mod ms+          data_tycons = filter isAlgTyCon tycons+      CgGuts{cg_binds = unprep_binds'} <- coreFileToCgGuts session final_iface details core+      cp_cfg <- initCorePrepConfig session+#if MIN_VERSION_ghc(9,13,0)+      let corePrep = corePrepPgm+                       (hsc_logger session) cp_cfg (initCorePrepPgmConfig (hsc_dflags session) (interactiveInScope $ hsc_IC session))+                       mod++      -- Run corePrep first as we want to test the final version of the program that will+      -- get translated to STG/Bytecode+      prepd_binds+        <- corePrep unprep_binds+#else+      let corePrep = corePrepPgm+                       (hsc_logger session) cp_cfg (initCorePrepPgmConfig (hsc_dflags session) (interactiveInScope $ hsc_IC session))+                       mod (ms_location ms)++      -- Run corePrep first as we want to test the final version of the program that will+      -- get translated to STG/Bytecode+      prepd_binds+        <- corePrep unprep_binds data_tycons+#endif+#if MIN_VERSION_ghc(9,13,0)+      prepd_binds'+        <- corePrep unprep_binds'+#else+      prepd_binds'+        <- corePrep unprep_binds' data_tycons+#endif+      let binds  = noUnfoldings $ (map flattenBinds . (:[])) prepd_binds+          binds' = noUnfoldings $ (map flattenBinds . (:[])) prepd_binds'++          -- diffBinds is unreliable, sometimes it goes down the wrong track.+          -- This fixes the order of the bindings so that it is less likely to do so.+          diffs2 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go binds binds'+          -- diffs1 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go (map (:[]) $ concat binds) (map (:[]) $ concat binds')+          -- diffs3  = flip S.evalState (mkRnEnv2 emptyInScopeSet) $ go (concat binds) (concat binds')++          diffs = diffs2+          go x y = S.state $ \s -> diffBinds True s x y++          -- The roundtrip doesn't preserver OtherUnfolding or occInfo, but neither are of these+          -- are used for generate core or bytecode, so we can safely ignore them+          -- SYB is slow but fine given that this is only used for testing+          noUnfoldings = everywhere $ mkT $ \v -> if isId v+            then+              let v' = if isOtherUnfolding (realIdUnfolding v) then setIdUnfolding v noUnfolding else v+                in setIdOccInfo v' noOccInfo+            else v+          isOtherUnfolding (OtherCon _) = True+          isOtherUnfolding _            = False+++      when (not $ null diffs) $+        panicDoc "verify core failed!" (vcat $ punctuate (text "\n\n") diffs) -- ++ [ppr binds , ppr binds']))+    _ -> pure ()++  pure ([], Just $! mkHiFileResult ms final_iface details (tmrRuntimeModules tcm) core_file)++  where+    dflags = hsc_dflags session'+    source = "compile"+    catchErrs x = x `catches`+      [ Handler $ return . (,Nothing) . diagFromGhcException source dflags+      , Handler $ \diag ->+          return+            ( diagFromString+                source DiagnosticSeverity_Error (noSpan "<internal>")+                ("Error during " ++ T.unpack source ++ show @SomeException diag)+                Nothing+            , Nothing+            )+      ]++-- | 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+                 -- Breakpoints don't survive roundtripping from disk+                 -- and this trips up the verify-core-files check+                 -- They may also lead to other problems.+                 -- We have to setBackend ghciBackend in 9.8 as otherwise+                 -- non-exported definitions are stripped out.+                 -- However, setting this means breakpoints are generated.+                 -- Solution: prevent breakpoing generation by unsetting+                 -- Opt_InsertBreakpoints+               let session' = tweak $ flip hscSetFlags session+#if MIN_VERSION_ghc(9,7,0)+                                    $ flip gopt_unset Opt_InsertBreakpoints+                                    $ setBackend ghciBackend+#endif+                                    $ ms_hspp_opts ms+               -- TODO: maybe settings ms_hspp_opts is unnecessary?+               -- MP: the flags in ModSummary should be right, if they are wrong then+               -- the correct place to fix this is when the ModSummary is created.+               desugar <- hscDesugar session' (ms { ms_hspp_opts = hsc_dflags session' }) 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 env' = tweak (hscSetFlags (ms_hspp_opts summary) session)+                          target = platformDefaultBackend (hsc_dflags env')+                          newFlags = setBackend target $ updOptLevel 0 $ setOutputFile+                              (Just dot_o)+                            $ hsc_dflags env'+                          session' = hscSetFlags newFlags session+                      (outputFilename, _mStub, _foreign_files, _cinfos, _stgcinfos) <- hscGenHardCode session' guts+                                (ms_location summary)+                                fp+                      obj <- compileFile session' driverNoStop (outputFilename, Just (As False))+                      case obj of+                        Nothing -> throwGhcExceptionIO $ Panic "compileFile didn't generate object code"+                        Just x -> pure x+              -- Need time to be the modification time for recompilation checking+              t <- liftIO $ getModificationTime dot_o_fp+#if MIN_VERSION_ghc(9,11,0)+              let linkable = Linkable t mod (pure $ DotO dot_o_fp ModuleObject)+#else+              let linkable = LM t mod [DotO dot_o_fp]+#endif+              pure (map snd warnings, linkable)++newtype CoreFileTime = CoreFileTime UTCTime++generateByteCode :: CoreFileTime -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)+generateByteCode (CoreFileTime time) hscEnv summary guts = do+    fmap (either (, Nothing) (second Just)) $+          catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do++#if MIN_VERSION_ghc(9,11,0)+              (warnings, (_, bytecode)) <-+                withWarnings "bytecode" $ \_tweak -> do+                      let session = _tweak (hscSetFlags (ms_hspp_opts summary) hscEnv)+                          -- TODO: maybe settings ms_hspp_opts is unnecessary?+                          summary' = summary { ms_hspp_opts = hsc_dflags session }+                      hscInteractive session (mkCgInteractiveGuts guts)+                                (ms_location summary')+#else+              (warnings, (_, bytecode, sptEntries)) <-+                withWarnings "bytecode" $ \_tweak -> do+                      let session = _tweak (hscSetFlags (ms_hspp_opts summary) hscEnv)+                          -- TODO: maybe settings ms_hspp_opts is unnecessary?+                          summary' = summary { ms_hspp_opts = hsc_dflags session }+                      hscInteractive session (mkCgInteractiveGuts guts)+                                (ms_location summary')+#endif++#if MIN_VERSION_ghc(9,11,0)+              let linkable = Linkable time (ms_mod summary) (pure $ BCOs bytecode)+#else+              let linkable = LM time (ms_mod summary) [BCOs bytecode sptEntries]+#endif++              pure (map snd warnings, linkable)++demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule+demoteTypeErrorsToWarnings =+  (update_pm_mod_summary . update_hspp_opts) demoteTEsToWarns where++  demoteTEsToWarns :: DynFlags -> DynFlags+  -- convert the errors into warnings, and also check the warnings are enabled+  demoteTEsToWarns = (`wopt_set` Opt_WarnDeferredTypeErrors)+                   . (`wopt_set` Opt_WarnTypedHoles)+                   . (`wopt_set` Opt_WarnDeferredOutOfScopeVariables)+                   . (`gopt_set` Opt_DeferTypeErrors)+                   . (`gopt_set` Opt_DeferTypedHoles)+                   . (`gopt_set` Opt_DeferOutOfScopeVariables)++update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary+update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}++update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule+update_pm_mod_summary up pm =+  pm{pm_mod_summary = up $ pm_mod_summary pm}++unDefer :: (Maybe DiagnosticReason, FileDiagnostic) -> (Bool, FileDiagnostic)+unDefer (Just (WarningWithFlag Opt_WarnDeferredTypeErrors)         , fd) = (True, upgradeWarningToError fd)+unDefer (Just (WarningWithFlag Opt_WarnTypedHoles)                 , fd) = (True, upgradeWarningToError fd)+unDefer (Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables), fd) = (True, upgradeWarningToError fd)+unDefer ( _                                        , fd) = (False, fd)++upgradeWarningToError :: FileDiagnostic -> FileDiagnostic+upgradeWarningToError =+  fdLspDiagnosticL %~ \diag -> diag {_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message diag}+  where+  warn2err :: T.Text -> T.Text+  warn2err = T.intercalate ": error:" . T.splitOn ": warning:"++hideDiag :: DynFlags -> (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)+hideDiag originalFlags (w@(Just (WarningWithFlag warning)), fd)+  | not (wopt warning originalFlags)+  = (w, fd { fdShouldShowDiagnostic = HideDiag })+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+    , Opt_WarnUnusedRecordWildcards+    , Opt_WarnInaccessibleCode+#if !MIN_VERSION_ghc(9,7,0)+    , Opt_WarnWarningsDeprecations+#endif+    ]++-- | Add a unnecessary/deprecated tag to the required diagnostics.+tagDiag :: (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)++#if MIN_VERSION_ghc(9,7,0)+tagDiag (w@(Just (WarningWithCategory cat)), fd)+  | cat == defaultWarningCategory -- default warning category is for deprecations+  = (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags diag) })+tagDiag (w@(Just (WarningWithFlags warnings)), fd)+  | tags <- mapMaybe requiresTag (toList warnings)+  = (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ tags ++ concat (_tags diag) })+#else+tagDiag (w@(Just (WarningWithFlag warning)), fd)+  | Just tag <- requiresTag warning+  = (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ tag : concat (_tags diag) })+#endif+    where+    requiresTag :: WarningFlag -> Maybe DiagnosticTag+#if !MIN_VERSION_ghc(9,7,0)+    -- doesn't exist on 9.8, we use WarningWithCategory instead+    requiresTag Opt_WarnWarningsDeprecations+      = Just DiagnosticTag_Deprecated+#endif+    requiresTag wflag  -- deprecation was already considered above+      | wflag `elem` unnecessaryDeprecationWarningFlags+      = Just DiagnosticTag_Unnecessary+    requiresTag _ = Nothing+-- 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}++-- | Also resets the interface store+atomicFileWrite :: ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO a+atomicFileWrite se targetPath write = do+  let dir = takeDirectory targetPath+  createDirectoryIfMissing True dir+  (tempFilePath, cleanUp) <- newTempFileWithin dir+  (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)) >> pure x)+    `onException` cleanUp++generateHieAsts :: HscEnv -> TcModuleResult+#if MIN_VERSION_ghc(9,11,0)+                -> IO ([FileDiagnostic], Maybe (HieASTs Type, NameEntityInfo))+#else+                -> IO ([FileDiagnostic], Maybe (HieASTs Type))+#endif+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 =+#if !MIN_VERSION_ghc(9,11,0)+                            Util.listToBag $+#endif+                            map (mkVarBind unitDataConId) (spliceExpressions $ tmrTopLevelSplices tcm)+        real_binds = tcg_binds $ tmrTypechecked tcm+        all_binds =+#if MIN_VERSION_ghc(9,11,0)+          fake_splice_binds ++ real_binds+#else+          fake_splice_binds `Util.unionBags` real_binds+#endif+        ts = tmrTypechecked tcm :: TcGblEnv+        top_ev_binds = tcg_ev_binds ts :: Util.Bag EvBind+        insts = tcg_insts ts :: [ClsInst]+        tcs = tcg_tcs ts :: [TyCon]+        hie_asts = GHC.enrichHie all_binds (tmrRenamed tcm) top_ev_binds insts tcs++    pure $ Just $+#if MIN_VERSION_ghc(9,11,0)+      hie_asts (tcg_type_env ts)+#else+      hie_asts+#endif+  where+    dflags = hsc_dflags hscEnv++spliceExpressions :: Splices -> [LHsExpr GhcTc]+spliceExpressions 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 notifying 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 -> Util.Fingerprint -> Compat.HieFile -> IO ()+indexHieFile se mod_summary srcPath !hash hf = do+ atomically $ do+  pending <- readTVar indexPending+  case HashMap.lookup srcPath pending of+    Just pendingHash | pendingHash == hash -> pure () -- An index is already scheduled+    _ -> do+      -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around+      let !hf' = hf{hie_hs_src = mempty}+      modifyTVar' indexPending $ HashMap.insert srcPath hash+      writeTaskQueue indexQueue $ \withHieDb -> 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+          pendingOps <- readTVar indexPending+          pure $ case HashMap.lookup srcPath pendingOps 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+          -- Using bracket, so even if an exception happen during withHieDb call,+          -- the `post` (which clean the progress indicator) will still be called.+          bracket_ pre post $+            withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf')+  where+    mod_location    = ms_location mod_summary+    targetPath      = Compat.ml_hie_file mod_location+    HieDbWriter{..} = hiedbWriter se++    pre = progressUpdate indexProgressReporting ProgressStarted+    -- 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.SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $+            toJSON $ fromNormalizedFilePath srcPath+      whenJust mdone $ \_ -> progressUpdate indexProgressReporting ProgressCompleted++writeAndIndexHieFile+  :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo]+#if MIN_VERSION_ghc(9,11,0)+  -> (HieASTs Type, NameEntityInfo)+#else+  -> HieASTs Type+#endif+  -> 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 se targetPath $ flip GHC.writeHieFile hf+    hash <- Util.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 :: ShakeExtras -> HscEnv -> HiFileResult -> IO [FileDiagnostic]+writeHiFile se hscEnv tc =+  handleGenerationErrors dflags "interface write" $ do+    atomicFileWrite se targetPath $ \fp ->+      writeIfaceFile hscEnv fp modIface+  where+    modIface = hirModIface 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 $ \(exception :: SomeException) -> return $+        diagFromString+          source DiagnosticSeverity_Error (noSpan "<internal>")+          ("Error during " ++ T.unpack source ++ show exception)+          Nothing+    ]++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 $ \(exception :: SomeException) ->+        return+          ( diagFromString+              source DiagnosticSeverity_Error (noSpan "<internal>")+              ("Error during " ++ T.unpack source ++ show exception)+              Nothing+          , Nothing+          )+    ]++-- Merge the HPTs, module graphs and FinderCaches+-- See Note [GhcSessionDeps] in Development.IDE.Core.Rules+-- Add the current ModSummary to the graph, along with the+-- HomeModInfo's of all direct dependencies (by induction hypothesis all+-- transitive dependencies will be contained in envs)+#if MIN_VERSION_ghc(9,11,0)+mergeEnvs :: HscEnv+          -> ModuleGraph+          -> DependencyInformation+          -> ModSummary+          -> [HomeModInfo]+          -> [HscEnv]+          -> IO HscEnv+mergeEnvs env mg dep_info ms extraMods envs = do+#if MIN_VERSION_ghc(9,13,0)+      newHug <- sequence $ foldl' mergeHUG (pure <$> hsc_HUG env) (map (fmap pure . hsc_HUG) envs)+      let hsc_env' = setModuleGraph mg $ (hscUpdateHUG (const newHug) env){+                hsc_FC = (hsc_FC env)+                  { addToFinderCache = \im val ->+                        if moduleUnit im `elem` hsc_all_home_unit_ids env+                        then pure ()+                        else addToFinderCache (hsc_FC env) im val+                  , lookupFinderCache = \im ->+                        if moduleUnit im `elem` hsc_all_home_unit_ids env+                        then case lookupModuleFile (im { moduleUnit = RealUnit (Definite $ moduleUnit im) }) dep_info of+                               Nothing -> pure Nothing+                               Just fs -> let ml = fromJust $ do+                                                    id <- lookupPathToId (depPathIdMap dep_info) fs+                                                    artifactModLocation (idToModLocation (depPathIdMap dep_info) id)+#if MIN_VERSION_ghc(9,13,0)+                                          in pure $ Just $ InstalledFound ml+#else+                                          in pure $ Just $ InstalledFound ml im+#endif+                        else lookupFinderCache (hsc_FC env) im+                  }+            }+      loadModulesHome extraMods hsc_env'+#else+    return $! loadModulesHome extraMods $+      let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in+      (hscUpdateHUG (const newHug) env){+          hsc_mod_graph = mg,+          hsc_FC = (hsc_FC env)+            { addToFinderCache = \gwib@(GWIB im _) val ->+                  if moduleUnit im `elem` hsc_all_home_unit_ids env+                  then pure ()+                  else addToFinderCache (hsc_FC env) gwib val+            , lookupFinderCache = \gwib@(GWIB im _) ->+                  if moduleUnit im `elem` hsc_all_home_unit_ids env+                  then case lookupModuleFile (im { moduleUnit = RealUnit (Definite $ moduleUnit im) }) dep_info of+                         Nothing -> pure Nothing+                         Just fs -> let ml = fromJust $ do+                                              id <- lookupPathToId (depPathIdMap dep_info) fs+                                              artifactModLocation (idToModLocation (depPathIdMap dep_info) id)+                                    in pure $ Just $ InstalledFound ml im+                  else lookupFinderCache (hsc_FC env) gwib+            }+      }+#endif++    where+#if MIN_VERSION_ghc(9,13,0)+        mergeHUG :: UnitEnvGraph (IO HomeUnitEnv) -> UnitEnvGraph (IO HomeUnitEnv) -> UnitEnvGraph (IO HomeUnitEnv)+        mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b+        mergeHUE a b = do+          a_v <- a+          hpt_b <- readIORef . hptInternalTableRef . homeUnitEnv_hpt =<< b+          hpt_a <- readIORef . hptInternalTableRef . homeUnitEnv_hpt $ a_v+          result <- hptInternalTableFromRef =<< (newIORef $! mergeUDFM hpt_a hpt_b)+          return $! a_v { homeUnitEnv_hpt = result }+        mergeUDFM = plusUDFM_C combineModules+        combineModules a b+          | HsSrcFile <- mi_hsc_src (hm_iface a) = a+          | otherwise = b+#else+        mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b+        mergeHUE a b = a { homeUnitEnv_hpt = mergeUDFM (homeUnitEnv_hpt a) (homeUnitEnv_hpt b) }+        mergeUDFM = plusUDFM_C combineModules++        combineModules a b+          | HsSrcFile <- mi_hsc_src (hm_iface a) = a+          | otherwise = b+#endif++#else+mergeEnvs :: HscEnv+          -> ModuleGraph+          -> DependencyInformation+          -> ModSummary+          -> [HomeModInfo]+          -> [HscEnv]+          -> IO HscEnv+mergeEnvs env mg _dep_info ms extraMods envs = do+    let im  = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))+        ifr = InstalledFound (ms_location ms) im+        curFinderCache = Compat.extendInstalledModuleEnv Compat.emptyInstalledModuleEnv im ifr+    newFinderCache <- concatFC curFinderCache (map hsc_FC envs)+    return $! loadModulesHome extraMods $+      let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in+      (hscUpdateHUG (const newHug) env){+          hsc_FC = newFinderCache,+          hsc_mod_graph = mg+      }++    where+        mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b+        mergeHUE a b = a { homeUnitEnv_hpt = mergeUDFM (homeUnitEnv_hpt a) (homeUnitEnv_hpt b) }+        mergeUDFM = plusUDFM_C combineModules++        combineModules a b+          | HsSrcFile <- mi_hsc_src (hm_iface a) = a+          | otherwise = b++        -- Prefer non-boot files over non-boot files+        -- otherwise we can get errors like https://gitlab.haskell.org/ghc/ghc/-/issues/19816+        -- if a boot file shadows over a non-boot file+        combineModuleLocations a@(InstalledFound ml _) _ | Just fp <- ml_hs_file ml, not ("boot" `isSuffixOf` fp) = a+        combineModuleLocations _ b = b++        concatFC :: FinderCacheState -> [FinderCache] -> IO FinderCache+        concatFC cur xs = do+          fcModules <- mapM (readIORef . fcModuleCache) xs+          fcFiles <- mapM (readIORef . fcFileCache) xs+          fcModules' <- newIORef $! foldl' (plusInstalledModuleEnv combineModuleLocations) cur fcModules+          fcFiles' <- newIORef $! Map.unions fcFiles+          pure $ FinderCache fcModules' fcFiles'+#endif+++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+  -> Maybe Util.StringBuffer+  -> ExceptT [FileDiagnostic] IO ModSummaryResult+getModSummaryFromImports env fp mContents = do+    (contents, opts, ppEnv, src_hash) <- preprocessor env fp mContents++    let dflags = hsc_dflags ppEnv++    -- 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 `Util.orElse` mAIN_NAME++        (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps++        -- GHC.Prim doesn't exist physically, so don't go looking for it.+        (ordinary_imps, ghc_prim_imports)+          = partition ((/= 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) = (+                               (ideclPkgQual i)+                             , reLoc $ ideclName i)++        msrImports = implicit_imports ++ imps++        rn_pkg_qual = renameRawPkgQual (hsc_unit_env ppEnv)+        rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))+#if MIN_VERSION_ghc(9,13,0)+        -- In GHC 9.13+, ms_srcimps is just [Located ModuleName] and ms_textual_imps includes ImportLevel+        srcImports = map snd $ rn_imps $ map convImport src_idecls++        -- Extract import level along with pkg qualifier and module name+        convImportWithLevel (L _ i) = (convImportLevel (ideclLevelSpec i)+                                      , ideclPkgQual i+                                      , reLoc $ ideclName i)++        -- Rename package qualifiers while preserving import levels+        rn_imps_with_level = fmap (\(lvl, pk, lmn@(L _ mn)) -> (lvl, rn_pkg_qual mn pk, lmn))++        -- Implicit imports (prelude) are always NormalLevel;+        -- explicit user imports preserve their declared level+        textualImports = map (\(pk, lmn) -> (NormalLevel, pk, lmn)) (rn_imps $ map convImport implicit_imports)+                      ++ rn_imps_with_level (map convImportWithLevel ordinary_imps)+#else+        srcImports = rn_imps $ map convImport src_idecls+        textualImports = rn_imps $ map convImport (implicit_imports ++ ordinary_imps)+#endif+        ghc_prim_import = not (null ghc_prim_imports)+++    -- Force bits that might keep the string buffer and DynFlags alive unnecessarily+    liftIO $ evaluate $ rnf srcImports+    liftIO $ evaluate $ rnf textualImports+++    modLoc <- liftIO $ if mod == mAIN_NAME+        -- specially in tests it's common to have lots of nameless modules+        -- mkHomeModLocation will map them to the same hi/hie locations+        then mkHomeModLocation dflags (pathToModuleName fp) fp+        else mkHomeModLocation dflags mod fp++    let modl = mkHomeModule (hscHomeUnit ppEnv) mod+        sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile+        msrModSummary =+            ModSummary+                { ms_mod          = modl+                , ms_hie_date     = Nothing+                , ms_dyn_obj_date = Nothing+#if !MIN_VERSION_ghc(9,13,0)+                , ms_ghc_prim_import = ghc_prim_import+#endif+                , ms_hs_hash      = src_hash++                , ms_hsc_src      = sourceType+                -- The contents are used by the GetModSummary rule+                , ms_hspp_buf     = Just contents+                , ms_hspp_file    = fp+                , ms_hspp_opts    = dflags+                , ms_iface_date   = Nothing+                , ms_location     = withBootSuffix sourceType modLoc+                , ms_obj_date     = Nothing+                , ms_parsed_mod   = Nothing+                , ms_srcimps      = srcImports+                , ms_textual_imps = textualImports+                }++    msrFingerprint <- liftIO $ computeFingerprint opts msrModSummary+    msrHscEnv <- liftIO $ Loader.initializePlugins (hscSetFlags (ms_hspp_opts msrModSummary) ppEnv)+    return ModSummaryResult{..}+    where+        -- Compute a fingerprint from the contents of `ModSummary`,+        -- eliding the timestamps, the preprocessed source and other non relevant fields+        computeFingerprint opts ModSummary{..} = do+            fingerPrintImports <- fingerprintFromPut $ do+                  put $ Util.uniq $ moduleNameFS $ moduleName ms_mod+#if MIN_VERSION_ghc(9,13,0)+                  -- In GHC 9.13+, ms_srcimps is [Located ModuleName] and ms_textual_imps is [(ImportLevel, PkgQual, Located ModuleName)]+                  forM_ ms_srcimps $ \m -> do+                    put $ Util.uniq $ moduleNameFS $ unLoc m+                  forM_ ms_textual_imps $ \(_lvl, mb_p, m) -> do+                    put $ Util.uniq $ moduleNameFS $ unLoc m+                    case mb_p of+                      G.NoPkgQual    -> pure ()+                      G.ThisPkg uid  -> put $ getKey $ getUnique uid+                      G.OtherPkg uid -> put $ getKey $ getUnique uid+#else+                  forM_ (ms_srcimps ++ ms_textual_imps) $ \(mb_p, m) -> do+                    put $ Util.uniq $ moduleNameFS $ unLoc m+                    case mb_p of+                      G.NoPkgQual    -> pure ()+                      G.ThisPkg uid  -> put $ getKey $ getUnique uid+                      G.OtherPkg uid -> put $ getKey $ getUnique uid+#endif+            return $! Util.fingerprintFingerprints $+                    [ Util.fingerprintString fp+                    , fingerPrintImports+                    , modLocationFingerprint ms_location+                    ] ++ map Util.fingerprintString opts++        modLocationFingerprint :: ModLocation -> Util.Fingerprint+        modLocationFingerprint ModLocation{..} = Util.fingerprintFingerprints $+            Util.fingerprintString <$> [ fromMaybe "" ml_hs_file+                                         , ml_hi_file+                                         , ml_dyn_hi_file+                                         , ml_obj_file+                                         , ml_dyn_obj_file+                                         , ml_hie_file]++-- | Parse only the module header+parseHeader+       :: Monad m+       => DynFlags -- ^ flags to use+       -> FilePath  -- ^ the filename (for source locations)+       -> Util.StringBuffer -- ^ Haskell module source text (full Unicode is supported)+       -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located (HsModule GhcPs))+parseHeader dflags filename contents = do+   let loc  = mkRealSrcLoc (Util.mkFastString filename) 1 1+   case unP Compat.parseHeader (initParserState (initParserOpts dflags) contents loc) of+     PFailedWithErrorMessages msgs ->+        throwE $ diagFromGhcErrorMessages sourceParser dflags $ msgs dflags+     POk pst rdr_module -> do+        let (warns, errs) = renderMessages $ getPsMessages pst++        -- 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 $ diagFromGhcErrorMessages sourceParser dflags errs++        let warnings = diagFromGhcErrorMessages sourceParser 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 (Util.mkFastString filename) 1 1+       dflags = ms_hspp_opts ms+       contents = fromJust $ ms_hspp_buf ms+   case unP Compat.parseModule (initParserState (initParserOpts dflags) contents loc) of+     PFailedWithErrorMessages msgs ->+       throwE $ diagFromGhcErrorMessages sourceParser dflags $ msgs dflags+     POk pst rdr_module ->+         let+             psMessages = getPsMessages pst+         in+           do+               let IdePreprocessedSource preproc_warns preproc_errs parsed = customPreprocessor rdr_module+               let attachNoStructuredError (span, msg) = (span, msg, Nothing)++               unless (null preproc_errs) $+                  throwE $+                    diagFromStrings+                      sourceParser+                      DiagnosticSeverity_Error+                      (fmap attachNoStructuredError preproc_errs)++               let preproc_warning_file_diagnostics =+                     diagFromStrings+                      sourceParser+                      DiagnosticSeverity_Warning+                      (fmap attachNoStructuredError preproc_warns)+               (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env ms parsed psMessages+               let (warns, errors) = renderMessages msgs++               -- 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 errors) $+                 throwE $ diagFromGhcErrorMessages sourceParser dflags errors++               -- 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+                   TempDir tmp_dir = tmpDir dflags+                   srcs0 = nubOrd $ filter (not . (tmp_dir `isPrefixOf`))+                                  $ filter (/= n_hspp)+                                  $ map normalise+                                  $ filter (not . isPrefixOf "<")+                                  $ map Util.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 ms parsed' srcs2+                   warnings = diagFromGhcErrorMessages sourceParser dflags warns+               pure (warnings ++ preproc_warning_file_diagnostics, pm)++loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile+loadHieFile ncu f = do+  GHC.hie_file_result <$> GHC.readHieFile ncu f+++{- Note [Recompilation avoidance in the presence of TH]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Most versions of GHC we currently support don't have a working implementation of+code unloading for object code, and no version of GHC supports this on certain+platforms like Windows. This makes it completely infeasible for interactive use,+as symbols from previous compiles will shadow over all future compiles.++This means that we need to use bytecode when generating code for Template+Haskell. Unfortunately, we can't serialize bytecode, so we will always need+to recompile when the IDE starts. However, we can put in place a much tighter+recompilation avoidance scheme for subsequent compiles:++1. If the source file changes, then we always need to recompile+   a. For files of interest, we will get explicit `textDocument/change` events+   that will let us invalidate our build products+   b. For files we read from disk, we can detect source file changes by+   comparing the `mtime` of the source file with the build product (.hi/.o) file+   on disk.+2. If GHC's recompilation avoidance scheme based on interface file hashes says+   that we need to recompile, the we need to recompile.+3. If the file in question requires code generation then, we need to recompile+   if we don't have the appropriate kind of build products.+   a. If we already have the build products in memory, and the conditions 1 and+   2 above hold, then we don't need to recompile+   b. If we are generating object code, then we can also search for it on+   disk and ensure it is up to date. Notably, we did _not_ previously re-use+   old bytecode from memory when `hls-graph`/`shake` decided to rebuild the+   `HiFileResult` for some reason++4. If the file in question used Template Haskell on the previous compile, then+we need to recompile if any `Linkable` in its transitive closure changed. This+sounds bad, but it is possible to make some improvements. In particular, we only+need to recompile if any of the `Linkable`s actually used during the previous+compile change.++How can we tell if a `Linkable` was actually used while running some TH?++GHC provides a `hscCompileCoreExprHook` which lets us intercept bytecode as+it is being compiled and linked. We can inspect the bytecode to see which+`Linkable` dependencies it requires, and record this for use in+recompilation checking.+We record all the home package modules of the free names that occur in the+bytecode. The `Linkable`s required are then the transitive closure of these+modules in the home-package environment. This is the same scheme as used by+GHC to find the correct things to link in before running bytecode.++This works fine if we already have previous build products in memory, but+what if we are reading an interface from disk? Well, we can smuggle in the+necessary information (linkable `Module`s required as well as the time they+were generated) using `Annotation`s, which provide a somewhat general purpose+way to serialise arbitrary information along with interface files.++Then when deciding whether to recompile, we need to check that the versions+(i.e. hashes) of the linkables used during a previous compile match whatever is+currently in the HPT.++As we always generate Linkables from core files, we use the core file hash+as a (hopefully) deterministic measure of whether the Linkable has changed.+This is better than using the object file hash (if we have one) because object+file generation is not deterministic.+-}++data RecompilationInfo m+  = RecompilationInfo+  { source_version :: FileVersion+  , old_value   :: Maybe (HiFileResult, FileVersion)+  , get_file_version :: NormalizedFilePath -> m (Maybe FileVersion)+  , get_linkable_hashes :: [NormalizedFilePath] -> m [BS.ByteString]+  , get_module_graph :: m DependencyInformation+  , regenerate  :: Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface+  }++-- | Either a regular GHC linkable or a core file that+-- can be later turned into a proper linkable+data IdeLinkable = GhcLinkable !Linkable | CoreLinkable !UTCTime !CoreFile++instance NFData IdeLinkable where+  rnf (GhcLinkable lb)      = rnf lb+  rnf (CoreLinkable time _) = rnf time++ml_core_file :: ModLocation -> FilePath+ml_core_file ml = ml_hi_file ml <.> "core"++-- | Returns an up-to-date module interface, regenerating if needed.+--   Assumes file exists.+--   Requires the 'HscEnv' to be set up with dependencies+-- See Note [Recompilation avoidance in the presence of TH]+loadInterface+  :: (MonadIO m, MonadMask m)+  => HscEnv+  -> ModSummary+  -> Maybe LinkableType+  -> RecompilationInfo m+  -> m ([FileDiagnostic], Maybe HiFileResult)+loadInterface session ms linkableNeeded RecompilationInfo{..} = do+    let sessionWithMsDynFlags = hscSetFlags (ms_hspp_opts ms) session+        mb_old_iface = hirModIface . fst <$> old_value++        core_file = ml_core_file (ms_location ms)+        iface_file = ml_hi_file (ms_location ms)++        !mod = ms_mod ms++    old_iface <- case mb_old_iface of+      Just iface -> pure (Just iface)+      Nothing -> do+        let ncu = hsc_NC sessionWithMsDynFlags+            read_dflags = hsc_dflags sessionWithMsDynFlags+#if MIN_VERSION_ghc(9,13,0)+        read_result <- liftIO $ readIface (hsc_hooks sessionWithMsDynFlags) (hsc_logger sessionWithMsDynFlags) read_dflags ncu mod iface_file+#else+        read_result <- liftIO $ readIface read_dflags ncu mod iface_file+#endif+        case read_result of+          Util.Failed{}        -> return Nothing+          -- important to call `shareUsages` here before checkOldIface+          -- consults `mi_usages`+          Util.Succeeded iface -> return $ Just (shareUsages iface)++    -- If mb_old_iface is nothing then checkOldIface will load it for us+    -- given that the source is unmodified+    (recomp_iface_reqd, mb_checked_iface)+      <- liftIO $ checkOldIface sessionWithMsDynFlags ms old_iface >>= \case+        UpToDateItem x -> pure (UpToDate, Just x)+        OutOfDateItem reason x -> pure (NeedsRecompile reason, x)++    let do_regenerate _reason = withTrace "regenerate interface" $ \setTag -> do+          setTag "Module" $ moduleNameString $ moduleName mod+          setTag "Reason" $ showReason _reason+          liftIO $ traceMarkerIO $ "regenerate interface " ++ show (moduleNameString $ moduleName mod, showReason _reason)+          regenerate linkableNeeded++    case (mb_checked_iface, recomp_iface_reqd) of+      (Just iface, UpToDate) -> do+             details <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface+             -- parse the runtime dependencies from the annotations+             let runtime_deps =+#if MIN_VERSION_ghc(9,13,0)+                   parseRuntimeDeps (md_anns details)+#else+                   if not (mi_used_th iface) then emptyModuleEnv+                   else parseRuntimeDeps (md_anns details)+#endif+             -- Peform the fine grained recompilation check for TH+             maybe_recomp <- checkLinkableDependencies get_linkable_hashes get_module_graph runtime_deps+             case maybe_recomp of+               Just msg -> do_regenerate msg+               Nothing+                 | isJust linkableNeeded -> handleErrs $ do+                   (coreFile@CoreFile{cf_iface_hash}, core_hash) <- liftIO $+                     readBinCoreFile (mkUpdater $ hsc_NC session) core_file+                   if cf_iface_hash == getModuleHash iface+                   then return ([], Just $ mkHiFileResult ms iface details runtime_deps (Just (coreFile, fingerprintToBS core_hash)))+                   else do_regenerate (recompBecause "Core file out of date (doesn't match iface hash)")+                 | otherwise -> return ([], Just $ mkHiFileResult ms iface details runtime_deps Nothing)+                 where handleErrs = flip catches+                         [Handler $ \(e :: IOException) -> do_regenerate (recompBecause $ "Reading core file failed (" ++ show e ++ ")")+                         ,Handler $ \(e :: GhcException) -> case e of+                            Signal _ -> throw e+                            Panic _  -> throw e+                            _        -> do_regenerate (recompBecause $ "Reading core file failed (" ++ show e ++ ")")+                         ]+      (_, _reason) -> do_regenerate _reason++-- | Find the runtime dependencies by looking at the annotations+-- serialized in the iface+-- The bytestrings are the hashes of the core files for modules we+-- required to run the TH splices in the given module.+-- See Note [Recompilation avoidance in the presence of TH]+parseRuntimeDeps :: [ModIfaceAnnotation] -> ModuleEnv BS.ByteString+parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns+  where+    go (Annotation (ModuleTarget mod) payload)+      | Just bs <- fromSerialized BS.pack payload+      = Just (mod, bs)+    go _ = Nothing++-- | checkLinkableDependencies compares the core files in the build graph to+-- the runtime dependencies of the module, to check if any of them are out of date+-- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH+-- See Note [Recompilation avoidance in the presence of TH]+checkLinkableDependencies :: MonadIO m => ([NormalizedFilePath] -> m [BS.ByteString]) -> m DependencyInformation -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)+checkLinkableDependencies get_linkable_hashes get_module_graph runtime_deps = do+  graph <- get_module_graph+  let go (mod, hash) = (,hash) <$> lookupModuleFile mod graph+      hs_files = mapM go (moduleEnvToList runtime_deps)+  case hs_files of+    Nothing -> error "invalid module graph"+    Just fs -> do+      store_hashes <- get_linkable_hashes (map fst fs)+      let out_of_date = [core_file | ((core_file, expected_hash), actual_hash) <- zip fs store_hashes, expected_hash /= actual_hash]+      case out_of_date of+        [] -> pure Nothing+        _ -> pure $ Just $ recompBecause+              $ "out of date runtime dependencies: " ++ intercalate ", " (map show out_of_date)++recompBecause :: String -> RecompileRequired+recompBecause =+                NeedsRecompile .+                RecompBecause+              . CustomReason++data SourceModified = SourceModified | SourceUnmodified deriving (Eq, Ord, Show)++showReason :: RecompileRequired -> String+showReason UpToDate                     = "UpToDate"+showReason (NeedsRecompile MustCompile) = "MustCompile"+showReason (NeedsRecompile s)           = printWithoutUniques s++mkDetailsFromIface :: HscEnv -> ModIface -> IO ModDetails+mkDetailsFromIface session iface = do+  fixIO $ \details -> do+#if MIN_VERSION_ghc(9,13,0)+    hscInsertHPT (HomeModInfo iface details emptyHomeModInfoLinkable) session+    initIfaceLoad session (typecheckIface iface)+#else+    let !hsc' = hscUpdateHPT (\hpt -> addToHpt hpt (moduleName $ mi_module iface) (HomeModInfo iface details emptyHomeModInfoLinkable)) session+    initIfaceLoad hsc' (typecheckIface iface)+#endif++coreFileToCgGuts :: HscEnv -> ModIface -> ModDetails -> CoreFile -> IO CgGuts+coreFileToCgGuts session iface details core_file = do+  let this_mod = mi_module iface+  types_var <- newIORef (md_types details)+#if MIN_VERSION_ghc(9,13,0)+  let hsc_env' = session {+        hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])+        }+  hscInsertHPT (HomeModInfo iface details emptyHomeModInfoLinkable) hsc_env'+#else+  let act hpt = addToHpt hpt (moduleName this_mod)+                             (HomeModInfo iface details emptyHomeModInfoLinkable)+      hsc_env' = hscUpdateHPT act (session {+        hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])+        })+#endif+  core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckCoreFile this_mod types_var core_file+      -- Implicit binds aren't saved, so we need to regenerate them ourselves.+  let _implicit_binds = concatMap getImplicitBinds tyCons -- only used if GHC < 9.6+      tyCons = typeEnvTyCons (md_types details)+  -- In GHC 9.6, the implicit binds are tidied and part of core_binds+  pure $ CgGuts this_mod tyCons core_binds [] NoStubs [] mempty+#if !MIN_VERSION_ghc(9,11,0)+                (emptyHpcInfo False)+#endif+                Nothing []++coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> UTCTime -> IO ([FileDiagnostic], Maybe HomeModInfo)+coreFileToLinkable linkableType session ms iface details core_file t = do+  cgi_guts <- coreFileToCgGuts session iface details core_file+  (warns, lb) <- case linkableType of+    BCOLinkable    -> fmap (maybe emptyHomeModInfoLinkable justBytecode) <$> generateByteCode (CoreFileTime t) session ms cgi_guts+    ObjectLinkable -> fmap (maybe emptyHomeModInfoLinkable justObjects) <$> generateObjectCode session ms cgi_guts+  pure (warns, Just $ HomeModInfo iface details lb) -- TODO wz1000 handle emptyHomeModInfoLinkable++-- | 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+  -> [Name]+  -> IO [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]+getDocsBatch hsc_env _names = do+    res <- initIfaceLoad hsc_env $ forM _names $ \name ->+        case nameModule_maybe name of+            Nothing -> return (Left $ NameHasNoModule name)+            Just mod -> do+             ModIface {+                        mi_docs = Just Docs{ docs_mod_hdr = mb_doc_hdr+                                      , docs_decls = dmap+                                      , docs_args = amap+                                      }+                      } <- loadSysInterface (text "getModuleInterface") mod+             if isNothing mb_doc_hdr && isNullUniqMap dmap && isNullUniqMap amap+               then pure (Left (NoDocsInIface mod $ compiled name))+               else pure (Right (+                                  lookupUniqMap dmap name,+                                  lookupWithDefaultUniqMap amap mempty name))+    return $ map (first $ T.unpack . printOutputable) res+  where+    compiled n =+      -- TODO: Find a more direct indicator.+      case nameSrcLoc n of+        RealSrcLoc {}   -> False+        UnhelpfulLoc {} -> True++-- | 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+           -> Name+           -> IO (Maybe TyThing)+lookupName _ name+  | Nothing <- nameModule_maybe name = pure Nothing+lookupName hsc_env name = exceptionHandle $ do+  mb_thing <- liftIO $ lookupType hsc_env name+  case mb_thing of+    x@(Just _) -> return x+    Nothing+      | x@(Just thing) <- wiredInNameTyThing_maybe name+      -> do when (needWiredInHomeIface thing)+                 (initIfaceLoad hsc_env (loadWiredInHomeIface name))+            return x+      | otherwise -> do+        res <- initIfaceLoad hsc_env $ importDecl name+        case res of+          Util.Succeeded x -> return (Just x)+          _                -> return Nothing+  where+    exceptionHandle x = x `catch` \(_ :: IOEnvFailure) -> pure Nothing++pathToModuleName :: FilePath -> ModuleName+pathToModuleName = mkModuleName . map rep+  where+      rep c | isPathSeparator c = '_'+      rep ':' = '_'+      rep c = c++-- | Initialising plugins looks in the finder cache, but we know that the plugin doesn't come from a home module, so don't+-- error out when we don't find it+setNonHomeFCHook :: HscEnv -> HscEnv+setNonHomeFCHook hsc_env =+#if MIN_VERSION_ghc(9,13,0)+  hsc_env { hsc_FC = (hsc_FC hsc_env)+                        { lookupFinderCache = \im ->+                            if moduleUnit im `elem` hsc_all_home_unit_ids hsc_env+                            then pure (Just $ InstalledNotFound [] Nothing)+                            else lookupFinderCache (hsc_FC hsc_env) im+                        }+          }+#elif MIN_VERSION_ghc(9,11,0)+  hsc_env { hsc_FC = (hsc_FC hsc_env)+                        { lookupFinderCache = \m@(GWIB im _) ->+                            if moduleUnit im `elem` hsc_all_home_unit_ids hsc_env+                            then pure (Just $ InstalledNotFound [] Nothing)+                            else lookupFinderCache (hsc_FC hsc_env) m+                        }+          }+#else+  hsc_env+#endif++{- Note [Guidelines For Using CPP In GHCIDE Import Statements]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  GHCIDE's interface with GHC is extensive, and unfortunately, because we have+  to work with multiple versions of GHC, we have several files that need to use+  a lot of CPP. In order to simplify the CPP in the import section of every file+  we have a few specific guidelines for using CPP in these sections.++  - We don't want to nest CPP clauses, nor do we want to use else clauses. Both+  nesting and else clauses end up drastically complicating the code, and require+  significant mental stack to unwind.++  - CPP clauses should be placed at the end of the imports section. The clauses+  should be ordered by the GHC version they target from earlier to later versions,+  with negative if clauses coming before positive if clauses of the same+  version. (If you think about which GHC version a clause activates for this+  should make sense `!MIN_VERSION_GHC(9,0,0)` refers to 8.10 and lower which is+  an earlier version than `MIN_VERSION_GHC(9,0,0)` which refers to versions 9.0+  and later). In addition there should be a space before and after each CPP+  clause.++  - In if clauses that use `&&` and depend on more than one statement, the+  positive statement should come before the negative statement. In addition the+  clause should come after the single positive clause for that GHC version.++  - There shouldn't be multiple identical CPP statements. The use of odd or even+  GHC numbers is identical, with the only preference being to use what is+  already there. (i.e. (`MIN_VERSION_GHC(9,2,0)` and `MIN_VERSION_GHC(9,1,0)`   are functionally equivalent) -}
src/Development/IDE/Core/FileExists.hs view
@@ -28,6 +28,7 @@ import           Development.IDE.Graph import           Development.IDE.Types.Location import           Development.IDE.Types.Options+import           Development.IDE.Types.Shake           (toKey) import qualified Focus import           Ide.Logger                            (Pretty (pretty),                                                         Recorder, WithPriority,@@ -40,6 +41,7 @@ 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@@ -104,12 +106,12 @@   FileExistsMapVar v <- getIdeGlobalAction   return v --- | Modify the global store of file exists.-modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO ()+-- | Modify the global store of file exists and return the keys that need to be marked as dirty+modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO [Key] modifyFileExists state changes = do   FileExistsMapVar var <- getIdeGlobalState state   -- Masked to ensure that the previous values are flushed together with the map update-  join $ mask_ $ atomicallyNamed "modifyFileExists" $ do+  mask_ $ atomicallyNamed "modifyFileExists" $ do     forM_ changes $ \(f,c) ->         case fromChange c of             Just c' -> STM.focus (Focus.insert c') f var@@ -118,10 +120,10 @@     -- flush previous values     let (fileModifChanges, fileExistChanges) =             partition ((== FileChangeType_Changed) . snd) changes-    mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges-    io1 <- recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges-    io2 <- recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges-    return (io1 <> io2)+    keys0 <- concat <$> mapM (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges+    let keys1 = map (toKey GetFileExists . fst) fileExistChanges+    let keys2 = map (toKey GetModificationTime . fst) fileModifChanges+    return (keys0 <> keys1 <> keys2)  fromChange :: FileChangeType -> Maybe Bool fromChange FileChangeType_Created = Just True@@ -135,6 +137,7 @@ 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. @@ -201,6 +204,7 @@             else fileExistsSlow file  {- Note [Invalidating file existence results]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We have two mechanisms for getting file existence information: - The file existence cache - The VFS lookup
src/Development/IDE/Core/FileStore.hs view
@@ -3,7 +3,10 @@ {-# LANGUAGE TypeFamilies #-}  module Development.IDE.Core.FileStore(+    getFileModTimeContents,     getFileContents,+    getUriContents,+    getVersionedTextDoc,     setFileModified,     setSomethingModified,     fileStoreRules,@@ -18,13 +21,12 @@     isWatchSupported,     registerFileWatches,     shareFilePath,-    Log(..)+    Log(..),     ) where -import           Control.Concurrent.STM.Stats                 (STM, atomically,-                                                               modifyTVar')-import           Control.Concurrent.STM.TQueue                (writeTQueue)+import           Control.Concurrent.STM.Stats                 (STM, atomically) import           Control.Exception+import           Control.Lens                                 ((^.)) import           Control.Monad.Extra import           Control.Monad.IO.Class import qualified Data.Binary                                  as B@@ -32,10 +34,9 @@ import qualified Data.ByteString.Lazy                         as LBS import qualified Data.HashMap.Strict                          as HashMap import           Data.IORef-import           Data.List                                    (foldl') import qualified Data.Text                                    as T import qualified Data.Text                                    as Text-import qualified Data.Text.Utf16.Rope                         as Rope+import           Data.Text.Utf16.Rope.Mixed                   (Rope) import           Data.Time import           Data.Time.Clock.POSIX import           Development.IDE.Core.FileUtils@@ -43,12 +44,14 @@ import           Development.IDE.Core.RuleTypes import           Development.IDE.Core.Shake                   hiding (Log) import qualified Development.IDE.Core.Shake                   as Shake+import           Development.IDE.Core.WorkerThread import           Development.IDE.GHC.Orphans                  () import           Development.IDE.Graph import           Development.IDE.Import.DependencyInformation import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Location import           Development.IDE.Types.Options+import           Development.IDE.Types.Shake                  (toKey) import           HieDb.Create                                 (deleteMissingRealFiles) import           Ide.Logger                                   (Pretty (pretty),                                                                Priority (Info),@@ -58,13 +61,16 @@                                                                logWith, viaShow,                                                                (<+>)) import qualified Ide.Logger                                   as L-import           Ide.Plugin.Config                            (CheckParents (..),-                                                               Config)+import           Ide.Types+import qualified Language.LSP.Protocol.Lens                   as L import           Language.LSP.Protocol.Message                (toUntypedRegistration) import qualified Language.LSP.Protocol.Message                as LSP import           Language.LSP.Protocol.Types                  (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions),                                                                FileSystemWatcher (..),-                                                               _watchers)+                                                               TextDocumentIdentifier (..),+                                                               VersionedTextDocumentIdentifier (..),+                                                               _watchers,+                                                               uriToNormalizedFilePath) import qualified Language.LSP.Protocol.Types                  as LSP import qualified Language.LSP.Server                          as LSP import           Language.LSP.VFS@@ -72,7 +78,6 @@ import           System.IO.Error import           System.IO.Unsafe - data Log   = LogCouldNotIdentifyReverseDeps !NormalizedFilePath   | LogTypeCheckingReverseDeps !NormalizedFilePath !(Maybe [NormalizedFilePath])@@ -141,6 +146,29 @@                         then return (Nothing, ([], Nothing))                         else return (Nothing, ([diag], Nothing)) ++getPhysicalModificationTimeRule :: Recorder (WithPriority Log) -> Rules ()+getPhysicalModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetPhysicalModificationTime file ->+    getPhysicalModificationTimeImpl file++getPhysicalModificationTimeImpl+  :: NormalizedFilePath+  -> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion))+getPhysicalModificationTimeImpl file = do+    let file' = fromNormalizedFilePath file+    let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time))++    alwaysRerun++    liftIO $ fmap wrap (getModTime file')+        `catch` \(e :: IOException) -> do+            let err | isDoesNotExistError e = "File does not exist: " ++ file'+                    | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e+                diag = ideErrorText file (T.pack err)+            if isDoesNotExistError e+                then return (Nothing, ([], Nothing))+                else return (Nothing, ([diag], Nothing))+ -- | Interface files cannot be watched, since they live outside the workspace. --   But interface files are private, in that only HLS writes them. --   So we implement watching ourselves, and bypass the need for alwaysRerun.@@ -148,24 +176,28 @@ isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hi-boot", ".hie", ".hie-boot", ".core"]  -- | Reset the GetModificationTime state of interface files-resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM ()+resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM [Key] resetInterfaceStore state f = do     deleteValue state GetModificationTime f  -- | Reset the GetModificationTime state of watched files --   Assumes the list does not include any FOIs-resetFileStore :: IdeState -> [(NormalizedFilePath, LSP.FileChangeType)] -> IO ()+resetFileStore :: IdeState -> [(NormalizedFilePath, LSP.FileChangeType)] -> IO [Key] resetFileStore ideState changes = mask $ \_ -> do     -- we record FOIs document versions in all the stored values     -- so NEVER reset FOIs to avoid losing their versions     -- FOI filtering is done by the caller (LSP Notification handler)-    forM_ changes $ \(nfp, c) -> do-        case c of-            LSP.FileChangeType_Changed-            --  already checked elsewhere |  not $ HM.member nfp fois-              -> atomically $-               deleteValue (shakeExtras ideState) GetModificationTime nfp-            _ -> pure ()+    fmap concat <$>+        forM changes $ \(nfp, c) -> do+            case c of+                LSP.FileChangeType_Changed+                    --  already checked elsewhere |  not $ HM.member nfp fois+                    ->+                      atomically $ do+                        ks <- deleteValue (shakeExtras ideState) GetModificationTime nfp+                        vs <- deleteValue (shakeExtras ideState) GetPhysicalModificationTime nfp+                        pure $ ks ++ vs+                _ -> pure []   modificationTime :: FileVersion -> Maybe UTCTime@@ -177,20 +209,20 @@  getFileContentsImpl     :: NormalizedFilePath-    -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe T.Text))+    -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe Rope)) getFileContentsImpl file = do     -- need to depend on modification time to introduce a dependency with Cutoff     time <- use_ GetModificationTime file     res <- do         mbVirtual <- getVirtualFile file-        pure $ Rope.toText . _file_text <$> mbVirtual+        pure $ _file_text <$> mbVirtual     pure ([], Just (time, res))  -- | 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+getFileModTimeContents :: NormalizedFilePath -> Action (UTCTime, Maybe Rope)+getFileModTimeContents f = do+    (fv, contents) <- use_ GetFileContents f     modTime <- case modificationTime fv of       Just t -> pure t       Nothing -> do@@ -200,11 +232,34 @@           _ -> do             posix <- getModTime $ fromNormalizedFilePath f             pure $ posixSecondsToUTCTime posix-    return (modTime, txt)+    return (modTime, contents) +getFileContents :: NormalizedFilePath -> Action (Maybe Rope)+getFileContents f = snd <$> use_ GetFileContents f++getUriContents :: NormalizedUri -> Action (Maybe Rope)+getUriContents uri =+    join <$> traverse getFileContents (uriToNormalizedFilePath uri)++-- | Given a text document identifier, annotate it with the latest version.+--+-- Like Language.LSP.Server.Core.getVersionedTextDoc, but gets the virtual file+-- from the Shake VFS rather than the LSP VFS.+getVersionedTextDoc :: TextDocumentIdentifier -> Action VersionedTextDocumentIdentifier+getVersionedTextDoc doc = do+  let uri = doc ^. L.uri+  mvf <-+    maybe (pure Nothing) getVirtualFile $+        uriToNormalizedFilePath $ toNormalizedUri uri+  let ver = case mvf of+        Just (VirtualFile lspver _ _ _) -> lspver+        Nothing                         -> 0+  return (VersionedTextDocumentIdentifier uri ver)+ fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () fileStoreRules recorder isWatched = do     getModificationTimeRule recorder+    getPhysicalModificationTimeRule recorder     getFileContentsRule recorder     addWatchedFileRule recorder isWatched @@ -215,16 +270,18 @@                 -> IdeState                 -> Bool -- ^ Was the file saved?                 -> NormalizedFilePath+                -> IO [Key]                 -> IO ()-setFileModified recorder vfs state saved nfp = do+setFileModified recorder vfs state saved nfp actionBefore = do     ideOptions <- getIdeOptionsIO $ shakeExtras state     doCheckParents <- optCheckParents ideOptions     let checkParents = case doCheckParents of           AlwaysCheck -> True           CheckOnSave -> saved           _           -> False-    join $ atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp]-    restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") []+    restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] $ do+        keys<-actionBefore+        return (toKey GetModificationTime nfp:keys)     when checkParents $       typecheckParents recorder state nfp @@ -234,7 +291,7 @@  typecheckParentsAction :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action () typecheckParentsAction recorder nfp = do-    revs <- transitiveReverseDependencies nfp <$> useNoFile_ GetModuleGraph+    revs <- transitiveReverseDependencies nfp <$> useWithSeparateFingerprintRule_ GetModuleGraphTransReverseDepsFingerprints GetModuleGraph nfp     case revs of       Nothing -> logWith recorder Info $ LogCouldNotIdentifyReverseDeps nfp       Just rs -> do@@ -244,14 +301,11 @@ -- | Note that some keys have been modified and restart the session --   Only valid if the virtual file system was initialised by LSP, as that --   independently tracks which files are modified.-setSomethingModified :: VFSModified -> IdeState -> [Key] -> String -> IO ()-setSomethingModified vfs state keys reason = do+setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO ()+setSomethingModified vfs state reason actionBetweenSession = do     -- Update database to remove any files that might have been renamed/deleted-    atomically $ do-        writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)-        modifyTVar' (dirtyKeys $ shakeExtras state) $ \x ->-            foldl' (flip insertKeySet) x keys-    void $ restartShakeSession (shakeExtras state) vfs reason []+    atomically $ writeTaskQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)+    void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession  registerFileWatches :: [String] -> LSP.LspT Config IO Bool registerFileWatches globs = do@@ -265,7 +319,7 @@           -- our purposes.           registration = LSP.TRegistration { _id ="globalFileWatches"                                            , _method = LSP.SMethod_WorkspaceDidChangeWatchedFiles-                                           , _registerOptions = Just $ regOptions}+                                           , _registerOptions = Just regOptions}           regOptions =             DidChangeWatchedFilesRegistrationOptions { _watchers = watchers }           -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind@@ -306,4 +360,3 @@           Just v  -> (km, v)           Nothing -> (HashMap.insert k k km, k) {-# NOINLINE shareFilePath  #-}-
+ src/Development/IDE/Core/LookupMod.hs view
@@ -0,0 +1,24 @@+module Development.IDE.Core.LookupMod (lookupMod, LookupModule) where++import           Control.Monad.Trans.Maybe       (MaybeT (MaybeT))+import           Development.IDE.Core.Shake      (HieDbWriter, IdeAction)+import           Development.IDE.GHC.Compat.Core (ModuleName, Unit)+import           Development.IDE.Types.Location  (Uri)++-- | 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 -> Unit -> Bool -> MaybeT m Uri++-- | Eventually this will lookup/generate URIs for files in dependencies, but not in the+-- project. Right now, this is just a stub.+lookupMod ::+  -- | access the database+  HieDbWriter ->+  -- | The `.hie` file we got from the database+  FilePath ->+  ModuleName ->+  Unit ->+  -- | Is this file a boot file?+  Bool ->+  MaybeT IdeAction Uri+lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing
src/Development/IDE/Core/OfInterest.hs view
@@ -1,8 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE TypeFamilies #-}  -- | Utilities and state for the files of interest - those which are currently --   open in the editor. The rule is 'IsFileOfInterest'@@ -25,7 +24,6 @@ import           Data.HashMap.Strict                      (HashMap) import qualified Data.HashMap.Strict                      as HashMap import           Data.Proxy-import qualified Data.Text                                as T import           Development.IDE.Graph  import           Control.Concurrent.STM.Stats             (atomically,@@ -41,12 +39,14 @@ import           Development.IDE.Types.Exports import           Development.IDE.Types.Location import           Development.IDE.Types.Options            (IdeTesting (..))+import           Development.IDE.Types.Shake              (toKey) import           GHC.TypeLits                             (KnownSymbol) import           Ide.Logger                               (Pretty (pretty),+                                                           Priority (..),                                                            Recorder,                                                            WithPriority,                                                            cmapWithPrio,-                                                           logDebug)+                                                           logWith) import qualified Language.LSP.Protocol.Message            as LSP import qualified Language.LSP.Server                      as LSP @@ -103,24 +103,26 @@     OfInterestVar var <- getIdeGlobalAction     liftIO $ readVar var -addFileOfInterest :: IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()+addFileOfInterest :: IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key] addFileOfInterest state f v = do     OfInterestVar var <- getIdeGlobalState state     (prev, files) <- modifyVar var $ \dict -> do         let (prev, new) = HashMap.alterF (, Just v) f dict         pure (new, (prev, new))-    when (prev /= Just v) $ do-        join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]-        logDebug (ideLogger state) $-            "Set files of interest to: " <> T.pack (show files)+    if prev /= Just v+    then do+        logWith (ideLogger state) Debug $+            LogSetFilesOfInterest (HashMap.toList files)+        return [toKey IsFileOfInterest f]+    else return [] -deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO ()+deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO [Key] deleteFileOfInterest state f = do     OfInterestVar var <- getIdeGlobalState state     files <- modifyVar' var $ HashMap.delete f-    join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]-    logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files)-+    logWith (ideLogger state) Debug $+        LogSetFilesOfInterest (HashMap.toList files)+    return [toKey IsFileOfInterest f] scheduleGarbageCollection :: IdeState -> IO () scheduleGarbageCollection state = do     GarbageCollectVar var <- getIdeGlobalState state@@ -139,7 +141,7 @@                 toJSON $ map fromNormalizedFilePath files      signal (Proxy @"kick/start")-    liftIO $ progressUpdate progress KickStarted+    liftIO $ progressUpdate progress ProgressNewStarted      -- Update the exports map     results <- uses GenerateCore files@@ -150,7 +152,7 @@     let mguts = catMaybes results     void $ liftIO $ atomically $ modifyTVar' exportsMap (updateExportsMapMg mguts) -    liftIO $ progressUpdate progress KickCompleted+    liftIO $ progressUpdate progress ProgressCompleted      GarbageCollectVar var <- getIdeGlobalAction     garbageCollectionScheduled <- liftIO $ readVar var
src/Development/IDE/Core/PluginUtils.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} module Development.IDE.Core.PluginUtils-(-- Wrapped Action functions+(-- * Wrapped Action functions   runActionE , runActionMT , useE@@ -9,13 +9,13 @@ , usesMT , useWithStaleE , useWithStaleMT--- Wrapped IdeAction functions+-- * Wrapped IdeAction functions , runIdeActionE , runIdeActionMT , useWithStaleFastE , useWithStaleFastMT , uriToFilePathE--- Wrapped PositionMapping functions+-- * Wrapped PositionMapping functions , toCurrentPositionE , toCurrentPositionMT , fromCurrentPositionE@@ -23,16 +23,27 @@ , toCurrentRangeE , toCurrentRangeMT , fromCurrentRangeE-, fromCurrentRangeMT) where+, fromCurrentRangeMT+-- * Diagnostics+, activeDiagnosticsInRange+, activeDiagnosticsInRangeMT+, injectServerDiagnostics+-- * Formatting handlers+, mkFormattingHandlers) where +import           Control.Concurrent.STM+import           Control.Lens+import           Control.Monad.Error.Class            (MonadError (throwError)) import           Control.Monad.Extra import           Control.Monad.IO.Class import           Control.Monad.Reader                 (runReaderT) import           Control.Monad.Trans.Except import           Control.Monad.Trans.Maybe-import           Data.Functor.Identity import qualified Data.Text                            as T+import qualified Data.Text.Utf16.Rope.Mixed           as Rope+import           Development.IDE.Core.FileStore import           Development.IDE.Core.PositionMapping+import           Development.IDE.Core.Service         (runAction) import           Development.IDE.Core.Shake           (IdeAction, IdeRule,                                                        IdeState (shakeExtras),                                                        mkDelayedAction,@@ -40,11 +51,18 @@ import qualified Development.IDE.Core.Shake           as Shake import           Development.IDE.GHC.Orphans          () import           Development.IDE.Graph                hiding (ShakeValue)+import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Location       (NormalizedFilePath) import qualified Development.IDE.Types.Location       as Location import qualified Ide.Logger                           as Logger import           Ide.Plugin.Error+import           Ide.PluginUtils                      (rangesOverlap)+import           Ide.Types+import qualified Language.LSP.Protocol.Lens           as LSP+import           Language.LSP.Protocol.Message        (SMethod (..))+import           Language.LSP.Protocol.Types          (CodeActionParams) import qualified Language.LSP.Protocol.Types          as LSP+import qualified StmContainers.Map                    as STM  -- ---------------------------------------------------------------------------- -- Action wrappers@@ -162,3 +180,89 @@ -- |MaybeT version of `fromCurrentRange` fromCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range fromCurrentRangeMT mapping = MaybeT . pure . fromCurrentRange mapping++-- ----------------------------------------------------------------------------+-- Diagnostics+-- ----------------------------------------------------------------------------++-- | @'activeDiagnosticsInRangeMT' shakeExtras nfp range@ computes the+-- 'FileDiagnostic' 's that HLS produced and overlap with the given @range@.+--+-- This function is to be used whenever we need an authoritative source of truth+-- for which diagnostics are shown to the user.+-- These diagnostics can be used to provide various IDE features, for example+-- CodeActions, CodeLenses, or refactorings.+--+-- However, why do we need this when computing 'CodeAction's? A 'CodeActionParam'+-- has the 'CodeActionContext' which already contains the diagnostics!+-- But according to the LSP docs, the server shouldn't rely that these Diagnostic+-- are actually up-to-date and accurately reflect the state of the document.+--+-- From the LSP docs:+-- > An array of diagnostics known on the client side overlapping the range+-- > provided to the `textDocument/codeAction` request. They are provided so+-- > that the server knows which errors are currently presented to the user+-- > for the given range. There is no guarantee that these accurately reflect+-- > the error state of the resource. The primary parameter+-- > to compute code actions is the provided range.+--+-- Thus, even when the client sends us the context, we should compute the+-- diagnostics on the server side.+activeDiagnosticsInRangeMT :: MonadIO m => Shake.ShakeExtras -> NormalizedFilePath -> LSP.Range -> MaybeT m [FileDiagnostic]+activeDiagnosticsInRangeMT ide nfp range = do+    MaybeT $ liftIO $ atomically $ do+        mDiags <- STM.lookup (LSP.normalizedFilePathToUri nfp) (Shake.publishedDiagnostics ide)+        case mDiags of+            Nothing -> pure Nothing+            Just fileDiags -> do+                pure $ Just $ filter diagRangeOverlaps fileDiags+    where+        diagRangeOverlaps = \fileDiag ->+            rangesOverlap range (fileDiag ^. fdLspDiagnosticL . LSP.range)++-- | Just like 'activeDiagnosticsInRangeMT'. See the docs of 'activeDiagnosticsInRangeMT' for details.+activeDiagnosticsInRange :: MonadIO m => Shake.ShakeExtras -> NormalizedFilePath -> LSP.Range -> m (Maybe [FileDiagnostic])+activeDiagnosticsInRange ide nfp range = runMaybeT (activeDiagnosticsInRangeMT ide nfp range)++-- Prefer server-side diagnostics if available; they are authoritative.+injectServerDiagnostics :: IdeState -> CodeActionParams -> IO CodeActionParams+injectServerDiagnostics ide params@LSP.CodeActionParams{_textDocument=LSP.TextDocumentIdentifier{_uri}, _range} = do+  serverDiags <- case LSP.uriToNormalizedFilePath (LSP.toNormalizedUri _uri) of+    Nothing  -> pure []+    Just nfp -> do+      mDiags <- activeDiagnosticsInRange (shakeExtras ide) nfp _range+      case mDiags of+        Nothing    -> pure []+        Just diags -> pure $ diags ^.. traverse . fdLspDiagnosticL+  pure $ params & LSP.context . LSP.diagnostics .~ serverDiags++-- ----------------------------------------------------------------------------+-- Formatting handlers+-- ----------------------------------------------------------------------------++-- `mkFormattingHandlers` was moved here from hls-plugin-api package so that+-- `mkFormattingHandlers` can refer to `IdeState`. `IdeState` is defined in the+-- ghcide package, but hls-plugin-api does not depend on ghcide, so `IdeState`+-- is not in scope there.++mkFormattingHandlers :: FormattingHandler IdeState -> PluginHandlers IdeState+mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provider SMethod_TextDocumentFormatting)+                      <> mkPluginHandler SMethod_TextDocumentRangeFormatting (provider SMethod_TextDocumentRangeFormatting)+  where+    provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler IdeState m+    provider m ide _pid params+      | Just nfp <- LSP.uriToNormalizedFilePath $ LSP.toNormalizedUri uri = do+        contentsMaybe <- liftIO $ runAction "mkFormattingHandlers" ide $ getFileContents nfp+        case contentsMaybe of+          Just contents -> do+            let (typ, mtoken) = case m of+                  SMethod_TextDocumentFormatting -> (FormatText, params ^. LSP.workDoneToken)+                  SMethod_TextDocumentRangeFormatting -> (FormatRange (params ^. LSP.range), params ^. LSP.workDoneToken)+                  _ -> Prelude.error "mkFormattingHandlers: impossible"+            f ide mtoken typ (Rope.toText contents) nfp opts+          Nothing -> throwError $ PluginInvalidParams $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri++      | otherwise = throwError $ PluginInvalidParams $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri+      where+        uri = params ^. LSP.textDocument . LSP.uri+        opts = params ^. LSP.options
src/Development/IDE/Core/PositionMapping.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedLabels #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 module Development.IDE.Core.PositionMapping@@ -10,7 +9,7 @@   , fromCurrentPosition   , toCurrentPosition   , PositionDelta(..)-  , addDelta+  , addOldDelta   , idDelta   , composeDelta   , mkDelta@@ -25,13 +24,14 @@   ) where  import           Control.DeepSeq+import           Control.Lens                ((^.)) import           Control.Monad import           Data.Algorithm.Diff import           Data.Bifunctor import           Data.List-import           Data.Row import qualified Data.Text                   as T import qualified Data.Vector.Unboxed         as V+import qualified Language.LSP.Protocol.Lens  as L import           Language.LSP.Protocol.Types (Position (Position),                                               Range (Range),                                               TextDocumentContentChangeEvent (TextDocumentContentChangeEvent),@@ -119,16 +119,20 @@ 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)+-- | addOldDelta+-- Add a old delta onto a Mapping k n to make a Mapping (k - 1) n+addOldDelta ::+    PositionDelta -- ^ delta from version k - 1 to version k+    -> PositionMapping -- ^ The input mapping is from version k to version n+    -> PositionMapping -- ^ The output mapping is from version k - 1 to version n+addOldDelta delta (PositionMapping pm) = PositionMapping (composeDelta pm delta)  -- TODO: We currently ignore the right hand side (if there is only text), as -- that was what was done with lsp* 1.6 packages applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta applyChange PositionDelta{..} (TextDocumentContentChangeEvent (InL x)) = PositionDelta-    { toDelta = toCurrent (x .! #range) (x .! #text) <=< toDelta-    , fromDelta = fromDelta <=< fromCurrent (x .! #range) (x .! #text)+    { toDelta = toCurrent (x ^. L.range) (x ^. L.text) <=< toDelta+    , fromDelta = fromDelta <=< fromCurrent (x ^. L.range) (x ^. L.text)     } applyChange posMapping _ = posMapping
src/Development/IDE/Core/Preprocessor.hs view
@@ -28,14 +28,13 @@ import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Location import qualified GHC.LanguageExtensions            as LangExt-import           System.FilePath-import           System.IO.Extra---- See Note [Guidelines For Using CPP In GHCIDE Import Statements]--#if MIN_VERSION_ghc(9,3,0)+import qualified GHC.Runtime.Loader                as Loader import           GHC.Utils.Logger                  (LogFlags (..))+#if MIN_VERSION_ghc(9,13,0)+import           GHC.Driver.Config.Parser          (supportedLanguagePragmas) #endif+import           System.FilePath+import           System.IO.Extra  -- | Given a file and some contents, apply any necessary preprocessors, --   e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.@@ -88,11 +87,7 @@   where     logAction :: IORef [CPPLog] -> LogActionCompat     logAction cppLogs dflags _reason severity srcSpan _style msg = do-#if MIN_VERSION_ghc(9,3,0)       let cppLog = CPPLog (fromMaybe SevWarning severity) srcSpan $ T.pack $ renderWithContext (log_default_user_context dflags) msg-#else-      let cppLog = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg-#endif       modifyIORef cppLogs (cppLog :)  @@ -112,7 +107,7 @@  diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic] diagsFromCPPLogs filename logs =-  map (\d -> (toNormalizedFilePath' filename, ShowDiag, cppDiagToDiagnostic d)) $+  map (\d -> ideErrorFromLspDiag (cppDiagToDiagnostic d) (toNormalizedFilePath' filename) Nothing) $     go [] logs   where     -- On errors, CPP calls logAction with a real span for the initial log and@@ -152,17 +147,22 @@     -> Util.StringBuffer     -> IO (Either [FileDiagnostic] ([String], HscEnv)) parsePragmasIntoHscEnv env fp contents = catchSrcErrors dflags0 "pragmas" $ do-#if MIN_VERSION_ghc(9,3,0)-    let (_warns,opts) = getOptions (initParserOpts dflags0) contents fp+#if MIN_VERSION_ghc(9,13,0)+    let supportedExts = supportedLanguagePragmas dflags0+    let (_warns,opts) = getOptions (initParserOpts dflags0) supportedExts contents fp #else-    let opts = getOptions dflags0 contents fp+    let (_warns,opts) = getOptions (initParserOpts dflags0) contents fp #endif      -- Force bits that might keep the dflags and stringBuffer alive unnecessarily     evaluate $ rnf opts +#if MIN_VERSION_ghc(9,13,0)+    (dflags, _, _) <- parseDynamicFilePragma (hsc_logger env) dflags0 opts+#else     (dflags, _, _) <- parseDynamicFilePragma dflags0 opts-    hsc_env' <- initializePlugins (hscSetFlags dflags env)+#endif+    hsc_env' <- Loader.initializePlugins (hscSetFlags dflags env)     return (map unLoc opts, hscSetFlags (disableWarningsAsErrors $ hsc_dflags hsc_env') hsc_env')   where dflags0 = hsc_dflags env
src/Development/IDE/Core/ProgressReporting.hs view
@@ -1,208 +1,236 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+ module Development.IDE.Core.ProgressReporting-  ( ProgressEvent(..)-  , ProgressReporting(..)-  , noProgressReporting-  , delayedProgressReporting-  -- utilities, reexported for use in Core.Shake-  , mRunLspT-  , mRunLspTCallback-  -- for tests-  , recordProgress-  , InProgressState(..)+  ( ProgressEvent (..),+    PerFileProgressReporting (..),+    ProgressReporting,+    noPerFileProgressReporting,+    progressReporting,+    progressReportingNoTrace,+    -- utilities, reexported for use in Core.Shake+    mRunLspT,+    mRunLspTCallback,+    -- for tests+    recordProgress,+    InProgressState (..),+    progressStop,+    progressUpdate   )-   where+where -import           Control.Concurrent.Async-import           Control.Concurrent.STM.Stats   (TVar, atomicallyNamed,-                                                 modifyTVar', newTVarIO,-                                                 readTVarIO)-import           Control.Concurrent.Strict+import           Control.Concurrent.STM         (STM)+import           Control.Concurrent.STM.Stats   (TVar, atomically,+                                                 atomicallyNamed, modifyTVar',+                                                 newTVarIO, readTVar, retry)+import           Control.Concurrent.Strict      (modifyVar_, newVar,+                                                 threadDelay) import           Control.Monad.Extra            hiding (loop) import           Control.Monad.IO.Class import           Control.Monad.Trans.Class      (lift)-import           Data.Aeson                     (ToJSON (toJSON))-import           Data.Foldable                  (for_) import           Data.Functor                   (($>)) import qualified Data.Text                      as T-import           Data.Unique import           Development.IDE.GHC.Orphans    ()-import           Development.IDE.Graph          hiding (ShakeValue) import           Development.IDE.Types.Location import           Development.IDE.Types.Options import qualified Focus-import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types-import qualified Language.LSP.Protocol.Types    as LSP+import           Language.LSP.Server            (ProgressAmount (..),+                                                 ProgressCancellable (..),+                                                 withProgress) import qualified Language.LSP.Server            as LSP import qualified StmContainers.Map              as STM-import           System.Time.Extra-import           UnliftIO.Exception             (bracket_)+import           UnliftIO                       (Async, async, bracket, cancel)  data ProgressEvent-    = KickStarted-    | KickCompleted+  = ProgressNewStarted+  | ProgressCompleted+  | ProgressStarted -data ProgressReporting  = ProgressReporting-  { progressUpdate :: ProgressEvent -> IO ()-  , inProgress     :: forall a. NormalizedFilePath -> Action a -> Action a-  , progressStop   :: IO ()+data ProgressReporting = ProgressReporting+  { _progressUpdate :: ProgressEvent -> IO (),+    _progressStop   :: IO ()+    -- ^ we are using IO here because creating and stopping the `ProgressReporting`+    -- is different from how we use it.   } -noProgressReporting :: IO ProgressReporting-noProgressReporting = return $ ProgressReporting-  { progressUpdate = const $ pure ()-  , inProgress = const id-  , progressStop   = pure ()+data PerFileProgressReporting = PerFileProgressReporting+  {+    inProgress             :: forall a. NormalizedFilePath -> IO a -> IO a,+    -- ^ see Note [ProgressReporting API and InProgressState]+    progressReportingInner :: ProgressReporting   } +class ProgressReporter a where+    progressUpdate ::  a -> ProgressEvent -> IO ()+    progressStop :: a -> IO ()++instance ProgressReporter ProgressReporting where+    progressUpdate = _progressUpdate+    progressStop = _progressStop++instance ProgressReporter PerFileProgressReporting where+    progressUpdate = _progressUpdate . progressReportingInner+    progressStop = _progressStop . progressReportingInner++{- Note [ProgressReporting API and InProgressState]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The progress of tasks can be tracked in two ways:++1. `ProgressReporting`: we have an internal state that actively tracks the progress.+   Changes to the progress are made directly to this state.++2. `ProgressReporting`: there is an external state that tracks the progress.+   The external state is converted into an STM Int for the purpose of reporting progress.++The `inProgress` function is only useful when we are using `ProgressReporting`.+-}++noProgressReporting :: ProgressReporting+noProgressReporting = ProgressReporting+      { _progressUpdate = const $ pure (),+        _progressStop = pure ()+      }+noPerFileProgressReporting :: IO PerFileProgressReporting+noPerFileProgressReporting =+  return $+    PerFileProgressReporting+      { inProgress = const id,+        progressReportingInner = noProgressReporting+      }+ -- | State used in 'delayedProgressReporting' data State-    = NotStarted-    | Stopped-    | Running (Async ())+  = NotStarted+  | Stopped+  | Running (Async ())  -- | State transitions used in 'delayedProgressReporting' data Transition = Event ProgressEvent | StopProgress -updateState :: IO (Async ()) -> Transition -> State -> IO State-updateState _      _                    Stopped     = pure Stopped-updateState start (Event KickStarted)   NotStarted  = Running <$> start-updateState start (Event KickStarted)   (Running a) = cancel a >> Running <$> start-updateState _     (Event KickCompleted) (Running a) = cancel a $> NotStarted-updateState _     (Event KickCompleted) st          = pure st-updateState _     StopProgress          (Running a) = cancel a $> Stopped-updateState _     StopProgress          st          = pure st+updateState :: IO () -> Transition -> State -> IO State+updateState _ _ Stopped = pure Stopped+updateState start (Event ProgressNewStarted) NotStarted = Running <$> async start+updateState start (Event ProgressNewStarted) (Running job) = cancel job >> Running <$> async start+updateState start (Event ProgressStarted) NotStarted = Running <$> async start+updateState _ (Event ProgressStarted) (Running job) = return (Running job)+updateState _ (Event ProgressCompleted) (Running job) = cancel job $> NotStarted+updateState _ (Event ProgressCompleted) st = pure st+updateState _ StopProgress (Running job) = cancel job $> Stopped+updateState _ StopProgress st = pure st  -- | Data structure to track progress across the project-data InProgressState = InProgressState-    { todoVar    :: TVar Int  -- ^ Number of files to do-    , doneVar    :: TVar Int  -- ^ Number of files done-    , currentVar :: STM.Map NormalizedFilePath Int-    }+-- see Note [ProgressReporting API and InProgressState]+data InProgressState+  = InProgressState+      { -- | Number of files to do+        todoVar    :: TVar Int,+        -- | Number of files done+        doneVar    :: TVar Int,+        currentVar :: STM.Map NormalizedFilePath Int+      }  newInProgress :: IO InProgressState newInProgress = InProgressState <$> newTVarIO 0 <*> newTVarIO 0 <*> STM.newIO  recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO ()-recordProgress InProgressState{..} file shift = do-    (prev, new) <- atomicallyNamed "recordProgress" $ STM.focus alterPrevAndNew file currentVar-    atomicallyNamed "recordProgress2" $ do-        case (prev,new) of-            (Nothing,0) -> modifyTVar' doneVar (+1) >> modifyTVar' todoVar (+1)-            (Nothing,_) -> modifyTVar' todoVar (+1)-            (Just 0, 0) -> pure ()-            (Just 0, _) -> modifyTVar' doneVar pred-            (Just _, 0) -> modifyTVar' doneVar (+1)-            (Just _, _) -> pure()+recordProgress InProgressState {..} file shift = do+  (prev, new) <- atomicallyNamed "recordProgress" $ STM.focus alterPrevAndNew file currentVar+  atomicallyNamed "recordProgress2" $ case (prev, new) of+    (Nothing, 0) -> modifyTVar' doneVar (+ 1) >> modifyTVar' todoVar (+ 1)+    (Nothing, _) -> modifyTVar' todoVar (+ 1)+    (Just 0, 0)  -> pure ()+    (Just 0, _)  -> modifyTVar' doneVar pred+    (Just _, 0)  -> modifyTVar' doneVar (+ 1)+    (Just _, _)  -> pure ()   where     alterPrevAndNew = do-        prev <- Focus.lookup-        Focus.alter alter-        new <- Focus.lookupWithDefault 0-        return (prev, new)+      prev <- Focus.lookup+      Focus.alter alter+      new <- Focus.lookupWithDefault 0+      return (prev, new)     alter x = let x' = maybe (shift 0) shift x in Just x' --- | A 'ProgressReporting' that enqueues Begin and End notifications in a new---   thread, with a grace period (nothing will be sent if 'KickCompleted' arrives---   before the end of the grace period).-delayedProgressReporting-  :: Seconds  -- ^ Grace period before starting-  -> Seconds  -- ^ sampling delay-  -> Maybe (LSP.LanguageContextEnv c)-  -> ProgressReportingStyle-  -> IO ProgressReporting-delayedProgressReporting _before _after Nothing _optProgressStyle = noProgressReporting-delayedProgressReporting before after (Just lspEnv) optProgressStyle = do-    inProgressState <- newInProgress-    progressState <- newVar NotStarted-    let progressUpdate event = updateStateVar $ Event event-        progressStop   =  updateStateVar StopProgress-        updateStateVar = modifyVar_ progressState . updateState (lspShakeProgress inProgressState) -        inProgress = updateStateForFile inProgressState-    return ProgressReporting{..}-    where-        lspShakeProgress InProgressState{..} = 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 $ sleep before-            u <- ProgressToken . InR . T.pack . show . hashUnique <$> liftIO newUnique+-- | `progressReportingNoTrace` initiates a new progress reporting session.+-- It functions similarly to `progressReporting`, but it utilizes an external state for progress tracking.+-- Refer to Note [ProgressReporting API and InProgressState] for more details.+progressReportingNoTrace ::+  STM Int ->+  STM Int ->+  Maybe (LSP.LanguageContextEnv c) ->+  T.Text ->+  ProgressReportingStyle ->+  IO ProgressReporting+progressReportingNoTrace _ _ Nothing _title _optProgressStyle = return noProgressReporting+progressReportingNoTrace todo done (Just lspEnv) title optProgressStyle = do+  progressState <- newVar NotStarted+  let _progressUpdate event = liftIO $ updateStateVar $ Event event+      _progressStop = updateStateVar StopProgress+      updateStateVar = modifyVar_ progressState . updateState (progressCounter lspEnv title optProgressStyle todo done)+  return ProgressReporting {..} -            b <- liftIO newBarrier-            void $ LSP.runLspT lspEnv $ LSP.sendRequest SMethod_WindowWorkDoneProgressCreate-                LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b-            liftIO $ async $ do-                ready <- waitBarrier b-                LSP.runLspT lspEnv $ for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0)-            where-                start token = LSP.sendNotification SMethod_Progress $-                    LSP.ProgressParams-                        { _token = token-                        , _value = toJSON $ WorkDoneProgressBegin-                          { _kind = AString @"begin"-                          ,  _title = "Processing"-                          , _cancellable = Nothing-                          , _message = Nothing-                          , _percentage = Nothing-                          }-                        }-                stop token = LSP.sendNotification SMethod_Progress-                    LSP.ProgressParams-                        { _token = token-                        , _value = toJSON $ WorkDoneProgressEnd-                          { _kind = AString @"end"-                           , _message = Nothing-                          }-                        }-                loop _ _ | optProgressStyle == NoProgress =-                    forever $ liftIO $ threadDelay maxBound-                loop token prevPct = do-                    done <- liftIO $ readTVarIO doneVar-                    todo <- liftIO $ readTVarIO todoVar-                    liftIO $ sleep after-                    if todo == 0 then loop token 0 else do-                        let-                            nextFrac :: Double-                            nextFrac = fromIntegral done / fromIntegral todo-                            nextPct :: UInt-                            nextPct = floor $ 100 * nextFrac-                        when (nextPct /= prevPct) $-                          LSP.sendNotification SMethod_Progress $-                          LSP.ProgressParams-                              { _token = token-                              , _value = case optProgressStyle of-                                  Explicit -> toJSON $ WorkDoneProgressReport-                                    { _kind = AString @"report"-                                    , _cancellable = Nothing-                                    , _message = Just $ T.pack $ show done <> "/" <> show todo-                                    , _percentage = Nothing-                                    }-                                  Percentage -> toJSON $ WorkDoneProgressReport-                                    { _kind = AString @"report"-                                    , _cancellable = Nothing-                                    , _message = Nothing-                                    , _percentage = Just nextPct-                                    }-                                  NoProgress -> error "unreachable"-                              }-                        loop token nextPct+-- | `progressReporting` initiates a new progress reporting session.+-- It necessitates the active tracking of progress using the `inProgress` function.+-- Refer to Note [ProgressReporting API and InProgressState] for more details.+progressReporting ::+  Maybe (LSP.LanguageContextEnv c) ->+  T.Text ->+  ProgressReportingStyle ->+  IO PerFileProgressReporting+progressReporting Nothing _title _optProgressStyle = noPerFileProgressReporting+progressReporting (Just lspEnv) title optProgressStyle = do+  inProgressState <- newInProgress+  progressReportingInner <- progressReportingNoTrace (readTVar $ todoVar inProgressState)+                                (readTVar $ doneVar inProgressState) (Just lspEnv) title optProgressStyle+  let+    inProgress :: NormalizedFilePath -> IO a -> IO a+    inProgress = updateStateForFile inProgressState+  return PerFileProgressReporting {..}+  where+    updateStateForFile inProgress file = UnliftIO.bracket (liftIO $ f succ) (const $ liftIO $ f pred) . const+      where+        -- 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. -        updateStateForFile inProgress 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 = recordProgress inProgress file shift+        f = recordProgress inProgress file -mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m ()+-- Kill this to complete the progress session+progressCounter ::+  LSP.LanguageContextEnv c ->+  T.Text ->+  ProgressReportingStyle ->+  STM Int ->+  STM Int ->+  IO ()+progressCounter lspEnv title optProgressStyle getTodo getDone =+  LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0+  where+    loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound+    loop update prevPct = do+      (todo, done, nextPct) <- liftIO $ atomically $ do+        todo <- getTodo+        done <- getDone+        let nextFrac :: Double+            nextFrac = if todo == 0 then 0 else fromIntegral done / fromIntegral todo+            nextPct :: UInt+            nextPct = floor $ 100 * nextFrac+        when (nextPct == prevPct) retry+        pure (todo, done, nextPct)++      _ <- update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo))+      loop update nextPct++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 ::+  (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
src/Development/IDE/Core/RuleTypes.hs view
@@ -1,8 +1,8 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE DeriveAnyClass     #-} {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleInstances  #-} {-# LANGUAGE GADTs              #-} {-# LANGUAGE PatternSynonyms    #-} {-# LANGUAGE TemplateHaskell    #-}@@ -17,7 +17,7 @@     ) where  import           Control.DeepSeq-import           Control.Exception                            (assert)+import qualified Control.Exception                            as E import           Control.Lens import           Data.Aeson.Types                             (Value) import           Data.Hashable@@ -34,14 +34,20 @@ import           Development.IDE.Types.HscEnvEq               (HscEnvEq) import           Development.IDE.Types.KnownTargets import           GHC.Generics                                 (Generic)+import           GHC.Iface.Ext.Types                          (HieASTs,+                                                               TypeIndex)+import           GHC.Iface.Ext.Utils                          (RefMap)  import           Data.ByteString                              (ByteString)-import           Data.Text                                    (Text)+import           Data.Text.Utf16.Rope.Mixed                   (Rope) import           Development.IDE.Import.FindImports           (ArtifactsLocation) import           Development.IDE.Spans.Common import           Development.IDE.Spans.LocalBindings import           Development.IDE.Types.Diagnostics+import           GHC.Driver.Errors.Types                      (WarningMessages) import           GHC.Serialized                               (Serialized)+import           Ide.Logger                                   (Pretty (..),+                                                               viaShow) import           Language.LSP.Protocol.Types                  (Int32,                                                                NormalizedFilePath) @@ -71,6 +77,12 @@  type instance RuleResult GetModuleGraph = DependencyInformation +-- | it only compute the fingerprint of the module graph for a file and its dependencies+-- we need this to trigger recompilation when the sub module graph for a file changes+type instance RuleResult GetModuleGraphTransDepsFingerprints = Fingerprint+type instance RuleResult GetModuleGraphTransReverseDepsFingerprints = Fingerprint+type instance RuleResult GetModuleGraphImmediateReverseDepsFingerprints = Fingerprint+ data GetKnownTargets = GetKnownTargets   deriving (Show, Generic, Eq, Ord) instance Hashable GetKnownTargets@@ -81,7 +93,7 @@ type instance RuleResult GenerateCore = ModGuts  data GenerateCore = GenerateCore-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GenerateCore instance NFData   GenerateCore @@ -101,12 +113,12 @@     rnf = rwhnf  data GetLinkable = GetLinkable-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetLinkable instance NFData   GetLinkable  data GetImportMap = GetImportMap-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetImportMap instance NFData   GetImportMap @@ -156,6 +168,8 @@         -- ^ Which modules did we need at runtime while compiling this file?         -- Used for recompilation checking in the presence of TH         -- Stores the hash of their core file+    , tmrWarnings        :: WarningMessages+        -- ^ Structured warnings for this module.     } instance Show TcModuleResult where     show = show . pm_mod_summary . tmrParsed@@ -187,9 +201,9 @@  mkHiFileResult :: ModSummary -> ModIface -> ModDetails -> ModuleEnv ByteString -> Maybe (CoreFile, ByteString) -> HiFileResult mkHiFileResult hirModSummary hirModIface hirModDetails hirRuntimeModules hirCoreFp =-    assert (case hirCoreFp of Just (CoreFile{cf_iface_hash}, _)-                                -> getModuleHash hirModIface == cf_iface_hash-                              _ -> True)+    E.assert (case hirCoreFp of+                   Just (CoreFile{cf_iface_hash}, _) -> getModuleHash hirModIface == cf_iface_hash+                   _ -> True)     HiFileResult{..}   where     hirIfaceFp = fingerprintToBS . getModuleHash $ hirModIface -- will always be two bytes@@ -238,14 +252,20 @@ -- | 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+data DocAndTyThingMap = DKMap+    { getDocMap     :: !DocMap+    -- ^ Docs for declarations: functions, data types, instances, methods, etc+    , getTyThingMap :: !TyThingMap+    , getArgDocMap  :: !ArgDocMap+    -- ^ Docs for arguments, e.g., function arguments and method arguments+    }+instance NFData DocAndTyThingMap where+    rnf (DKMap a b c) = rwhnf a `seq` rwhnf b `seq` rwhnf c -instance Show DocAndKindMap where+instance Show DocAndTyThingMap where     show = const "docmap" -type instance RuleResult GetDocMap = DocAndKindMap+type instance RuleResult GetDocMap = DocAndTyThingMap  -- | A GHC session that we reuse. type instance RuleResult GhcSession = HscEnvEq@@ -274,10 +294,12 @@ type instance RuleResult GetModIface = HiFileResult  -- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.-type instance RuleResult GetFileContents = (FileVersion, Maybe Text)+type instance RuleResult GetFileContents = (FileVersion, Maybe Rope)  type instance RuleResult GetFileExists = Bool +type instance RuleResult GetFileHash = Fingerprint+ type instance RuleResult AddWatchedFile = Bool  @@ -303,6 +325,13 @@  instance NFData   GetModificationTime +data GetPhysicalModificationTime = GetPhysicalModificationTime+    deriving (Generic, Show, Eq)+    deriving anyclass (Hashable, NFData)++-- | Get the modification time of a file on disk, ignoring any version in the VFS.+type instance RuleResult GetPhysicalModificationTime = FileVersion+ pattern GetModificationTime :: GetModificationTime pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True} @@ -328,21 +357,30 @@ instance NFData   GetFileContents  data GetFileExists = GetFileExists-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic)  instance NFData   GetFileExists instance Hashable GetFileExists +data GetFileHash = GetFileHash+    deriving (Eq, Show, Generic)++instance NFData   GetFileHash+instance Hashable GetFileHash+ data FileOfInterestStatus   = OnDisk   | Modified { firstOpen :: !Bool -- ^ was this file just opened              }-  deriving (Eq, Show, Typeable, Generic)+  deriving (Eq, Show, Generic) instance Hashable FileOfInterestStatus instance NFData   FileOfInterestStatus +instance Pretty FileOfInterestStatus where+    pretty = viaShow+ data IsFileOfInterestResult = NotFOI | IsFOI FileOfInterestStatus-  deriving (Eq, Show, Typeable, Generic)+  deriving (Eq, Show, Generic) instance Hashable IsFileOfInterestResult instance NFData   IsFileOfInterestResult @@ -374,17 +412,17 @@ type instance RuleResult GetModSummaryWithoutTimestamps = ModSummaryResult  data GetParsedModule = GetParsedModule-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetParsedModule instance NFData   GetParsedModule  data GetParsedModuleWithComments = GetParsedModuleWithComments-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetParsedModuleWithComments instance NFData   GetParsedModuleWithComments  data GetLocatedImports = GetLocatedImports-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetLocatedImports instance NFData   GetLocatedImports @@ -392,42 +430,57 @@ type instance RuleResult NeedsCompilation = Maybe LinkableType  data NeedsCompilation = NeedsCompilation-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable NeedsCompilation instance NFData   NeedsCompilation  data GetModuleGraph = GetModuleGraph-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetModuleGraph instance NFData   GetModuleGraph +data GetModuleGraphTransDepsFingerprints = GetModuleGraphTransDepsFingerprints+    deriving (Eq, Show, Generic)+instance Hashable GetModuleGraphTransDepsFingerprints+instance NFData   GetModuleGraphTransDepsFingerprints++data GetModuleGraphTransReverseDepsFingerprints = GetModuleGraphTransReverseDepsFingerprints+    deriving (Eq, Show, Generic)+instance Hashable GetModuleGraphTransReverseDepsFingerprints+instance NFData   GetModuleGraphTransReverseDepsFingerprints++data GetModuleGraphImmediateReverseDepsFingerprints = GetModuleGraphImmediateReverseDepsFingerprints+    deriving (Eq, Show, Generic)+instance Hashable GetModuleGraphImmediateReverseDepsFingerprints+instance NFData   GetModuleGraphImmediateReverseDepsFingerprints+ data ReportImportCycles = ReportImportCycles-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable ReportImportCycles instance NFData   ReportImportCycles  data TypeCheck = TypeCheck-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable TypeCheck instance NFData   TypeCheck  data GetDocMap = GetDocMap-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetDocMap instance NFData   GetDocMap  data GetHieAst = GetHieAst-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetHieAst instance NFData   GetHieAst  data GetBindings = GetBindings-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetBindings instance NFData   GetBindings  data GhcSession = GhcSession-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GhcSession instance NFData   GhcSession @@ -436,7 +489,7 @@         -- Required for interactive evaluation, but leads to more cache invalidations         fullModSummary :: Bool     }-    deriving newtype (Eq, Typeable, Hashable, NFData)+    deriving newtype (Eq, Hashable, NFData)  instance Show GhcSessionDeps where     show (GhcSessionDeps_ False) = "GhcSessionDeps"@@ -446,45 +499,45 @@ pattern GhcSessionDeps = GhcSessionDeps_ False  data GetModIfaceFromDisk = GetModIfaceFromDisk-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetModIfaceFromDisk instance NFData   GetModIfaceFromDisk  data GetModIfaceFromDiskAndIndex = GetModIfaceFromDiskAndIndex-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetModIfaceFromDiskAndIndex instance NFData   GetModIfaceFromDiskAndIndex  data GetModIface = GetModIface-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetModIface instance NFData   GetModIface  data IsFileOfInterest = IsFileOfInterest-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable IsFileOfInterest instance NFData   IsFileOfInterest  data GetModSummaryWithoutTimestamps = GetModSummaryWithoutTimestamps-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetModSummaryWithoutTimestamps instance NFData   GetModSummaryWithoutTimestamps  data GetModSummary = GetModSummary-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetModSummary instance NFData   GetModSummary  -- See Note [Client configuration in Rules] -- | Get the client config stored in the ide state data GetClientSettings = GetClientSettings-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetClientSettings instance NFData   GetClientSettings  type instance RuleResult GetClientSettings = Hashed (Maybe Value) -data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Typeable, Generic)+data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Generic) instance Hashable AddWatchedFile instance NFData   AddWatchedFile @@ -504,7 +557,7 @@ instance Show IdeGhcSession where show _ = "IdeGhcSession" instance NFData IdeGhcSession where rnf !_ = () -data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic)+data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Generic) instance Hashable GhcSessionIO instance NFData   GhcSessionIO @@ -513,6 +566,7 @@     ''Splices  {- Note [Client configuration in Rules]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The LSP client configuration is stored by `lsp` for us, and is accesible in handlers through the LspT monad.
src/Development/IDE/Core/Rules.hs view
@@ -3,7 +3,6 @@  {-# LANGUAGE CPP                   #-} {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE TypeFamilies          #-}  -- | A Shake implementation of the compiler service, built@@ -12,11 +11,8 @@ module Development.IDE.Core.Rules(     -- * Types     IdeState, GetParsedModule(..), TransitiveDependencies(..),-    Priority(..), GhcSessionIO(..), GetClientSettings(..),+    GhcSessionIO(..), GetClientSettings(..),     -- * Functions-    priorityTypeCheck,-    priorityGenerateCore,-    priorityFilesOfInterest,     runAction,     toIdeResult,     defineNoFile,@@ -27,6 +23,7 @@     getParsedModuleWithComments,     getClientConfigAction,     usePropertyAction,+    usePropertyByPathAction,     getHieFile,     -- * Rules     CompiledLinkables(..),@@ -46,7 +43,6 @@     getHieAstsRule,     getBindingsRule,     needsCompilationRule,-    computeLinkableTypeForDynFlags,     generateCoreRule,     getImportMapRule,     regenerateHiFile,@@ -61,16 +57,18 @@     DisplayTHWarning(..),     ) where -import           Prelude                                      hiding (mod) import           Control.Applicative-import           Control.Concurrent.Async                     (concurrently)+import           Control.Concurrent.STM.Stats                 (atomically)+import           Control.Concurrent.STM.TVar import           Control.Concurrent.Strict import           Control.DeepSeq-import           Control.Exception.Safe import           Control.Exception                            (evaluate)-import           Control.Monad.Extra                          hiding (msum)-import           Control.Monad.Reader                         hiding (msum)-import           Control.Monad.State                          hiding (msum)+import           Control.Exception.Safe+import           Control.Lens                                 ((%~), (&), (.~))+import           Control.Monad.Extra+import           Control.Monad.IO.Unlift+import           Control.Monad.Reader+import           Control.Monad.State import           Control.Monad.Trans.Except                   (ExceptT, except,                                                                runExceptT) import           Control.Monad.Trans.Maybe@@ -79,44 +77,51 @@ import qualified Data.ByteString                              as BS import qualified Data.ByteString.Lazy                         as LBS import           Data.Coerce-import           Data.Foldable                                hiding (msum)+import           Data.Default                                 (Default, def)+import           Data.Foldable+import           Data.Hashable import qualified Data.HashMap.Strict                          as HM import qualified Data.HashSet                                 as HashSet-import           Data.Hashable-import           Data.IORef-import           Control.Concurrent.STM.TVar import           Data.IntMap.Strict                           (IntMap) import qualified Data.IntMap.Strict                           as IntMap+import           Data.IORef import           Data.List-import           Data.List.Extra                              (nubOrdOn)+import           Data.List.Extra                              (nubOrd, nubOrdOn) import qualified Data.Map                                     as M import           Data.Maybe import           Data.Proxy-import qualified Data.Text.Utf16.Rope                         as Rope-import qualified Data.Set                                     as Set import qualified Data.Text                                    as T import qualified Data.Text.Encoding                           as T+import qualified Data.Text.Utf16.Rope.Mixed                   as Rope import           Data.Time                                    (UTCTime (..))+import           Data.Time.Clock.POSIX                        (posixSecondsToUTCTime) import           Data.Tuple.Extra import           Data.Typeable                                (cast) import           Development.IDE.Core.Compile-import           Development.IDE.Core.FileExists hiding (LogShake, Log)+import           Development.IDE.Core.FileExists              hiding (Log,+                                                               LogShake) import           Development.IDE.Core.FileStore               (getFileContents,                                                                getModTime) import           Development.IDE.Core.IdeConfiguration-import           Development.IDE.Core.OfInterest hiding (LogShake, Log)+import           Development.IDE.Core.OfInterest              hiding (Log,+                                                               LogShake) import           Development.IDE.Core.PositionMapping import           Development.IDE.Core.RuleTypes-import           Development.IDE.Core.Service hiding (LogShake, Log)-import           Development.IDE.Core.Shake hiding (Log)-import           Development.IDE.GHC.Compat.Env+import           Development.IDE.Core.Service                 hiding (Log,+                                                               LogShake)+import           Development.IDE.Core.Shake                   hiding (Log)+import qualified Development.IDE.Core.Shake                   as Shake import           Development.IDE.GHC.Compat                   hiding-                                                              (vcat, nest, parseModule,-                                                               TargetId(..),-                                                               loadInterface,+                                                              (TargetId (..),                                                                Var,-                                                               (<+>), settings)-import qualified Development.IDE.GHC.Compat                   as Compat hiding (vcat, nest)+                                                               loadInterface,+                                                               nest,+                                                               parseModule,+                                                               settings, vcat,+                                                               (<+>))+import qualified Development.IDE.GHC.Compat                   as Compat hiding+                                                                        (nest,+                                                                         vcat) import qualified Development.IDE.GHC.Compat.Util              as Util import           Development.IDE.GHC.Error import           Development.IDE.GHC.Util                     hiding@@ -131,47 +136,51 @@ import           Development.IDE.Types.HscEnvEq import           Development.IDE.Types.Location import           Development.IDE.Types.Options+import qualified Development.IDE.Types.Shake                  as Shake+import           GHC.Iface.Ext.Types                          (HieASTs (..))+import           GHC.Iface.Ext.Utils                          (generateReferencesMap) import qualified GHC.LanguageExtensions                       as LangExt+#if MIN_VERSION_ghc(9,13,0)+import           GHC.Types.PkgQual                            (PkgQual (NoPkgQual))+import           GHC.Types.Basic                              (ImportLevel (..))+import           GHC.Unit.Types                               (GenWithIsBoot(..))+import           GHC.Unit.Module.Graph                        (mkModuleEdge)+import           GHC.Unit.Module.ModNodeKey                   (mnkModuleName)+#endif+import           HIE.Bios.Ghc.Gap                             (hostIsDynamic) import qualified HieDb+import           Ide.Logger                                   (Pretty (pretty),+                                                               Recorder,+                                                               WithPriority,+                                                               cmapWithPrio,+                                                               logWith, nest,+                                                               vcat, (<+>))+import qualified Ide.Logger                                   as Logger import           Ide.Plugin.Config-import qualified Language.LSP.Server                          as LSP-import           Language.LSP.Protocol.Types                  (ShowMessageParams (ShowMessageParams), MessageType (MessageType_Info))-import           Language.LSP.Protocol.Message                (SMethod (SMethod_CustomMethod, SMethod_WindowShowMessage))-import           Language.LSP.VFS-import           System.Directory                             (makeAbsolute, doesFileExist)-import           Data.Default                                 (def, Default) import           Ide.Plugin.Properties                        (HasProperty,+                                                               HasPropertyByPath,+                                                               KeyNamePath,                                                                KeyNameProxy,                                                                Properties,                                                                ToHsType,-                                                               useProperty)+                                                               useProperty,+                                                               usePropertyByPath) import           Ide.Types                                    (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser),-                                                               PluginId)-import Control.Concurrent.STM.Stats (atomically)-import Language.LSP.Server (LspT)-import System.Info.Extra (isWindows)-import HIE.Bios.Ghc.Gap (hostIsDynamic)-import Ide.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat)-import qualified Development.IDE.Core.Shake as Shake-import qualified Ide.Logger as Logger-import qualified Development.IDE.Types.Shake as Shake-import           Data.Time.Clock.POSIX             (posixSecondsToUTCTime)-import Control.Monad.IO.Unlift---import GHC.Fingerprint---- See Note [Guidelines For Using CPP In GHCIDE Import Statements]--#if !MIN_VERSION_ghc(9,3,0)-import GHC (mgModSummaries)-#endif--#if MIN_VERSION_ghc(9,3,0)-import qualified Data.IntMap as IM-#endif+                                                               PluginId, getVirtualFileFromVFS)+import qualified Language.LSP.Protocol.Lens                   as JL+import           Language.LSP.Protocol.Message                (SMethod (SMethod_CustomMethod, SMethod_WindowShowMessage))+import           Language.LSP.Protocol.Types                  (MessageType (MessageType_Info),+                                                               ShowMessageParams (ShowMessageParams))+import           Language.LSP.Server                          (LspT)+import qualified Language.LSP.Server                          as LSP+import           Language.LSP.VFS+import           Prelude                                      hiding (mod)+import           System.Directory                             (doesFileExist)+import           System.Info.Extra                            (isWindows)  +import qualified Data.IntMap                                  as IM+import           GHC.Fingerprint  data Log   = LogShake Shake.Log@@ -217,12 +226,15 @@ ------------------------------------------------------------ -- Exposed API ------------------------------------------------------------++-- TODO: rename+-- TODO: return text --> return rope getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString getSourceFileSource nfp = do-    (_, msource) <- getFileContents nfp+    msource <- getFileContents nfp     case msource of         Nothing     -> liftIO $ BS.readFile (fromNormalizedFilePath nfp)-        Just source -> pure $ T.encodeUtf8 source+        Just source -> pure $ T.encodeUtf8 $ Rope.toText source  -- | Parse the contents of a haskell file. getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)@@ -237,15 +249,6 @@ -- 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@@ -265,45 +268,10 @@     let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' }         reset_ms pm = pm { pm_mod_summary = ms' } -    -- We still parse with Haddocks whether Opt_Haddock is True or False to collect information-    -- but we no longer need to parse with and without Haddocks separately for above GHC90.-    res@(_,pmod) <- if Compat.ghcVersion >= Compat.GHC90 then-      liftIO $ (fmap.fmap.fmap) reset_ms $ getParsedModuleDefinition hsc opt file (withOptHaddock ms)-    else do-        let dflags    = ms_hspp_opts ms-            mainParse = getParsedModuleDefinition hsc opt file ms--        -- Parse again (if necessary) to capture Haddock parse errors-        if gopt Opt_Haddock dflags-            then-                liftIO $ (fmap.fmap.fmap) reset_ms 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-                ((diags,res),(diagsh,resh)) <- liftIO $ (fmap.fmap.fmap.fmap) reset_ms $ concurrently mainParse haddockParse--                -- Merge haddock and regular diagnostics so we can always report haddock-                -- parse errors-                let diagsM = mergeParseErrorsHaddock diags diagsh-                case resh of-                  Just _-                    | HaddockParse <- optHaddockParse opt-                    -> pure (diagsM, resh)-                  -- If we fail to parse haddocks, report the haddock diagnostics as well and-                  -- return the non-haddock parse.-                  -- This seems to be the correct behaviour because the Haddock flag is added-                  -- by us and not the user, so our IDE shouldn't stop working because of it.-                  _ -> pure (diagsM, res)-    -- Add dependencies on included files-    _ <- uses GetModificationTime $ map toNormalizedFilePath' (maybe [] pm_extra_src_files pmod)-    pure res+    liftIO $ (fmap.fmap.fmap) reset_ms $ getParsedModuleDefinition hsc opt file ms -withOptHaddock :: ModSummary -> ModSummary-withOptHaddock = withOption Opt_Haddock+withoutOptHaddock :: ModSummary -> ModSummary+withoutOptHaddock = withoutOption Opt_Haddock  withOption :: GeneralFlag -> ModSummary -> ModSummary withOption opt ms = ms{ms_hspp_opts= gopt_set (ms_hspp_opts ms) opt}@@ -311,18 +279,6 @@ 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 DiagnosticSeverity_Warning, _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.@@ -334,7 +290,7 @@     ModSummaryResult{msrModSummary = ms, msrHscEnv = hsc} <- use_ GetModSummary file     opt <- getIdeOptions -    let ms' = withoutOption Opt_Haddock $ withOption Opt_KeepRawTokenStream ms+    let ms' = withoutOptHaddock $ withOption Opt_KeepRawTokenStream ms     modify_dflags <- getModifyDynFlags dynFlagsModifyParser     let ms'' = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' }         reset_ms pm = pm { pm_mod_summary = ms' }@@ -364,36 +320,37 @@ getLocatedImportsRule recorder =     define (cmapWithPrio LogShake recorder) $ \GetLocatedImports file -> do         ModSummaryResult{msrModSummary = ms} <- use_ GetModSummaryWithoutTimestamps file-        targets <- useNoFile_ GetKnownTargets-        let targetsMap = HM.mapWithKey const targets+        (KnownTargets targets) <- useNoFile_ GetKnownTargets+#if MIN_VERSION_ghc(9,13,0)+        let imports = [(False, lvl, mbPkgName, modName) | (lvl, mbPkgName, modName) <- ms_textual_imps ms]+                   ++ [(True, NormalLevel, NoPkgQual, noLoc modName) | L _ modName <- ms_srcimps ms]+#else         let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]+#endif         env_eq <- use_ GhcSession file-        let env = hscEnvWithImportPaths env_eq-        let import_dirs = deps env_eq+        let env = hscEnv env_eq+        let import_dirs = map (second homeUnitEnv_dflags) $ hugElts $ hsc_HUG env         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 getTargetFor modName nfp-                | isImplicitCradle = do-                    itExists <- getFileExists nfp-                    return $ if itExists then Just nfp else Nothing-                | Just (TargetFile nfp') <- HM.lookup (TargetFile nfp) targetsMap = do+                | Just (TargetFile nfp') <- HM.lookupKey (TargetFile nfp) targets = do                     -- reuse the existing NormalizedFilePath in order to maximize sharing                     itExists <- getFileExists nfp'                     return $ if itExists then Just nfp' else Nothing                 | Just tt <- HM.lookup (TargetModule modName) targets = do                     -- reuse the existing NormalizedFilePath in order to maximize sharing-                    let ttmap = HM.mapWithKey const (HashSet.toMap tt)-                        nfp' = HM.lookupDefault nfp nfp ttmap+                    let nfp' = fromMaybe nfp $ HashSet.lookupElement nfp tt                     itExists <- getFileExists nfp'                     return $ if itExists then Just nfp' else Nothing-                | otherwise-                = return Nothing+                | otherwise = do+                    itExists <- getFileExists nfp+                    return $ if itExists then Just nfp else Nothing+#if MIN_VERSION_ghc(9,13,0)+        (diags, imports') <- fmap unzip $ forM imports $ \(isSource, _lvl, mbPkgName, modName) -> do+#else         (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do-            diagOrImp <- locateModule (hscSetFlags dflags' env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource+#endif+            diagOrImp <- locateModule (hscSetFlags dflags env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource             case diagOrImp of                 Left diags              -> pure (diags, Just (modName, Nothing))                 Right (FileImport path) -> pure ([], Just (modName, Just path))@@ -440,16 +397,16 @@     go :: NormalizedFilePath -- ^ Current module being processed        -> Maybe ModSummary   -- ^ ModSummary of the module        -> RawDepM FilePathId-    go f msum = do+    go f mbModSum = 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+          let al = modSummaryToArtifactsLocation f mbModSum           -- Get a fresh FilePathId for the new file           fId <- getFreshFid al           -- Record this module and its location-          whenJust msum $ \ms ->+          whenJust mbModSum $ \ms ->             modifyRawDepInfo (\rd -> rd { rawModuleMap = IntMap.insert (getFilePathId fId)                                                                            (ShowableModule $ ms_mod ms)                                                                            (rawModuleMap rd)})@@ -527,7 +484,7 @@ reportImportCyclesRule :: Recorder (WithPriority Log) -> Rules () reportImportCyclesRule recorder =     defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \ReportImportCycles file -> fmap (\errs -> if null errs then (Just "1",([], Just ())) else (Nothing, (errs, Nothing))) $ do-        DependencyInformation{..} <- useNoFile_ GetModuleGraph+        DependencyInformation{..} <- useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph file         case pathToId depPathIdMap file of           -- The header of the file does not parse, so it can't be part of any import cycles.           Nothing -> pure []@@ -538,23 +495,15 @@                   let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs)                   -- Convert cycles of files into cycles of module names                   forM cycles $ \(imp, files) -> do-                      modNames <- forM files $ +                      modNames <- forM files $                           getModuleName . idToPath depPathIdMap                       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 DiagnosticSeverity_Error-            , _source = Just "Import cycle detection"-            , _message = "Cyclic module dependency between " <> showCycle mods-            , _code = Nothing-            , _relatedInformation = Nothing-            , _tags = Nothing-            , _codeDescription = Nothing-            , _data_ = Nothing-            }+          toDiag imp mods =+            ideErrorWithSource (Just "Import cycle detection") (Just DiagnosticSeverity_Error) fp ("Cyclic module dependency between " <> showCycle mods) Nothing+              & fdLspDiagnosticL %~ JL.range .~ rng             where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp)                   fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp)           getModuleName file = do@@ -574,16 +523,21 @@   res <- readHieFileForSrcFromDisk recorder file   vfsRef <- asks vfsVar   vfsData <- liftIO $ _vfsMap <$> readTVarIO vfsRef-  (currentSource, ver) <- liftIO $ case M.lookup (filePathToUri' file) vfsData of+  (currentSource, ver) <- liftIO $ case getVirtualFileFromVFS (VFS vfsData) (filePathToUri' file) of     Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file)-    Just vf -> pure (Rope.toText $ _file_text vf, Just $ _lsp_version vf)-  let refmap = Compat.generateReferencesMap . Compat.getAsts . Compat.hie_asts $ res+    Just vf -> pure (virtualFileText vf, Just $ virtualFileVersion vf)+  let refmap = generateReferencesMap . getAsts . Compat.hie_asts $ res       del = deltaFromDiff (T.decodeUtf8 $ Compat.hie_hs_src res) currentSource   pure (HAR (Compat.hie_module res) (Compat.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+  (diags, masts') <- liftIO $ generateHieAsts hsc tmr+#if MIN_VERSION_ghc(9,11,0)+  let masts = fst <$> masts'+#else+  let masts = masts'+#endif   se <- getShakeExtras    isFoi <- use_ IsFileOfInterest f@@ -593,15 +547,15 @@         LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $           toJSON $ fromNormalizedFilePath f       pure []-    _ | Just asts <- masts -> do+    _ | 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+              modSummary = tmrModSummary tmr+          liftIO $ writeAndIndexHieFile hsc se modSummary f exports asts source     _ -> pure [] -  let refmap = Compat.generateReferencesMap . Compat.getAsts <$> masts-      typemap = AtPoint.computeTypeReferences . Compat.getAsts <$> masts+  let refmap = generateReferencesMap . getAsts <$> masts+      typemap = AtPoint.computeTypeReferences . getAsts <$> masts   pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap <*> typemap <*> pure HieFresh)  getImportMapRule :: Recorder (WithPriority Log) -> Rules ()@@ -636,7 +590,7 @@  -- | Persistent rule to ensure that hover doesn't block on startup persistentDocMapRule :: Rules ()-persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty, idDelta, Nothing)+persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty mempty, idDelta, Nothing)  readHieFileForSrcFromDisk :: Recorder (WithPriority Log) -> NormalizedFilePath -> MaybeT IdeAction Compat.HieFile readHieFileForSrcFromDisk recorder file = do@@ -666,7 +620,7 @@     -- very expensive.     when (foi == NotFOI) $       logWith recorder Logger.Warning $ LogTypecheckedFOI file-    typeCheckRuleDefinition hsc pm+    typeCheckRuleDefinition hsc pm file  knownFilesRule :: Recorder (WithPriority Log) -> Rules () knownFilesRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetKnownTargets -> do@@ -674,36 +628,61 @@   fs <- knownTargets   pure (LBS.toStrict $ B.encode $ hash fs, unhashed fs) +getFileHashRule :: Recorder (WithPriority Log) -> Rules ()+getFileHashRule recorder =+    defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetFileHash file -> do+        void $ use_ GetModificationTime file+        fileHash <- liftIO $ Util.getFileHash (fromNormalizedFilePath file)+        return (Just (fingerprintToBS fileHash), ([], Just fileHash))+ getModuleGraphRule :: Recorder (WithPriority Log) -> Rules () getModuleGraphRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do   fs <- toKnownFiles <$> useNoFile_ GetKnownTargets   dependencyInfoForFiles (HashSet.toList fs) +#if MIN_VERSION_ghc(9,13,0)+-- | Build level-aware module graph edges from a ModSummary and a list of dependency NodeKeys.+-- A module can be imported at multiple levels (e.g. @import splice M@ + @import M@),+-- so we collect ALL levels per module and produce one edge per (module, level) pair.+-- This is required for GHC 9.14's level-aware module graph (@mg_zero_graph@).+mkLevelEdges :: ModSummary -> [NodeKey] -> [ModuleNodeEdge]+mkLevelEdges ms dep_node_keys = concatMap (\nk -> map (\lvl -> mkModuleEdge lvl nk) (lookupLevels nk)) dep_node_keys+  where+    importLevelsMap = M.map nubOrd $ M.fromListWith (++)+      [(unLoc mn, [lvl]) | (lvl, _pkg, mn) <- ms_textual_imps ms]+    lookupLevels nk = case nk of+      NodeKey_Module mnk ->+        M.findWithDefault [NormalLevel] (gwib_mod $ mnkModuleName mnk) importLevelsMap+      _ -> [NormalLevel]+#endif+ dependencyInfoForFiles :: [NormalizedFilePath] -> Action (BS.ByteString, DependencyInformation) dependencyInfoForFiles fs = do   (rawDepInfo, bm) <- rawDependencyInformation fs   let (all_fs, _all_ids) = unzip $ HM.toList $ pathToIdMap $ rawPathIdMap rawDepInfo   msrs <- uses GetModSummaryWithoutTimestamps all_fs   let mss = map (fmap msrModSummary) msrs-#if MIN_VERSION_ghc(9,3,0)   let deps = map (\i -> IM.lookup (getFilePathId i) (rawImports rawDepInfo)) _all_ids       nodeKeys = IM.fromList $ catMaybes $ zipWith (\fi mms -> (getFilePathId fi,) . NodeKey_Module . msKey <$> mms) _all_ids mss       mns = catMaybes $ zipWith go mss deps+#if MIN_VERSION_ghc(9,13,0)+      go (Just ms) (Just (Right (ModuleImports xs))) = Just $ ModuleNode this_dep_edges (ModuleNodeCompile ms)+        where this_dep_ids = mapMaybe snd xs+              this_dep_node_keys = mapMaybe (\fi -> IM.lookup (getFilePathId fi) nodeKeys) this_dep_ids+              this_dep_edges = mkLevelEdges ms this_dep_node_keys+      go (Just ms) _ = Just $ ModuleNode [] (ModuleNodeCompile ms)+#else       go (Just ms) (Just (Right (ModuleImports xs))) = Just $ ModuleNode this_dep_keys ms         where this_dep_ids = mapMaybe snd xs               this_dep_keys = mapMaybe (\fi -> IM.lookup (getFilePathId fi) nodeKeys) this_dep_ids       go (Just ms) _ = Just $ ModuleNode [] ms+#endif       go _ _ = Nothing       mg = mkModuleGraph mns-#else-  let mg = mkModuleGraph $-        -- We don't do any instantiation for backpack at this point of time, so it is OK to use-        -- 'extendModSummaryNoDeps'.-        -- This may have to change in the future.-          map extendModSummaryNoDeps $-          (catMaybes mss)-#endif-  pure (fingerprintToBS $ Util.fingerprintFingerprints $ map (maybe fingerprint0 msrFingerprint) msrs, processDependencyInformation rawDepInfo bm mg)+  let shallowFingers = IntMap.fromList $ foldr' (\(i, m) acc -> case m of+                                        Just x -> (getFilePathId i,msrFingerprint x):acc+                                        Nothing -> acc) [] $ zip _all_ids msrs+  pure (fingerprintToBS $ Util.fingerprintFingerprints $ map (maybe fingerprint0 msrFingerprint) msrs, processDependencyInformation rawDepInfo bm mg shallowFingers)  -- 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@@ -712,14 +691,15 @@ typeCheckRuleDefinition     :: HscEnv     -> ParsedModule+    -> NormalizedFilePath     -> Action (IdeResult TcModuleResult)-typeCheckRuleDefinition hsc pm = do-  setPriority priorityTypeCheck+typeCheckRuleDefinition hsc pm fp = do   IdeOptions { optDefer = defer } <- getIdeOptions    unlift <- askUnliftIO   let dets = TypecheckHelpers            { getLinkables = unliftIO unlift . uses_ GetLinkable+           , getModuleGraph = unliftIO unlift $ useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph fp            }   addUsageDependencies $ liftIO $     typecheckModule defer hsc dets pm@@ -746,23 +726,35 @@     defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GhcSessionIO -> do         alwaysRerun         opts <- getIdeOptions+        config <- getClientConfigAction         res <- optGhcSession opts -        let fingerprint = LBS.toStrict $ B.encode $ hash (sessionVersion res)+        let fingerprint = LBS.toStrict $ LBS.concat+                [ B.encode (hash (sessionVersion res))+                -- When the session version changes, reload all session+                -- hsc env sessions+                , B.encode (show (sessionLoading config))+                -- The loading config affects session loading.+                -- Invalidate all build nodes.+                -- Changing the session loading config will increment+                -- the 'sessionVersion', thus we don't generate the same fingerprint+                -- twice by accident.+                ]         return (fingerprint, res)      defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession file -> do         IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO+        -- loading is always returning a absolute path now         (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file          -- add the deps to the Shake graph         let addDependency fp = do                 -- VSCode uses absolute paths in its filewatch notifications-                afp <- liftIO $ makeAbsolute fp-                let nfp = toNormalizedFilePath' afp+                let nfp = toNormalizedFilePath' fp                 itExists <- getFileExists nfp                 when itExists $ void $ do-                  use_ GetModificationTime nfp+                  use_ GetPhysicalModificationTime nfp+         mapM_ addDependency deps          let cutoffHash = LBS.toStrict $ B.encode (hash (snd val))@@ -781,6 +773,7 @@     }  -- | Note [GhcSessionDeps]+--   ~~~~~~~~~~~~~~~~~~~~~ -- For a file 'Foo', GhcSessionDeps "Foo.hs" results in an HscEnv which includes -- 1. HomeModInfo's (in the HUG/HPT) for all modules in the transitive closure of "Foo", **NOT** including "Foo" itself. -- 2. ModSummary's (in the ModuleGraph) for all modules in the transitive closure of "Foo", including "Foo" itself.@@ -789,53 +782,53 @@     :: -- | full mod summary         Bool ->         GhcSessionDepsConfig -> HscEnvEq -> NormalizedFilePath -> Action (Maybe HscEnvEq)-ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do-    let hsc = hscEnv env-+ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} hscEnvEq file = do     mbdeps <- mapM(fmap artifactFilePath . snd) <$> use_ GetLocatedImports file     case mbdeps of         Nothing -> return Nothing         Just deps -> do             when fullModuleGraph $ void $ use_ ReportImportCycles file-            ms <- msrModSummary <$> if fullModSummary+            msr <- if fullModSummary                 then use_ GetModSummary file                 else use_ GetModSummaryWithoutTimestamps file-+            let+                ms = msrModSummary msr+                -- This `HscEnv` has its plugins initialized in `parsePragmasIntoHscEnv`+                -- Fixes the bug in #4631+                env = msrHscEnv msr             depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps             ifaces <- uses_ GetModIface deps             let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails emptyHomeModInfoLinkable) ifaces+            de <- useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph file             mg <- do               if fullModuleGraph-              then depModuleGraph <$> useNoFile_ GetModuleGraph+              then return $ depModuleGraph de               else do                 let mgs = map hsc_mod_graph depSessions-#if MIN_VERSION_ghc(9,3,0)                 -- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph                 -- also points to all the direct descendants of the current module. To get the keys for the descendants                 -- we must get their `ModSummary`s                 !final_deps <- do                   dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps                   return $!! map (NodeKey_Module . msKey) dep_mss+#if MIN_VERSION_ghc(9,13,0)+                let final_dep_edges = mkLevelEdges ms final_deps                 let module_graph_nodes =-                      nubOrdOn mkNodeKey (ModuleNode final_deps ms : concatMap mgModSummaries' mgs)+                      nubOrdOn mkNodeKey (ModuleNode final_dep_edges (ModuleNodeCompile ms) : concatMap mgModSummaries' mgs) #else                 let module_graph_nodes =-                      -- We don't do any instantiation for backpack at this point of time, so it is OK to use-                      -- 'extendModSummaryNoDeps'.-                      -- This may have to change in the future.-                      map extendModSummaryNoDeps $-                      nubOrdOn ms_mod (ms : concatMap mgModSummaries mgs)+                      nubOrdOn mkNodeKey (ModuleNode final_deps ms : concatMap mgModSummaries' mgs) #endif                 liftIO $ evaluate $ liftRnf rwhnf module_graph_nodes                 return $ mkModuleGraph module_graph_nodes-            session' <- liftIO $ mergeEnvs hsc mg ms inLoadOrder depSessions+            session' <- liftIO $ mergeEnvs env mg de ms inLoadOrder depSessions              -- Here we avoid a call to to `newHscEnvEqWithImportPaths`, which creates a new             -- ExportsMap when it is called. We only need to create the ExportsMap once per             -- session, while `ghcSessionDepsDefinition` will be called for each file we need             -- to compile. `updateHscEnvEq` will refresh the HscEnv (session') and also             -- generate a new Unique.-            Just <$> liftIO (updateHscEnvEq env session')+            Just <$> liftIO (updateHscEnvEq hscEnvEq session')  -- | 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.@@ -851,15 +844,17 @@       let m_old = case old of             Shake.Succeeded (Just old_version) v -> Just (v, old_version)             Shake.Stale _   (Just old_version) v -> Just (v, old_version)-            _ -> Nothing+            _                                    -> Nothing           recompInfo = RecompilationInfo             { source_version = ver             , old_value = m_old             , get_file_version = use GetModificationTime_{missingFileDiagnostics = False}             , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs+            , get_module_graph = useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph f             , regenerate = regenerateHiFile session f ms             }-      r <- loadInterface (hscEnv session) ms linkableType recompInfo+      hsc_env' <- setFileCacheHook (hscEnv session)+      r <- loadInterface hsc_env' ms linkableType recompInfo       case r of         (diags, Nothing) -> return (Nothing, (diags, Nothing))         (diags, Just x) -> do@@ -886,7 +881,7 @@       hie_loc = Compat.ml_hie_file $ ms_location ms   fileHash <- liftIO $ Util.getFileHash hie_loc   mrow <- liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb (fromNormalizedFilePath f))-  hie_loc' <- liftIO $ traverse (makeAbsolute . HieDb.hieModuleHieFile) mrow+  let hie_loc' = HieDb.hieModuleHieFile <$> mrow   case mrow of     Just row       | fileHash == HieDb.modInfoHash (HieDb.hieModInfo row)@@ -927,23 +922,18 @@     defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModSummary f -> do         session' <- hscEnv <$> use_ GhcSession f         modify_dflags <- getModifyDynFlags dynFlagsModifyGlobal-        let session = hscSetFlags (modify_dflags $ hsc_dflags session') session'-        (modTime, mFileContent) <- getFileContents f+        let session = setNonHomeFCHook $ hscSetFlags (modify_dflags $ hsc_dflags session') session' -- TODO wz1000+        mFileContent <- getFileContents f         let fp = fromNormalizedFilePath f         modS <- liftIO $ runExceptT $-                getModSummaryFromImports session fp modTime (textToStringBuffer <$> mFileContent)+                getModSummaryFromImports session fp (textToStringBuffer . Rope.toText <$> mFileContent)         case modS of             Right res -> do                 -- Check for Template Haskell                 when (uses_th_qq $ msrModSummary res) $ do                     DisplayTHWarning act <- getIdeGlobalAction                     liftIO act-#if MIN_VERSION_ghc(9,3,0)                 let bufFingerPrint = ms_hs_hash (msrModSummary res)-#else-                bufFingerPrint <- liftIO $-                    fingerprintFromStringBuffer $ fromJust $ ms_hspp_buf $ msrModSummary res-#endif                 let fingerPrint = Util.fingerprintFingerprints                         [ msrFingerprint res, bufFingerPrint ]                 return ( Just (fingerprintToBS fingerPrint) , ([], Just res))@@ -954,9 +944,6 @@         case mbMs of             Just res@ModSummaryResult{..} -> do                 let ms = msrModSummary {-#if !MIN_VERSION_ghc(9,3,0)-                    ms_hs_date = error "use GetModSummary instead of GetModSummaryWithoutTimestamps",-#endif                     ms_hspp_buf = error "use GetModSummary instead of GetModSummaryWithoutTimestamps"                     }                     fp = fingerprintToBS msrFingerprint@@ -966,9 +953,9 @@ generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts) generateCore runSimplifier file = do     packageState <- hscEnv <$> use_ GhcSessionDeps file+    hsc' <- setFileCacheHook packageState     tm <- use_ TypeCheck file-    setPriority priorityGenerateCore-    liftIO $ compileModule runSimplifier packageState (tmrModSummary tm) (tmrTypechecked tm)+    liftIO $ compileModule runSimplifier hsc' (tmrModSummary tm) (tmrTypechecked tm)  generateCoreRule :: Recorder (WithPriority Log) -> Rules () generateCoreRule recorder =@@ -983,14 +970,15 @@       tmr <- use_ TypeCheck f       linkableType <- getLinkableType f       hsc <- hscEnv <$> use_ GhcSessionDeps f+      hsc' <- setFileCacheHook hsc       let compile = fmap ([],) $ use GenerateCore f       se <- getShakeExtras-      (diags, !mbHiFile) <- writeCoreFileIfNeeded se hsc linkableType compile tmr+      (diags, !mbHiFile) <- writeCoreFileIfNeeded se hsc' linkableType compile tmr       let fp = hiFileFingerPrint <$> mbHiFile       hiDiags <- case mbHiFile of         Just hiFile           | OnDisk <- status-          , not (tmrDeferredError tmr) -> liftIO $ writeHiFile se hsc hiFile+          , not (tmrDeferredError tmr) -> liftIO $ writeHiFile se hsc' hiFile         _ -> pure []       return (fp, (diags++hiDiags, mbHiFile))     NotFOI -> do@@ -1014,32 +1002,33 @@   count <- getRebuildCountVar <$> getIdeGlobalAction   liftIO $ atomically $ modifyTVar' count (+1) +setFileCacheHook :: HscEnv -> Action HscEnv+setFileCacheHook old_hsc_env = do+#if MIN_VERSION_ghc(9,11,0)+  unlift <- askUnliftIO+  return $ old_hsc_env { hsc_FC = (hsc_FC old_hsc_env) { lookupFileCache = unliftIO unlift . use_ GetFileHash . toNormalizedFilePath'  } }+#else+  return old_hsc_env+#endif+ -- | 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+    hsc <- setFileCacheHook (hscEnv sess)     opt <- getIdeOptions -    -- Embed haddocks in the interface file-    (diags, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f (withOptHaddock ms)-    (diags', mb_pm') <--        -- We no longer need to parse again if GHC version is above 9.0. https://github.com/haskell/haskell-language-server/issues/1892-        if Compat.ghcVersion >= Compat.GHC90 || isJust mb_pm then do-            return (diags, mb_pm)-        else 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)+    -- By default, we parse with `-haddock` unless 'OptHaddockParse' is overwritten.+    (diags, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f ms+    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+            (diags', mtmr) <- typeCheckRuleDefinition hsc pm f             case mtmr of-              Nothing -> pure (diags'', Nothing)+              Nothing -> pure (diags', Nothing)               Just tmr -> do                  let compile = liftIO $ compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr@@ -1047,7 +1036,7 @@                 se <- getShakeExtras                  -- Bang pattern is important to avoid leaking 'tmr'-                (diags''', !res) <- writeCoreFileIfNeeded se hsc compNeeded compile tmr+                (diags'', !res) <- writeCoreFileIfNeeded se hsc compNeeded compile tmr                  -- Write hi file                 hiDiags <- case res of@@ -1071,7 +1060,7 @@                     pure (hiDiags <> gDiags <> concat wDiags)                   Nothing -> pure [] -                return (diags' <> diags'' <> diags''' <> hiDiags, res)+                return (diags <> diags' <> diags'' <> hiDiags, res)   -- | HscEnv should have deps included already@@ -1108,28 +1097,44 @@   pluginConfig <- getPluginConfigAction plId   pure $ useProperty kn p $ plcConfig pluginConfig +usePropertyByPathAction ::+  (HasPropertyByPath props path t) =>+  KeyNamePath path ->+  PluginId ->+  Properties props ->+  Action (ToHsType t)+usePropertyByPathAction path plId p = do+  pluginConfig <- getPluginConfigAction plId+  pure $ usePropertyByPath path p $ plcConfig pluginConfig+ -- ---------------------------------------------------------------------  getLinkableRule :: Recorder (WithPriority Log) -> Rules () getLinkableRule recorder =   defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetLinkable f -> do-    ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary f-    HiFileResult{hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f-    let obj_file  = ml_obj_file (ms_location ms)-        core_file = ml_core_file (ms_location ms)-    -- Can't use `GetModificationTime` rule because the core file was possibly written in this-    -- very session, so the results aren't reliable-    core_t <- liftIO $ getModTime core_file+    HiFileResult{hirModSummary, hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f+    let obj_file  = ml_obj_file (ms_location hirModSummary)+        core_file = ml_core_file (ms_location hirModSummary)+#if MIN_VERSION_ghc(9,11,0)+        mkLinkable t mod l = Linkable t mod (pure l)+        dotO o = DotO o ModuleObject+#else+        mkLinkable t mod l = LM t mod [l]+        dotO = DotO+#endif     case hirCoreFp of-      Nothing -> error "called GetLinkable for a file without a linkable"+      Nothing -> error $ "called GetLinkable for a file without a linkable: " ++ show f       Just (bin_core, fileHash) -> do         session <- use_ GhcSessionDeps f         linkableType <- getLinkableType f >>= \case-          Nothing -> error "called GetLinkable for a file which doesn't need compilation"+          Nothing -> error $ "called GetLinkable for a file which doesn't need compilation: " ++ show f           Just t -> pure t+        -- Can't use `GetModificationTime` rule because the core file was possibly written in this+        -- very session, so the results aren't reliable+        core_t <- liftIO $ getModTime core_file         (warns, hmi) <- case linkableType of           -- Bytecode needs to be regenerated from the core file-          BCOLinkable -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (posixSecondsToUTCTime core_t)+          BCOLinkable -> liftIO $ coreFileToLinkable linkableType (hscEnv session) hirModSummary hirModIface hirModDetails bin_core (posixSecondsToUTCTime core_t)           -- Object code can be read from the disk           ObjectLinkable -> do             -- object file is up to date if it is newer than the core file@@ -1142,10 +1147,15 @@               else pure Nothing             case mobj_time of               Just obj_t-                | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (justObjects $ LM (posixSecondsToUTCTime obj_t) (ms_mod ms) [DotO obj_file]))-              _ -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (error "object doesn't have time")+                | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (justObjects $ mkLinkable (posixSecondsToUTCTime obj_t) (ms_mod hirModSummary) (dotO obj_file)))+              _ -> liftIO $ coreFileToLinkable linkableType (hscEnv session) hirModSummary hirModIface hirModDetails bin_core (error "object doesn't have time")         -- Record the linkable so we know not to unload it, and unload old versions-        whenJust ((homeModInfoByteCode =<< hmi) <|> (homeModInfoObject =<< hmi)) $ \(LM time mod _) -> do+        whenJust ((homeModInfoByteCode =<< hmi) <|> (homeModInfoObject =<< hmi))+#if MIN_VERSION_ghc(9,11,0)+          $ \(Linkable time mod _) -> do+#else+          $ \(LM time mod _) -> do+#endif             compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction             liftIO $ modifyVar compiledLinkables $ \old -> do               let !to_keep = extendModuleEnv old mod time@@ -1159,7 +1169,9 @@               --just before returning it to be loaded. This has a substantial effect on recompile               --times as the number of loaded modules and splices increases.               ---              unload (hscEnv session) (map (\(mod', time') -> LM time' mod' []) $ moduleEnvToList to_keep)+              --We use a dummy DotA linkable part to fake a NativeCode linkable.+              --The unload function doesn't care about the exact linkable parts.+              unload (hscEnv session) (map (\(mod', time') -> mkLinkable time' mod' (DotA "dummy")) $ moduleEnvToList to_keep)               return (to_keep, ())         return (fileHash <$ hmi, (warns, LinkableResult <$> hmi <*> pure fileHash)) @@ -1167,13 +1179,12 @@ getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) getLinkableType f = use_ NeedsCompilation f --- needsCompilationRule :: Rules () needsCompilationRule :: NormalizedFilePath  -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType)) needsCompilationRule file-  | "boot" `isSuffixOf` (fromNormalizedFilePath file) =+  | "boot" `isSuffixOf` fromNormalizedFilePath file =     pure (Just $ encodeLinkableType Nothing, Just Nothing) needsCompilationRule file = do-  graph <- useNoFile GetModuleGraph+  graph <- useWithSeparateFingerprintRule GetModuleGraphImmediateReverseDepsFingerprints GetModuleGraph file   res <- case graph of     -- Treat as False if some reverse dependency header fails to parse     Nothing -> pure Nothing@@ -1190,36 +1201,23 @@         -- that we just threw away, and thus have to recompile all dependencies once         -- again, this time keeping the object code.         -- A file needs to be compiled if any file that depends on it uses TemplateHaskell or needs to be compiled-        ms <- msrModSummary . fst <$> useWithStale_ GetModSummaryWithoutTimestamps file         (modsums,needsComps) <- liftA2             (,) (map (fmap (msrModSummary . fst)) <$> usesWithStale GetModSummaryWithoutTimestamps revdeps)                 (uses NeedsCompilation revdeps)-        pure $ computeLinkableType ms modsums (map join needsComps)+        pure $ computeLinkableType modsums (map join needsComps)   pure (Just $ encodeLinkableType res, Just res)   where-    computeLinkableType :: ModSummary -> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType-    computeLinkableType this deps xs+    computeLinkableType :: [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType+    computeLinkableType 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+      | Just BCOLinkable    `elem` xs     = Just BCOLinkable    -- If any dependent needs bytecode, then we need to be compiled+      | any (maybe False uses_th_qq) deps = Just BCOLinkable    -- 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-        this_type = computeLinkableTypeForDynFlags (ms_hspp_opts this)  uses_th_qq :: ModSummary -> Bool uses_th_qq (ms_hspp_opts -> dflags) =       xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags --- | How should we compile this module?--- (assuming we do in fact need to compile it).--- Depends on whether it uses unboxed tuples or sums-computeLinkableTypeForDynFlags :: DynFlags -> LinkableType-computeLinkableTypeForDynFlags d-          = BCOLinkable-  where -- unboxed_tuples_or_sums is only used in GHC < 9.2-        _unboxed_tuples_or_sums =-            xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d- -- | Tracks which linkables are current, so we don't need to unload them newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) } instance IsIdeGlobal CompiledLinkables@@ -1234,9 +1232,9 @@       -- Disabling this drastically decreases sharing and is likely to       -- increase memory usage if you have multiple files open       -- Disabling this also disables checking for import cycles-      fullModuleGraph :: Bool+      fullModuleGraph        :: Bool     -- | Disable TH for improved performance in large codebases-    , enableTemplateHaskell :: Bool+    , enableTemplateHaskell  :: Bool     -- | Warning to show when TH is not supported by the current HLS binary     , templateHaskellWarning :: LspT Config IO ()     }@@ -1277,6 +1275,7 @@     getModIfaceRule recorder     getModSummaryRule templateHaskellWarning recorder     getModuleGraphRule recorder+    getFileHashRule recorder     knownFilesRule recorder     getClientSettingsRule recorder     getHieAstsRule recorder@@ -1297,6 +1296,19 @@     persistentDocMapRule     persistentImportMapRule     getLinkableRule recorder+    defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModuleGraphTransDepsFingerprints file -> do+        di <- useNoFile_ GetModuleGraph+        let finger = lookupFingerprint file di (depTransDepsFingerprints di)+        return (fingerprintToBS <$> finger, ([], finger))+    defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModuleGraphTransReverseDepsFingerprints file -> do+        di <- useNoFile_ GetModuleGraph+        let finger = lookupFingerprint file di (depTransReverseDepsFingerprints di)+        return (fingerprintToBS <$> finger, ([], finger))+    defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModuleGraphImmediateReverseDepsFingerprints file -> do+        di <- useNoFile_ GetModuleGraph+        let finger = lookupFingerprint file di (depImmediateReverseDepsFingerprints di)+        return (fingerprintToBS <$> finger, ([], finger))+  -- | Get HieFile for haskell file on NormalizedFilePath getHieFile :: NormalizedFilePath -> Action (Maybe HieFile)
src/Development/IDE/Core/Service.hs view
@@ -1,9 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RankNTypes        #-}-{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE TypeFamilies #-}  -- | A Shake implementation of the compiler service, built --   using the "Shaker" abstraction layer for in-memory use.@@ -19,13 +17,15 @@     ) where  import           Control.Applicative              ((<|>))+import           Control.Concurrent.STM           (newTVarIO)+import           Control.Monad.IO.Class           (liftIO) import           Development.IDE.Core.Debouncer import           Development.IDE.Core.FileExists  (fileExistsRules) import           Development.IDE.Core.OfInterest  hiding (Log, LogShake) import           Development.IDE.Graph+import           Development.IDE.Session          (SessionLoaderPendingBarrierVar (..)) import           Development.IDE.Types.Options    (IdeOptions (..))-import           Ide.Logger                       as Logger (Logger,-                                                             Pretty (pretty),+import           Ide.Logger                       as Logger (Pretty (pretty),                                                              Priority (Debug),                                                              Recorder,                                                              WithPriority,@@ -56,6 +56,7 @@     LogOfInterest msg -> pretty msg     LogFileExists msg -> pretty msg + ------------------------------------------------------------ -- Exposed API @@ -65,14 +66,14 @@            -> IdePlugins IdeState            -> Rules ()            -> Maybe (LSP.LanguageContextEnv Config)-           -> Logger            -> Debouncer LSP.NormalizedUri            -> IdeOptions            -> WithHieDb-           -> IndexQueue+           -> ThreadQueue            -> Monitoring+           -> FilePath -- ^ Root directory see Note [Root Directory]            -> IO IdeState-initialise recorder defaultConfig plugins mainRule lspEnv logger debouncer options withHieDb hiedbChan metrics = do+initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan metrics rootDir = do     shakeProfiling <- do         let fromConf = optShakeProfiling options         fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING"@@ -82,7 +83,6 @@         lspEnv         defaultConfig         plugins-        logger         debouncer         shakeProfiling         (optReportProgress options)@@ -91,11 +91,14 @@         hiedbChan         (optShakeOptions options)         metrics-          $ do+        (do+            pendingBarrier <- liftIO $ newTVarIO Nothing+            addIdeGlobal $ SessionLoaderPendingBarrierVar pendingBarrier             addIdeGlobal $ GlobalIdeOptions options             ofInterestRules (cmapWithPrio LogOfInterest recorder)             fileExistsRules (cmapWithPrio LogFileExists recorder) lspEnv-            mainRule+            mainRule)+        rootDir  -- | Shutdown the Compiler Service. shutdown :: IdeState -> IO ()
src/Development/IDE/Core/Shake.hs view
@@ -1,16 +1,12 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ConstraintKinds           #-}-{-# LANGUAGE DerivingStrategies        #-}-{-# LANGUAGE DuplicateRecordFields     #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE PackageImports            #-}-{-# LANGUAGE PolyKinds                 #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE RecursiveDo               #-}-{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DerivingStrategies    #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE PackageImports        #-}+{-# LANGUAGE RecursiveDo           #-}+{-# LANGUAGE TypeFamilies          #-}  -- | A Shake implementation of the compiler service. --@@ -26,15 +22,17 @@ --   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, shakeSessionInit, shakeExtras, shakeDb,+    IdeState, shakeSessionInit, shakeExtras, shakeDb, rootDir,     ShakeExtras(..), getShakeExtras, getShakeExtrasRules,-    KnownTargets, Target(..), toKnownFiles,-    IdeRule, IdeResult,+    KnownTargets(..), Target(..), toKnownFiles, unionKnownTargets, mkKnownTargets,+    IdeRule, IdeResult, RestartQueue,     GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics),     shakeOpen, shakeShut,     shakeEnqueue,     newSession,     use, useNoFile, uses, useWithStaleFast, useWithStaleFast', delayedAction,+    useWithSeparateFingerprintRule,+    useWithSeparateFingerprintRule_,     FastResult(..),     use_, useNoFile_, uses_,     useWithStale, usesWithStale,@@ -55,14 +53,13 @@     HLS.getClientConfig,     getPluginConfigAction,     knownTargets,-    setPriority,     ideLogger,     actionLogger,     getVirtualFile,     FileVersion(..),-    Priority(..),     updatePositionMapping,-    deleteValue, recordDirtyKeys,+    updatePositionMappingHelper,+    deleteValue,     WithProgressFunc, WithIndefiniteProgressFunc,     ProgressEvent(..),     DelayedAction, mkDelayedAction,@@ -78,6 +75,9 @@     garbageCollectDirtyKeysOlderThan,     Log(..),     VFSModified(..), getClientConfigAction,+    ThreadQueue(..),+    runWithSignal,+    askShake     ) where  import           Control.Concurrent.Async@@ -86,7 +86,7 @@ import           Control.Concurrent.Strict import           Control.DeepSeq import           Control.Exception.Extra                hiding (bracket_)-import           Control.Lens                           ((&), (?~))+import           Control.Lens                           ((%~), (&), (?~)) import           Control.Monad.Extra import           Control.Monad.IO.Class import           Control.Monad.Reader@@ -127,11 +127,22 @@ import           Development.IDE.Core.PositionMapping import           Development.IDE.Core.ProgressReporting import           Development.IDE.Core.RuleTypes+import           Development.IDE.Types.Options          as Options+import qualified Language.LSP.Protocol.Message          as LSP+import qualified Language.LSP.Server                    as LSP+ import           Development.IDE.Core.Tracing+import           Development.IDE.Core.WorkerThread+#if MIN_VERSION_ghc(9,13,0) import           Development.IDE.GHC.Compat             (NameCache,-                                                         NameCacheUpdater (..),+                                                         NameCacheUpdater,+                                                         newNameCache)+#else+import           Development.IDE.GHC.Compat             (NameCache,+                                                         NameCacheUpdater,                                                          initNameCache,                                                          knownKeyNames)+#endif import           Development.IDE.GHC.Orphans            () import           Development.IDE.Graph                  hiding (ShakeValue,                                                          action)@@ -150,51 +161,48 @@ import           Development.IDE.Types.KnownTargets import           Development.IDE.Types.Location import           Development.IDE.Types.Monitoring       (Monitoring (..))-import           Development.IDE.Types.Options import           Development.IDE.Types.Shake import qualified Focus import           GHC.Fingerprint import           GHC.Stack                              (HasCallStack)+import           GHC.TypeLits                           (KnownSymbol) import           HieDb.Types import           Ide.Logger                             hiding (Priority) import qualified Ide.Logger                             as Logger import           Ide.Plugin.Config import qualified Ide.PluginUtils                        as HLS-import           Ide.Types                              (IdePlugins (IdePlugins),-                                                         PluginDescriptor (pluginId),-                                                         PluginId)-import           Language.LSP.Diagnostics+import           Ide.Types import qualified Language.LSP.Protocol.Lens             as L import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types import qualified Language.LSP.Protocol.Types            as LSP-import qualified Language.LSP.Server                    as LSP import           Language.LSP.VFS                       hiding (start) import qualified "list-t" ListT import           OpenTelemetry.Eventlog                 hiding (addEvent)+import qualified Prettyprinter                          as Pretty import qualified StmContainers.Map                      as STM import           System.FilePath                        hiding (makeRelative) import           System.IO.Unsafe                       (unsafePerformIO) import           System.Time.Extra+import           UnliftIO                               (MonadUnliftIO (withRunInIO)) --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0)-import           Data.IORef-import           Development.IDE.GHC.Compat             (mkSplitUniqSupply,-                                                         upNameCache)-#endif- data Log   = LogCreateHieDbExportsMapStart   | LogCreateHieDbExportsMapFinish !Int-  | LogBuildSessionRestart !String ![DelayedActionInternal] !(KeySet) !Seconds !(Maybe FilePath)+  | LogBuildSessionRestart !String ![DelayedActionInternal] !KeySet !Seconds !(Maybe FilePath)   | LogBuildSessionRestartTakingTooLong !Seconds   | LogDelayedAction !(DelayedAction ()) !Seconds   | LogBuildSessionFinish !(Maybe SomeException)   | LogDiagsDiffButNoLspEnv ![FileDiagnostic]   | LogDefineEarlyCutoffRuleNoDiagHasDiag !FileDiagnostic   | LogDefineEarlyCutoffRuleCustomNewnessHasDiag !FileDiagnostic+  | LogCancelledAction !T.Text+  | LogSessionInitialised+  | LogLookupPersistentKey !T.Text+  | LogShakeGarbageCollection !T.Text !Int !Seconds+  -- * OfInterest Log messages+  | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)]   deriving Show  instance Pretty Log where@@ -228,30 +236,55 @@     LogDefineEarlyCutoffRuleCustomNewnessHasDiag fileDiagnostic ->       "defineEarlyCutoff RuleWithCustomNewnessCheck - file diagnostic:"       <+> pretty (showDiagnosticsColored [fileDiagnostic])+    LogCancelledAction action ->+        pretty action <+> "was cancelled"+    LogSessionInitialised -> "Shake session initialized"+    LogLookupPersistentKey key ->+        "LOOKUP PERSISTENT FOR:" <+> pretty key+    LogShakeGarbageCollection label number duration ->+        pretty label <+> "of" <+> pretty number <+> "keys (took " <+> pretty (showDuration duration) <> ")"+    LogSetFilesOfInterest ofInterest ->+        "Set files of interst to" <> Pretty.line+            <> indent 4 (pretty $ fmap (first fromNormalizedFilePath) ofInterest)  -- | 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+  { indexQueue             :: IndexQueue+  , indexPending           :: TVar (HMap.HashMap NormalizedFilePath Fingerprint) -- ^ Avoid unnecessary/out of date indexing+  , indexCompleted         :: TVar Int -- ^ to report progress+  , indexProgressReporting :: ProgressReporting   }  -- | Actions to queue up on the index worker thread -- The inner `(HieDb -> IO ()) -> IO ()` wraps `HieDb -> IO ()` -- with (currently) retry functionality-type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ())+type IndexQueue = TaskQueue (((HieDb -> IO ()) -> IO ()) -> IO ())+type RestartQueue = TaskQueue (IO ())+type LoaderQueue = TaskQueue (IO ()) ++data ThreadQueue = ThreadQueue {+    tIndexQueue     :: IndexQueue+    , tRestartQueue :: RestartQueue+    , tLoaderQueue  :: LoaderQueue+}++-- Note [Semantic Tokens Cache Location]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- storing semantic tokens cache for each file in shakeExtras might+-- not be ideal, since it most used in LSP request handlers+-- instead of rules. We should consider moving it to a more+-- appropriate place in the future if we find one, store it for now.+ -- information we stash inside the shakeExtra field data ShakeExtras = ShakeExtras     { --eventer :: LSP.FromServerMessage -> IO ()      lspEnv :: Maybe (LSP.LanguageContextEnv Config)     ,debouncer :: Debouncer NormalizedUri-    ,logger :: Logger+    ,shakeRecorder :: Recorder (WithPriority Log)     ,idePlugins :: IdePlugins IdeState     ,globals :: TVar (HMap.HashMap TypeRep Dynamic)       -- ^ Registry of global state used by rules.@@ -259,27 +292,32 @@     ,state :: Values     ,diagnostics :: STMDiagnosticStore     ,hiddenDiagnostics :: STMDiagnosticStore-    ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic]+    ,publishedDiagnostics :: STM.Map NormalizedUri [FileDiagnostic]     -- ^ This represents the set of diagnostics that we have published.     -- Due to debouncing not every change might get published.++    ,semanticTokensCache:: STM.Map NormalizedFilePath SemanticTokens+    -- ^ Cache of last response of semantic tokens for each file,+    -- so we can compute deltas for semantic tokens(SMethod_TextDocumentSemanticTokensFullDelta).+    -- putting semantic tokens cache and id in shakeExtras might not be ideal+    -- see Note [Semantic Tokens Cache Location]+    ,semanticTokensId :: TVar Int+    -- ^ semanticTokensId is used to generate unique ids for each lsp response of semantic tokens.     ,positionMapping :: STM.Map NormalizedUri (EnumMap Int32 (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-    -- accumulation of all previous mappings.-    ,progress :: ProgressReporting+    -- accumulation to the current version.+    ,progress :: PerFileProgressReporting     ,ideTesting :: IdeTesting     -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants     ,restartShakeSession         :: VFSModified         -> String         -> [DelayedAction ()]+        -> IO [Key]         -> IO ()-#if MIN_VERSION_ghc(9,3,0)     ,ideNc :: NameCache-#else-    ,ideNc :: IORef NameCache-#endif     -- | A mapping of module name to known target (or candidate targets, if missing)     ,knownTargetsVar :: TVar (Hashed KnownTargets)     -- | A mapping of exported identifiers for local modules. Updated on kick@@ -302,6 +340,10 @@       -- ^ Default HLS config, only relevant if the client does not provide any Config     , dirtyKeys :: TVar KeySet       -- ^ Set of dirty rule keys since the last Shake run+    , restartQueue :: RestartQueue+      -- ^ Queue of restart actions to be run.+    , loaderQueue :: LoaderQueue+      -- ^ Queue of loader actions to be run.     }  type WithProgressFunc = forall a.@@ -362,7 +404,8 @@ getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile) getVirtualFile nf = do   vfs <- fmap _vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras-  pure $! Map.lookup (filePathToUri' nf) vfs -- Don't leak a reference to the entire map+  pure $!  -- Don't leak a reference to the entire map+    getVirtualFileFromVFS (VFS vfs) $ filePathToUri' nf  -- Take a snapshot of the current LSP VFS vfsSnapshot :: Maybe (LSP.LanguageContextEnv a) -> IO VFS@@ -428,7 +471,7 @@           | otherwise = do           pmap <- readTVarIO persistentKeys           mv <- runMaybeT $ do-            liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP PERSISTENT FOR: " ++ show k+            liftIO $ logWith (shakeRecorder s) Debug $ LogLookupPersistentKey (T.pack $ show k)             f <- MaybeT $ pure $ lookupKeyMap (newKey k) pmap             (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file             MaybeT $ pure $ (,del,ver) <$> fromDynamic dv@@ -443,7 +486,7 @@                               `catch` (\(_ :: IOException) -> pure Nothing)                 atomicallyNamed "lastValueIO 2" $ do                   STM.focus (Focus.alter (alterValue $ Stale (Just del) actual_version (toDyn v))) (toKey k file) state-                  Just . (v,) . addDelta del <$> mappingForVersion positionMapping file actual_version+                  Just . (v,) . addOldDelta del <$> mappingForVersion positionMapping file actual_version          -- 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@@ -459,7 +502,7 @@         Succeeded ver (fromDynamic -> Just v) ->             atomicallyNamed "lastValueIO 5"  $ Just . (v,) <$> mappingForVersion positionMapping file ver         Stale del ver (fromDynamic -> Just v) ->-            atomicallyNamed "lastValueIO 6"  $ Just . (v,) . maybe id addDelta del <$> mappingForVersion positionMapping file ver+            atomicallyNamed "lastValueIO 6"  $ Just . (v,) . maybe id addOldDelta del <$> mappingForVersion positionMapping file ver         Failed p | not p -> readPersistent         _ -> pure Nothing @@ -495,6 +538,33 @@     -- ^ Closes the Shake session   } +-- Note [Root Directory]+-- ~~~~~~~~~~~~~~~~~~~~~+-- We keep track of the root directory explicitly, which is the directory of the project root.+-- We might be setting it via these options with decreasing priority:+--+-- 1. from LSP workspace root, `resRootPath` in `LanguageContextEnv`.+-- 2. command line (--cwd)+-- 3. default to the current directory.+--+-- Using `getCurrentDirectory` makes it more difficult to run the tests, as we spawn one thread of HLS per test case.+-- If we modify the global Variable CWD, via `setCurrentDirectory`, all other test threads are suddenly affected,+-- forcing us to run all integration tests sequentially.+--+-- Also, there might be a race condition if we depend on the current directory, as some plugin might change it.+-- e.g. stylish's `loadConfig`. https://github.com/haskell/haskell-language-server/issues/4234+--+-- But according to https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_workspaceFolders+-- The root dir is deprecated, that means we should cleanup dependency on the project root(Or $CWD) thing gradually,+-- so multi-workspaces can actually be supported when we use absolute path everywhere(might also need some high level design).+-- That might not be possible unless we have everything adapted to it, like 'hlint' and 'evaluation of template haskell'.+-- But we should still be working towards the goal.+--+-- We can drop it in the future once:+-- 1. We can get rid all the usages of root directory in the codebase.+-- 2. LSP version we support actually removes the root directory from the protocol.+--+ -- | A Shake database plus persistent store. Can be thought of as storing --   mappings from @(FilePath, k)@ to @RuleResult k@. data IdeState = IdeState@@ -503,6 +573,8 @@     ,shakeExtras          :: ShakeExtras     ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath)     ,stopMonitoring       :: IO ()+    -- | See Note [Root Directory]+    ,rootDir              :: FilePath     }  @@ -531,26 +603,17 @@   -- | Delete the value stored for a given ide build key+-- and return the key that was deleted. deleteValue   :: Shake.ShakeValue k   => ShakeExtras   -> k   -> NormalizedFilePath-  -> STM ()-deleteValue ShakeExtras{dirtyKeys, state} key file = do+  -> STM [Key]+deleteValue ShakeExtras{state} key file = do     STM.delete (toKey key file) state-    modifyTVar' dirtyKeys $ insertKeySet (toKey key file)+    return [toKey key file] -recordDirtyKeys-  :: Shake.ShakeValue k-  => ShakeExtras-  -> k-  -> [NormalizedFilePath]-  -> STM (IO ())-recordDirtyKeys ShakeExtras{dirtyKeys} key file = do-    modifyTVar' dirtyKeys $ \x -> foldl' (flip insertKeySet) x (toKey key <$> file)-    return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do-        addEvent (fromString $ unlines $ "dirty " <> show key : map fromNormalizedFilePath file)  -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value. getValues ::@@ -591,27 +654,32 @@           -> Maybe (LSP.LanguageContextEnv Config)           -> Config           -> IdePlugins IdeState-          -> Logger           -> Debouncer NormalizedUri           -> Maybe FilePath           -> IdeReportProgress           -> IdeTesting           -> WithHieDb-          -> IndexQueue+          -> ThreadQueue           -> ShakeOptions           -> Monitoring           -> Rules ()+          -> FilePath+          -- ^ Root directory, this one might be picking up from `LanguageContextEnv`'s `resRootPath`+          -- , see Note [Root Directory]           -> IO IdeState-shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer+shakeOpen recorder lspEnv defaultConfig idePlugins debouncer   shakeProfileDir (IdeReportProgress reportProgress)-  ideTesting@(IdeTesting testing)-  withHieDb indexQueue opts monitoring rules = mdo+  ideTesting+  withHieDb threadQueue opts monitoring rules rootDir = mdo+    -- see Note [Serializing runs in separate thread]+    let indexQueue = tIndexQueue threadQueue+        restartQueue = tRestartQueue threadQueue+        loaderQueue = tLoaderQueue threadQueue -#if MIN_VERSION_ghc(9,3,0)-    ideNc <- initNameCache 'r' knownKeyNames+#if MIN_VERSION_ghc(9,13,0)+    ideNc <- newNameCache #else-    us <- mkSplitUniqSupply 'r'-    ideNc <- newIORef (initNameCache us knownKeyNames)+    ideNc <- initNameCache 'r' knownKeyNames #endif     shakeExtras <- do         globals <- newTVarIO HMap.empty@@ -619,13 +687,18 @@         diagnostics <- STM.newIO         hiddenDiagnostics <- STM.newIO         publishedDiagnostics <- STM.newIO+        semanticTokensCache <- STM.newIO         positionMapping <- STM.newIO-        knownTargetsVar <- newTVarIO $ hashed HMap.empty+        knownTargetsVar <- newTVarIO $ hashed emptyKnownTargets         let restartShakeSession = shakeRestart recorder ideState         persistentKeys <- newTVarIO mempty         indexPending <- newTVarIO HMap.empty         indexCompleted <- newTVarIO 0-        indexProgressToken <- newVar Nothing+        semanticTokensId <- newTVarIO 0+        indexProgressReporting <- progressReportingNoTrace+            (liftM2 (+) (length <$> readTVar indexPending) (readTVar indexCompleted))+            (readTVar indexCompleted)+            lspEnv "Indexing" optProgressStyle         let hiedbWriter = HieDbWriter{..}         exportsMap <- newTVarIO mempty         -- lazily initialize the exports map with the contents of the hiedb@@ -636,18 +709,17 @@             atomically $ modifyTVar' exportsMap (<> em)             logWith recorder Debug $ LogCreateHieDbExportsMapFinish (ExportsMap.size em) -        progress <- do-            let (before, after) = if testing then (0,0.1) else (0.1,0.1)+        progress <-             if reportProgress-                then delayedProgressReporting before after lspEnv optProgressStyle-                else noProgressReporting+                then progressReporting lspEnv "Processing" optProgressStyle+                else noPerFileProgressReporting         actionQueue <- newQueue          let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv         dirtyKeys <- newTVarIO mempty         -- Take one VFS snapshot at the start         vfsVar <- newTVarIO =<< vfsSnapshot lspEnv-        pure ShakeExtras{..}+        pure ShakeExtras{shakeRecorder = recorder, ..}     shakeDb  <-         shakeNewDatabase             opts { shakeExtra = newShakeExtra shakeExtras }@@ -688,13 +760,13 @@  -- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO ()-shakeSessionInit recorder ide@IdeState{..} = do+shakeSessionInit recorder IdeState{..} = do     -- Take a snapshot of the VFS - it should be empty as we've received no notifications     -- till now, but it can't hurt to be in sync with the `lsp` library.     vfs <- vfsSnapshot (lspEnv shakeExtras)     initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit"     putMVar shakeSession initSession-    logDebug (ideLogger ide) "Shake session initialized"+    logWith recorder Debug LogSessionInitialised  shakeShut :: IdeState -> IO () shakeShut IdeState{..} = do@@ -704,6 +776,7 @@     for_ runner cancelShakeSession     void $ shakeDatabaseProfile shakeDb     progressStop $ progress shakeExtras+    progressStop $ indexProgressReporting $ hiedbWriter shakeExtras     stopMonitoring  @@ -729,27 +802,33 @@   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 :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO ()-shakeRestart recorder IdeState{..} vfs reason acts =-    withMVar'-        shakeSession-        (\runner -> do-              (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner-              res <- shakeDatabaseProfile shakeDb-              backlog <- readTVarIO $ dirtyKeys shakeExtras-              queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras+shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()+shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession =+    void $ awaitRunInThread (restartQueue shakeExtras) $ do+        withMVar'+            shakeSession+            (\runner -> do+                (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner+                keys <- ioActionBetweenShakeSession+                -- it is every important to update the dirty keys after we enter the critical section+                -- see Note [Housekeeping rule cache and dirty key outside of hls-graph]+                atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys+                res <- shakeDatabaseProfile shakeDb+                backlog <- readTVarIO $ dirtyKeys shakeExtras+                queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras -              -- this log is required by tests-              logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res-        )-        -- 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 recorder shakeExtras vfs shakeDb acts reason)+                -- this log is required by tests+                logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res+            )+            -- 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 recorder shakeExtras vfs shakeDb acts reason)     where         logErrorAfter :: Seconds -> IO () -> IO ()         logErrorAfter seconds action = flip withAsync (const action) $ do@@ -762,7 +841,7 @@ -- --   Appropriate for user actions other than edits. shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a)-shakeEnqueue ShakeExtras{actionQueue, logger} act = do+shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do     (b, dai) <- instantiateDelayedAction act     atomicallyNamed "actionQueue - push" $ pushQueue dai actionQueue     let wait' barrier =@@ -771,7 +850,7 @@                     fail $ "internal bug: forever blocked on MVar for " <>                             actionName act)               , Handler (\e@AsyncCancelled -> do-                  logPriority logger Debug $ T.pack $ actionName act <> " was cancelled"+                  logWith shakeRecorder Debug $ LogCancelledAction (T.pack $ actionName act)                    atomicallyNamed "actionQueue - abort" $ abortQueue dai actionQueue                   throw e)@@ -895,13 +974,12 @@ garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key] garbageCollectKeys label maxAge checkParents agedKeys = do     start <- liftIO offsetTime-    ShakeExtras{state, dirtyKeys, lspEnv, logger, ideTesting} <- getShakeExtras+    ShakeExtras{state, dirtyKeys, lspEnv, shakeRecorder, ideTesting} <- getShakeExtras     (n::Int, garbage) <- liftIO $         foldM (removeDirtyKey dirtyKeys state) (0,[]) agedKeys     t <- liftIO start     when (n>0) $ liftIO $ do-        logDebug logger $ T.pack $-            label <> " of " <> show n <> " keys (took " <> showDuration t <> ")"+        logWith shakeRecorder Debug $ LogShakeGarbageCollection (T.pack label) n t     when (coerce ideTesting) $ liftIO $ mRunLspT lspEnv $         LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/GC"))                              (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage)@@ -1004,13 +1082,8 @@ askShake = ask  -#if MIN_VERSION_ghc(9,3,0) mkUpdater :: NameCache -> NameCacheUpdater mkUpdater = id-#else-mkUpdater :: IORef NameCache -> NameCacheUpdater-mkUpdater ref = NCU (upNameCache ref)-#endif  -- | A (maybe) stale result now, and an up to date one later data FastResult a = FastResult { stale :: Maybe (a,PositionMapping), uptoDate :: IO (Maybe a)  }@@ -1092,6 +1165,23 @@     -- whether the rule succeeded or not.     traverse (lastValue key) files +-- we use separate fingerprint rules to trigger the rebuild of the rule+useWithSeparateFingerprintRule+    :: (IdeRule k v, IdeRule k1 Fingerprint)+    => k1 -> k -> NormalizedFilePath -> Action (Maybe v)+useWithSeparateFingerprintRule fingerKey key file = do+    _ <- use fingerKey file+    useWithoutDependency key emptyFilePath++-- we use separate fingerprint rules to trigger the rebuild of the rule+useWithSeparateFingerprintRule_+    :: (IdeRule k v, IdeRule k1 Fingerprint)+    => k1 -> k -> NormalizedFilePath -> Action v+useWithSeparateFingerprintRule_ fingerKey key file = do+    useWithSeparateFingerprintRule fingerKey key file >>= \case+        Just v -> return v+        Nothing -> liftIO $ throwIO $ BadDependency (show key)+ useWithoutDependency :: IdeRule k v     => k -> NormalizedFilePath -> Action (Maybe v) useWithoutDependency key file =@@ -1116,7 +1206,7 @@     extras <- getShakeExtras     let diagnostics ver diags = do             traceDiagnostics diags-            updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags+            updateFileDiagnostics recorder file ver (newKey key) extras diags     defineEarlyCutoff' diagnostics (==) key file old mode $ const $ op key file defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do     let diagnostics _ver diags = do@@ -1135,7 +1225,7 @@     extras <- getShakeExtras     let diagnostics ver diags = do             traceDiagnostics diags-            updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags+            updateFileDiagnostics recorder file ver (newKey key) extras diags     defineEarlyCutoff' diagnostics (==) key file old mode $ op key file  defineNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules ()@@ -1162,7 +1252,8 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do     ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras     options <- getIdeOptions-    (if optSkipProgress options key then id else inProgress progress file) $ do+    let trans g x =  withRunInIO $ \run -> g (run x)+    (if optSkipProgress options key then id else trans (inProgress progress file)) $ do         val <- case mbOld of             Just old | mode == RunDependenciesSame -> do                 mbValue <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key file@@ -1172,7 +1263,7 @@                     Just (v@(Succeeded _ x), diags) -> do                         ver <- estimateFileVersionUnsafely key (Just x) file                         doDiagnostics (vfsVersion =<< ver) $ Vector.toList diags-                        return $ Just $ RunResult ChangedNothing old $ A v+                        return $ Just $ RunResult ChangedNothing old (A v) $ return ()                     _ -> return Nothing             _ ->                 -- assert that a "clean" rule is never a cache miss@@ -1189,14 +1280,13 @@                 (mbBs, (diags, mbRes)) <- actionCatch                     (do v <- action staleV; liftIO $ evaluate $ force v) $                     \(e :: SomeException) -> do-                        pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))+                        pure (Nothing, ([ideErrorText file (T.pack $ show (key, file) ++ show e) | not $ isBadDependency e],Nothing))                  ver <- estimateFileVersionUnsafely key mbRes file                 (bs, res) <- case mbRes of                     Nothing -> do                         pure (toShakeValue ShakeStale mbBs, staleV)                     Just v -> pure (maybe ShakeNoCutoff ShakeResult mbBs, Succeeded ver v)-                liftIO $ atomicallyNamed "define - write" $ setValues state key file res (Vector.fromList diags)                 doDiagnostics (vfsVersion =<< ver) diags                 let eq = case (bs, fmap decodeShakeValue mbOld) of                         (ShakeResult a, Just (ShakeResult b)) -> cmp a b@@ -1206,9 +1296,12 @@                         _                                     -> False                 return $ RunResult                     (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)-                    (encodeShakeValue bs) $-                    A res-        liftIO $ atomicallyNamed "define - dirtyKeys" $ modifyTVar' dirtyKeys (deleteKeySet $ toKey key file)+                    (encodeShakeValue bs)+                    (A res) $ do+                        -- this hook needs to be run in the same transaction as the key is marked clean+                        -- see Note [Housekeeping rule cache and dirty key outside of hls-graph]+                        setValues state key file res (Vector.fromList diags)+                        modifyTVar' dirtyKeys (deleteKeySet $ toKey key file)         return res   where     -- Highly unsafe helper to compute the version of a file@@ -1232,6 +1325,32 @@         --  * creating bogus "file does not exists" diagnostics         | otherwise = useWithoutDependency (GetModificationTime_ False) fp +-- Note [Housekeeping rule cache and dirty key outside of hls-graph]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Hls-graph contains its own internal running state for each key in the shakeDatabase.+-- ShakeExtras contains `state` field (rule result cache) and `dirtyKeys` (keys that became+-- dirty in between build sessions) that is not visible to the hls-graph+-- Essentially, we need to keep the rule cache and dirty key and hls-graph's internal state+-- in sync.++-- 1. A dirty key collected in a session should not be removed from dirty keys in the same session.+-- Since if we clean out the dirty key in the same session,+--     1.1. we will lose the chance to dirty its reverse dependencies. Since it only happens during session restart.+--     1.2. a key might be marked as dirty in ShakeExtras while it's being recomputed by hls-graph which could lead to it's premature removal from dirtyKeys.+--          See issue https://github.com/haskell/haskell-language-server/issues/4093 for more details.++-- 2. When a key is marked clean in the hls-graph's internal running+-- state, the rule cache and dirty keys are updated in the same transaction.+-- otherwise, some situations like the following can happen:+-- thread 1: hls-graph session run a key+-- thread 1: defineEarlyCutoff' run the action for the key+-- thread 1: the action is done, rule cache and dirty key are updated+-- thread 2: we restart the hls-graph session, thread 1 is killed, the+--           hls-graph's internal state is not updated.+-- This is problematic with early cut off because we are having a new rule cache matching the+-- old hls-graph's internal state, which might case it's reverse dependency to skip the recomputation.+-- See https://github.com/haskell/haskell-language-server/issues/4194 for more details.+ traceA :: A v -> String traceA (A Failed{})    = "Failed" traceA (A Stale{})     = "Stale"@@ -1243,89 +1362,83 @@   -> Maybe Int32   -> Key   -> ShakeExtras-  -> [(ShowDiagnostic,Diagnostic)] -- ^ current results+  -> [FileDiagnostic] -- ^ current results   -> m ()-updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 =+updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 = do   liftIO $ withTrace ("update diagnostics " <> fromString(fromNormalizedFilePath fp)) $ \ addTag -> do     addTag "key" (show k)-    let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current+    let (currentShown, currentHidden) = partition ((== ShowDiag) . fdShouldShowDiagnostic) current         uri = filePathToUri' fp         addTagUnsafe :: String -> String -> String -> a -> a         addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v-        update :: (forall a. String -> String -> a -> a) -> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic]+        update :: (forall a. String -> String -> a -> a) -> [FileDiagnostic] -> STMDiagnosticStore -> STM [FileDiagnostic]         update addTagUnsafeMethod new store = addTagUnsafeMethod "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafeMethod uri ver (renderKey k) new store-        current = second diagsFromRule <$> current0+        current = map (fdLspDiagnosticL %~ diagsFromRule) current0     addTag "version" (show ver)     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 <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") (map snd currentShown) diagnostics-        _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") (map snd currentHidden) hiddenDiagnostics+        newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") currentShown diagnostics+        _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") currentHidden hiddenDiagnostics         let uri' = filePathToUri' fp         let delay = if null newDiags then 0.1 else 0         registerEvent debouncer delay uri' $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do-             join $ mask_ $ do-                 lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics-                 let action = when (lastPublish /= newDiags) $ case lspEnv of+            join $ mask_ $ do+                lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics+                let action = when (lastPublish /= newDiags) $ case lspEnv of                         Nothing -> -- Print an LSP event.-                            logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (fp, ShowDiag,) newDiags)+                            logWith recorder Info $ LogDiagsDiffButNoLspEnv newDiags                         Just env -> LSP.runLspT env $ do                             liftIO $ tag "count" (show $ Prelude.length newDiags)                             liftIO $ tag "key" (show k)                             LSP.sendNotification SMethod_TextDocumentPublishDiagnostics $-                                LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) ( newDiags)-                 return action+                                LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) (map fdLspDiagnostic newDiags)+                return action     where         diagsFromRule :: Diagnostic -> Diagnostic         diagsFromRule c@Diagnostic{_range}             | coerce ideTesting = c & L.relatedInformation ?~-                         [-                        DiagnosticRelatedInformation+                        [ DiagnosticRelatedInformation                             (Location                                 (filePathToUri $ fromNormalizedFilePath fp)                                 _range                             )                             (T.pack $ show k)-                            ]+                        ]             | otherwise = c  -newtype Priority = Priority Double--setPriority :: Priority -> Action ()-setPriority (Priority p) = reschedule p--ideLogger :: IdeState -> Logger-ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger+ideLogger :: IdeState -> Recorder (WithPriority Log)+ideLogger IdeState{shakeExtras=ShakeExtras{shakeRecorder}} = shakeRecorder -actionLogger :: Action Logger-actionLogger = do-    ShakeExtras{logger} <- getShakeExtras-    return logger+actionLogger :: Action (Recorder (WithPriority Log))+actionLogger = shakeRecorder <$> getShakeExtras  ---------------------------------------------------------------------------------type STMDiagnosticStore = STM.Map NormalizedUri StoreItem+type STMDiagnosticStore = STM.Map NormalizedUri StoreItem'+data StoreItem' = StoreItem' (Maybe Int32) FileDiagnosticsBySource+type FileDiagnosticsBySource = Map.Map (Maybe T.Text) (SL.SortedList FileDiagnostic) -getDiagnosticsFromStore :: StoreItem -> [Diagnostic]-getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags+getDiagnosticsFromStore :: StoreItem' -> [FileDiagnostic]+getDiagnosticsFromStore (StoreItem' _ diags) = concatMap SL.fromSortedList $ Map.elems diags  updateSTMDiagnostics ::   (forall a. String -> String -> a -> a) ->   STMDiagnosticStore ->   NormalizedUri ->   Maybe Int32 ->-  DiagnosticsBySource ->-  STM [LSP.Diagnostic]+  FileDiagnosticsBySource ->+  STM [FileDiagnostic] updateSTMDiagnostics addTag store uri mv newDiagsBySource =     getDiagnosticsFromStore . fromJust <$> STM.focus (Focus.alter update *> Focus.lookup) uri store   where-    update (Just(StoreItem mvs dbs))+    update (Just(StoreItem' mvs dbs))       | addTag "previous version" (show mvs) $         addTag "previous count" (show $ Prelude.length $ filter (not.null) $ Map.elems dbs) False = undefined-      | mvs == mv = Just (StoreItem mv (newDiagsBySource <> dbs))-    update _ = Just (StoreItem mv newDiagsBySource)+      | mvs == mv = Just (StoreItem' mv (newDiagsBySource <> dbs))+    update _ = Just (StoreItem' mv newDiagsBySource)  -- | Sets the diagnostics for a file and compilation step --   if you want to clear the diagnostics call this with an empty list@@ -1334,9 +1447,9 @@     -> NormalizedUri     -> Maybe Int32 -- ^ the time that the file these diagnostics originate from was last edited     -> T.Text-    -> [LSP.Diagnostic]+    -> [FileDiagnostic]     -> STMDiagnosticStore-    -> STM [LSP.Diagnostic]+    -> STM [FileDiagnostic] setStageDiagnostics addTag uri ver stage diags ds = updateSTMDiagnostics addTag ds uri ver updatedDiags   where     !updatedDiags = Map.singleton (Just stage) $! SL.toSortedList diags@@ -1345,19 +1458,41 @@     STMDiagnosticStore ->     STM [FileDiagnostic] getAllDiagnostics =-    fmap (concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT+    fmap (concatMap (\(_,v) -> getDiagnosticsFromStore v)) . ListT.toList . STM.listT  updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> STM () updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes =     STM.focus (Focus.alter f) uri positionMapping       where         uri = toNormalizedUri _uri-        f = Just . f' . fromMaybe mempty-        f' mappingForUri = snd $-                -- 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.-                EM.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc)))-                  zeroMapping-                  (EM.insert _version (shared_change, zeroMapping) mappingForUri)-        shared_change = mkDelta changes+        f = Just . updatePositionMappingHelper _version changes . fromMaybe mempty+++updatePositionMappingHelper ::+    Int32+    -> [TextDocumentContentChangeEvent]+    -> EnumMap Int32 (PositionDelta, PositionMapping)+    -> EnumMap Int32 (PositionDelta, PositionMapping)+updatePositionMappingHelper ver changes mappingForUri = snd $+        -- 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.+        EM.mapAccumRWithKey (\acc _k (delta, _) -> let new = addOldDelta delta acc in (new, (delta, acc)))+            zeroMapping+            (EM.insert ver (mkDelta changes, zeroMapping) mappingForUri)++-- | sends a signal whenever shake session is run/restarted+-- being used in cabal and hlint plugin tests to know when its time+-- to look for file diagnostics+kickSignal :: KnownSymbol s => Bool -> Maybe (LSP.LanguageContextEnv c) -> [NormalizedFilePath] -> Proxy s -> Action ()+kickSignal testing lspEnv files msg = when testing $ liftIO $ mRunLspT lspEnv $+  LSP.sendNotification (LSP.SMethod_CustomMethod msg) $+  toJSON $ map fromNormalizedFilePath files++-- | Add kick start/done signal to rule+runWithSignal :: (KnownSymbol s0, KnownSymbol s1, IdeRule k v) => Proxy s0 -> Proxy s1 -> [NormalizedFilePath] -> k -> Action ()+runWithSignal msgStart msgEnd files rule = do+  ShakeExtras{ideTesting = Options.IdeTesting testing, lspEnv} <- getShakeExtras+  kickSignal testing lspEnv files msgStart+  void $ uses rule files+  kickSignal testing lspEnv files msgEnd
src/Development/IDE/Core/Tracing.hs view
@@ -7,7 +7,7 @@     , otTracedGarbageCollection     , withTrace     , withEventTrace-    , withTelemetryLogger+    , withTelemetryRecorder     ) where @@ -26,7 +26,7 @@ import           Development.IDE.Types.Diagnostics (FileDiagnostic,                                                     showDiagnostics) import           Development.IDE.Types.Location    (Uri (..))-import           Ide.Logger                        (Logger (Logger))+import           Ide.Logger import           Ide.Types                         (PluginId (..)) import           Language.LSP.Protocol.Types       (NormalizedFilePath,                                                     fromNormalizedFilePath)@@ -51,17 +51,21 @@   | otherwise = act (\_ -> pure ())  -- | Returns a logger that produces telemetry events in a single span-withTelemetryLogger :: (MonadIO m, MonadMask m) => (Logger -> m a) -> m a-withTelemetryLogger k = withSpan "Logger" $ \sp ->+withTelemetryRecorder :: (MonadIO m, MonadMask m) => (Recorder (WithPriority (Doc a)) -> m c) -> m c+withTelemetryRecorder k = withSpan "Logger" $ \sp ->     -- Tracy doesn't like when we create a new span for every log line.     -- To workaround that, we create a single span for all log events.     -- This is fine since we don't care about the span itself, only about the events-    k $ Logger $ \p m ->-            addEvent sp (fromString $ show p) (encodeUtf8 $ trim m)-    where-        -- eventlog message size is limited by EVENT_PAYLOAD_SIZE_MAX = STG_WORD16_MAX-        trim = T.take (fromIntegral(maxBound :: Word16) - 10)+    k $ telemetryLogRecorder sp +-- | Returns a logger that produces telemetry events in a single span.+telemetryLogRecorder :: SpanInFlight -> Recorder (WithPriority (Doc a))+telemetryLogRecorder sp = Recorder $ \WithPriority {..} ->+  liftIO $ addEvent sp (fromString $ show priority) (encodeUtf8 $ trim $ renderStrict $ layoutCompact payload)+  where+    -- eventlog message size is limited by EVENT_PAYLOAD_SIZE_MAX = STG_WORD16_MAX+    trim = T.take (fromIntegral(maxBound :: Word16) - 10)+ -- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span. otTracedHandler     :: MonadUnliftIO m@@ -108,7 +112,7 @@             ExitCaseSuccess res -> do                 setTag sp "result" (pack $ result $ runValue res)                 setTag sp "changed" $ case res of-                    RunResult x _ _ -> fromString $ show x+                    RunResult x _ _ _ -> fromString $ show x           endSpan sp)         (\sp -> act (liftIO . setTag sp "diagnostics" . encodeUtf8 . showDiagnostics ))   | otherwise = act (\_ -> return ())
src/Development/IDE/Core/UseStale.hs view
@@ -1,7 +1,5 @@-{-# LANGUAGE DerivingVia    #-}-{-# LANGUAGE GADTs          #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE RankNTypes     #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs       #-}  module Development.IDE.Core.UseStale   ( Age(..)
+ src/Development/IDE/Core/WorkerThread.hs view
@@ -0,0 +1,128 @@+{-+Module : Development.IDE.Core.WorkerThread+Author : @soulomoon+SPDX-License-Identifier: Apache-2.0++Description : This module provides an API for managing worker threads in the IDE.+see Note [Serializing runs in separate thread]+-}+module Development.IDE.Core.WorkerThread+  ( LogWorkerThread (..),+    withWorkerQueue,+    awaitRunInThread,+    TaskQueue,+    isEmptyTaskQueue,+    writeTaskQueue,+    withWorkerQueueSimple+  )+where++import           Control.Concurrent.Async  (withAsync)+import           Control.Concurrent.STM+import           Control.Concurrent.Strict (newBarrier, signalBarrier,+                                            waitBarrier)+import           Control.Exception.Safe    (SomeException, finally, throwIO,+                                            try)+import           Control.Monad.Cont        (ContT (ContT))+import qualified Data.Text                 as T+import           Ide.Logger++data LogWorkerThread+  = LogThreadEnding !T.Text+  | LogThreadEnded !T.Text+  | LogSingleWorkStarting !T.Text+  | LogSingleWorkEnded !T.Text+  deriving (Show)++instance Pretty LogWorkerThread where+  pretty = \case+    LogThreadEnding t -> "Worker thread ending:" <+> pretty t+    LogThreadEnded t -> "Worker thread ended:" <+> pretty t+    LogSingleWorkStarting t -> "Worker starting a unit of work: " <+> pretty t+    LogSingleWorkEnded t -> "Worker ended a unit of work: " <+> pretty t++{-+Note [Serializing runs in separate thread]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We often want to take long-running actions using some resource that cannot be shared.+In this instance it is useful to have a queue of jobs to run using the resource.+Like the db writes, session loading in session loader, shake session restarts.++Originally we used various ways to implement this, but it was hard to maintain and error prone.+Moreover, we can not stop these threads uniformly when we are shutting down the server.+-}+data TaskQueue a = TaskQueue (TQueue a)++data ExitOrTask t = Exit | Task t++newTaskQueueIO :: IO (TaskQueue a)+newTaskQueueIO = TaskQueue <$> newTQueueIO++-- | 'withWorkerQueueSimple' is a simplified version of 'withWorkerQueue'+-- for the common case where the worker function is just 'id'.+withWorkerQueueSimple :: Recorder (WithPriority LogWorkerThread) -> T.Text -> ContT () IO (TaskQueue (IO ()))+withWorkerQueueSimple recorder title = withWorkerQueue recorder title id++-- | 'withWorkerQueue' creates a new 'TQueue', and launches a worker+-- thread which polls the queue for requests and runs the given worker+-- function on them.+withWorkerQueue :: Recorder (WithPriority LogWorkerThread) -> T.Text -> (t -> IO ()) -> ContT () IO (TaskQueue t)+withWorkerQueue recorder title workerAction = ContT $ \mainAction -> do+  q <- newTaskQueueIO+  -- Use a TMVar as a stop flag to coordinate graceful shutdown.+  -- The worker thread checks this flag before dequeuing each job; if set, it exits immediately,+  -- ensuring that no new work is started after shutdown is requested.+  -- This mechanism is necessary because some downstream code may swallow async exceptions,+  -- making 'cancel' unreliable for stopping the thread in all cases.+  -- If 'cancel' does interrupt the thread (e.g., while blocked in STM or in a cooperative job),+  -- the thread exits immediately and never checks the TMVar; in such cases, the stop flag is redundant.+  b <- newEmptyTMVarIO+  withAsync (writerThread q b) $ \_ -> do+    mainAction q+    -- if we want to debug the exact location the worker swallows an async exception, we can+    -- temporarily comment out the `finally` clause.+        `finally` atomically (putTMVar b ())+    logWith recorder Debug (LogThreadEnding title)+  logWith recorder Debug (LogThreadEnded title)+  where+    writerThread q b =+      -- See above: check stop flag before dequeuing, exit if set, otherwise run next job.+      do+        task <- atomically $ do+          task <- tryReadTaskQueue q+          isEm <- isEmptyTMVar b+          case (isEm, task) of+            (False, _)   -> return Exit -- stop flag set, exit+            (_, Just t)  -> return $ Task t -- got a task, run it+            (_, Nothing) -> retry -- no task, wait+        case task of+          Exit -> return ()+          Task t -> do+                logWith recorder Debug $ LogSingleWorkStarting title+                workerAction t+                logWith recorder Debug $ LogSingleWorkEnded title+                writerThread q b+++-- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread,+-- and then blocks until the result is computed. If the action throws an+-- non-async exception, it is rethrown in the calling thread.+awaitRunInThread :: TaskQueue (IO ()) -> IO result -> IO result+awaitRunInThread (TaskQueue q) act = do+  -- Take an action from TQueue, run it and+  -- use barrier to wait for the result+  barrier <- newBarrier+  atomically $ writeTQueue q (try act >>= signalBarrier barrier)+  resultOrException <- waitBarrier barrier+  case resultOrException of+    Left e  -> throwIO (e :: SomeException)+    Right r -> return r++writeTaskQueue :: TaskQueue a -> a -> STM ()+writeTaskQueue (TaskQueue q) = writeTQueue q++isEmptyTaskQueue :: TaskQueue a -> STM Bool+isEmptyTaskQueue (TaskQueue q) = isEmptyTQueue q++tryReadTaskQueue :: TaskQueue a -> STM (Maybe a)+tryReadTaskQueue (TaskQueue q) = tryReadTQueue q
src/Development/IDE/GHC/CPP.hs view
@@ -18,21 +18,18 @@ import           Development.IDE.GHC.Compat      as Compat import           Development.IDE.GHC.Compat.Util import           GHC+import           GHC.Settings+import qualified GHC.SysTools.Cpp                as Pipeline  -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -import           GHC.Settings -#if !MIN_VERSION_ghc(9,3,0)-import qualified GHC.Driver.Pipeline             as Pipeline-#endif--#if MIN_VERSION_ghc(9,3,0) && !MIN_VERSION_ghc(9,5,0)-import qualified GHC.Driver.Pipeline.Execute     as Pipeline+#if MIN_VERSION_ghc(9,10,2)+import qualified GHC.SysTools.Tasks              as Pipeline #endif -#if MIN_VERSION_ghc(9,5,0)-import qualified GHC.SysTools.Cpp                as Pipeline+#if MIN_VERSION_ghc(9,11,0)+import qualified GHC.SysTools.Tasks              as Pipeline #endif  addOptP :: String -> DynFlags -> DynFlags@@ -46,22 +43,21 @@  doCpp :: HscEnv -> FilePath -> FilePath -> IO () doCpp env input_fn output_fn =-        -- See GHC commit a2f53ac8d968723417baadfab5be36a020ea6850-        -- this function/Pipeline.doCpp previously had a raw parameter-        -- always set to True that corresponded to these settings--#if MIN_VERSION_ghc(9,5,0)+    -- See GHC commit a2f53ac8d968723417baadfab5be36a020ea6850+    -- this function/Pipeline.doCpp previously had a raw parameter+    -- always set to True that corresponded to these settings     let cpp_opts = Pipeline.CppOpts                  { cppLinePragmas = True-# if MIN_VERSION_ghc(9,9,0)++#if MIN_VERSION_ghc(9,10,2)+                 , sourceCodePreprocessor = Pipeline.SCPHsCpp+#elif MIN_VERSION_ghc(9,10,0)                  , useHsCpp = True-# else-                 , cppUseCc = False-# endif-                 } in #else-    let cpp_opts = True in+                 , cppUseCc = False #endif++                 } in      Pipeline.doCpp (hsc_logger env) (hsc_tmpfs env) (hsc_dflags env) (hsc_unit_env env) cpp_opts input_fn output_fn
src/Development/IDE/GHC/Compat.hs view
@@ -1,51 +1,29 @@ -- 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-incomplete-uni-patterns -Wno-dodgy-imports #-}+{-# LANGUAGE CPP             #-}+{-# LANGUAGE PatternSynonyms #-}  -- | Attempt at hiding the GHC version differences we can. module Development.IDE.GHC.Compat(-    mkHomeModLocation,     hPutStringBuffer,     addIncludePathsQuote,     getModuleHash,     setUpTypedHoles,-    NameCacheUpdater(..),-#if MIN_VERSION_ghc(9,3,0)-    getMessages,-    renderDiagnosticMessageWithHints,-    nameEnvElts,-#else-    upNameCache,-#endif     lookupNameCache,     disableWarningsAsErrors,     reLoc,     reLocA,-    getPsMessages,     renderMessages,     pattern PFailedWithErrorMessages,-    isObjectLinkable,--#if !MIN_VERSION_ghc(9,3,0)-    extendModSummaryNoDeps,-    emsModSummary,-#endif     myCoreToStgExpr,-     Usage(..),--    liftZonkM,-     FastStringCompat,     bytesFS,     mkFastStringByteString,     nodeInfo',     getNodeIds,+    getSourceNodeIds,     sourceNodeInfo,     generatedNodeInfo,     simpleNodeInfoCompat,@@ -53,10 +31,6 @@     nodeAnnotations,     mkAstNode,     combineRealSrcSpans,--    nonDetOccEnvElts,-    nonDetFoldOccEnv,-     isQualifiedImport,     GhcVersion(..),     ghcVersion,@@ -71,8 +45,6 @@     readHieFile,     setHieDir,     dontWriteHieFiles,-    module Compat.HieTypes,-    module Compat.HieUtils,     -- * Compat modules     module Development.IDE.GHC.Compat.Core,     module Development.IDE.GHC.Compat.Env,@@ -94,7 +66,7 @@     simplifyExpr,     tidyExpr,     emptyTidyEnv,-    tcInitTidyEnv,+    tidyOpenType,     corePrepExpr,     corePrepPgm,     lintInteractiveExpr,@@ -102,11 +74,7 @@     HomePackageTable,     lookupHpt,     loadModulesHome,-#if MIN_VERSION_ghc(9,3,0)-    Dependencies(dep_direct_mods),-#else-    Dependencies(dep_mods),-#endif+    hugElts,     bcoFreeNames,     ModIfaceAnnotation,     pattern Annotation,@@ -121,7 +89,9 @@     emptyInScopeSet,     Unfolding(..),     noUnfolding,+#if !MIN_VERSION_ghc(9,13,0)     loadExpr,+#endif     byteCodeGen,     bc_bcos,     loadDecls,@@ -129,13 +99,31 @@     expectJust,     extract_cons,     recDotDot,-#if MIN_VERSION_ghc(9,5,0)+++    Dependencies(dep_direct_mods),+    NameCacheUpdater,+     XModulePs(..),++#if !MIN_VERSION_ghc(9,7,0)+    liftZonkM,+    nonDetFoldOccEnv, #endif-    ) where -import           Prelude                               hiding (mod)-import           Development.IDE.GHC.Compat.Core hiding (moduleUnitId)+#if MIN_VERSION_ghc(9,7,0)+    tcInitTidyEnv,+#endif++    ) where+import           Control.Applicative                     ((<|>))+import qualified Data.ByteString                         as BS+import           Data.Coerce                             (coerce)+import           Data.List                               (foldl')+import qualified Data.Map                                as Map+import qualified Data.Set                                as S+import           Data.String                             (IsString (fromString))+import           Development.IDE.GHC.Compat.Core import           Development.IDE.GHC.Compat.Env import           Development.IDE.GHC.Compat.Iface import           Development.IDE.GHC.Compat.Logger@@ -144,287 +132,202 @@ import           Development.IDE.GHC.Compat.Plugins import           Development.IDE.GHC.Compat.Units import           Development.IDE.GHC.Compat.Util-import           GHC                                   hiding (HasSrcSpan,-                                                        ModLocation,-                                                        RealSrcSpan, exprType,-                                                        getLoc, lookupName)-import           Data.Coerce                           (coerce)-import           Data.String                           (IsString (fromString))-import           Compat.HieAst                         (enrichHie)-import           Compat.HieBin-import           Compat.HieTypes                       hiding (nodeAnnotations)-import qualified Compat.HieTypes                       as GHC (nodeAnnotations)-import           Compat.HieUtils-import qualified Data.ByteString                       as BS-import           Data.List                             (foldl')-import qualified Data.Map                              as Map-import qualified Data.Set                              as S---- See Note [Guidelines For Using CPP In GHCIDE Import Statements]+import           GHC                                     hiding (ModLocation,+                                                          RealSrcSpan, exprType,+                                                          getLoc, lookupName)+import           Prelude                                 hiding (mod) -#if MIN_VERSION_ghc(9,7,0)-import           GHC.Tc.Zonk.TcType                    (tcInitTidyEnv)-#endif-import qualified GHC.Core.Opt.Pipeline                 as GHC-import           GHC.Core.Tidy                         (tidyExpr)-import           GHC.CoreToStg.Prep                    (corePrepPgm)-import qualified GHC.CoreToStg.Prep                    as GHC-import           GHC.Driver.Hooks                      (hscCompileCoreExprHook)+import qualified GHC.Core.Opt.Pipeline                   as GHC+import           GHC.Core.Tidy                           (tidyExpr)+import           GHC.Core.TyCo.Tidy                      (tidyOpenType)+import           GHC.CoreToStg.Prep                      (corePrepPgm)+import qualified GHC.CoreToStg.Prep                      as GHC+import           GHC.Driver.Hooks                        (hscCompileCoreExprHook)+import           GHC.Iface.Ext.Types                     hiding+                                                         (nodeAnnotations)+import qualified GHC.Iface.Ext.Types                     as GHC (nodeAnnotations)+import           GHC.Iface.Ext.Utils -import           GHC.ByteCode.Asm                      (bcoFreeNames)-import           GHC.Types.Annotations                 (AnnTarget (ModuleTarget),-                                                        Annotation (..),-                                                        extendAnnEnvList)-import           GHC.Types.Unique.DFM                  as UniqDFM-import           GHC.Types.Unique.DSet                 as UniqDSet-import           GHC.Types.Unique.Set                  as UniqSet-import           GHC.Data.FastString+import           GHC.ByteCode.Asm                        (bcoFreeNames) import           GHC.Core+import           GHC.Data.FastString import           GHC.Data.StringBuffer-import           GHC.Driver.Session                    hiding (ExposePackage)+import           GHC.Driver.Session                      hiding (ExposePackage)+import           GHC.Iface.Ext.Ast                       (enrichHie)+import           GHC.Iface.Ext.Binary+import           GHC.Iface.Make                          (mkIfaceExports)+import           GHC.SysTools.Tasks                      (runPp, runUnlit)+import           GHC.Types.Annotations                   (AnnTarget (ModuleTarget),+                                                          Annotation (..),+                                                          extendAnnEnvList)+import qualified GHC.Types.Avail                         as Avail+import           GHC.Types.Unique.DFM                    as UniqDFM+import           GHC.Types.Unique.DSet                   as UniqDSet+import           GHC.Types.Unique.Set                    as UniqSet import           GHC.Types.Var.Env-import           GHC.Iface.Make                        (mkIfaceExports)-import           GHC.SysTools.Tasks                    (runUnlit, runPp)-import qualified GHC.Types.Avail                       as Avail --#if !MIN_VERSION_ghc(9,5,0)-import           GHC.Core.Lint                         (lintInteractiveExpr)-#endif---import           GHC.Iface.Env-import           GHC.Types.SrcLoc                      (combineRealSrcSpans)-import           GHC.Linker.Loader                     (loadExpr)-import           GHC.Runtime.Context                   (icInteractiveModule)-import           GHC.Unit.Home.ModInfo                 (HomePackageTable,-                                                        lookupHpt)-import           GHC.Driver.Env                        as Env-import           GHC.Unit.Module.ModIface import           GHC.Builtin.Uniques import           GHC.ByteCode.Types+import           GHC.Core.Lint.Interactive               (interactiveInScope) import           GHC.CoreToStg import           GHC.Data.Maybe-import           GHC.Linker.Loader                     (loadDecls)+import           GHC.Driver.Config.Core.Lint.Interactive (lintInteractiveExpr)+import           GHC.Driver.Config.Core.Opt.Simplify     (initSimplifyExprOpts)+import           GHC.Driver.Config.CoreToStg             (initCoreToStgOpts)+import           GHC.Driver.Config.CoreToStg.Prep        (initCorePrepConfig)+import           GHC.Driver.Config.Stg.Pipeline+import           GHC.Driver.Env                          as Env+import           GHC.Iface.Env+import           GHC.Linker.Loader                       (loadDecls+#if !MIN_VERSION_ghc(9,13,0)+                                                         , loadExpr+#endif+                                                         )+import           GHC.Runtime.Context                     (icInteractiveModule) import           GHC.Stg.Pipeline import           GHC.Stg.Syntax import           GHC.StgToByteCode import           GHC.Types.CostCentre import           GHC.Types.IPE--#if !MIN_VERSION_ghc(9,3,0)-import           GHC.Unit.Module.Deps (Dependencies(dep_mods), Usage(..))-import           GHC.Linker.Types                      (isObjectLinkable)-import           GHC.Unit.Module.ModSummary-import           GHC.Runtime.Interpreter+import           GHC.Types.SrcLoc                        (combineRealSrcSpans)+#if MIN_VERSION_ghc(9,13,0)+import           GHC.Unit.Home.PackageTable              (HomePackageTable,+                                                          lookupHpt)+#else+import           GHC.Unit.Home.ModInfo                   (HomePackageTable,+                                                          lookupHpt) #endif+import           GHC.Unit.Module.Deps                    (Dependencies (dep_direct_mods),+                                                          Usage (..))+import           GHC.Unit.Module.ModIface -#if !MIN_VERSION_ghc(9,3,0)-import           Data.IORef-#endif+-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if MIN_VERSION_ghc(9,3,0)-import GHC.Unit.Module.Deps (Dependencies(dep_direct_mods), Usage(..))-import GHC.Driver.Config.Stg.Pipeline+#if MIN_VERSION_ghc(9,13,0)+import           GHC.Unit.Home.Graph                     (addHomeModInfoToHug, unitEnv_assocs) #endif -#if MIN_VERSION_ghc(9,5,0)-import           GHC.Core.Lint.Interactive                           (interactiveInScope)-import           GHC.Driver.Config.Core.Lint.Interactive             (lintInteractiveExpr)-import           GHC.Driver.Config.Core.Opt.Simplify                 (initSimplifyExprOpts)-import           GHC.Driver.Config.CoreToStg                         (initCoreToStgOpts)-import           GHC.Driver.Config.CoreToStg.Prep                    (initCorePrepConfig)+#if MIN_VERSION_ghc(9,7,0)+import           GHC.Tc.Zonk.TcType                      (tcInitTidyEnv) #endif  #if !MIN_VERSION_ghc(9,7,0) liftZonkM :: a -> a liftZonkM = id-#endif -#if !MIN_VERSION_ghc(9,7,0) nonDetFoldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b nonDetFoldOccEnv = foldOccEnv #endif -#if !MIN_VERSION_ghc(9,3,0)-nonDetOccEnvElts :: OccEnv a -> [a]-nonDetOccEnvElts = occEnvElts-#endif  type ModIfaceAnnotation = Annotation -#if MIN_VERSION_ghc(9,3,0)-nameEnvElts :: NameEnv a -> [a]-nameEnvElts = nonDetNameEnvElts-#endif  myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext-#if MIN_VERSION_ghc(9,3,0)             -> Bool-#endif                 -> Module -> ModLocation -> CoreExpr                 -> IO ( Id-#if MIN_VERSION_ghc(9,3,0)                       ,[CgStgTopBinding] -- output program-#else-                      ,[StgTopBinding] -- output program-#endif                       , InfoTableProvMap                       , CollectedCCs ) myCoreToStgExpr logger dflags ictxt-#if MIN_VERSION_ghc(9,3,0)                 for_bytecode-#endif                 this_mod ml prepd_expr = do     {- Create a temporary binding (just because myCoreToStg needs a        binding for the stg2stg step) -}     let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel")                                 (mkPseudoUniqueE 0)-#if MIN_VERSION_ghc(9,5,0)                                 ManyTy-#else-                                Many-#endif                                 (exprType prepd_expr)     (stg_binds, prov_map, collected_ccs) <-        myCoreToStg logger                    dflags                    ictxt-#if MIN_VERSION_ghc(9,3,0)                    for_bytecode-#endif                    this_mod                    ml                    [NonRec bco_tmp_id prepd_expr]     return (bco_tmp_id, stg_binds, prov_map, collected_ccs)  myCoreToStg :: Logger -> DynFlags -> InteractiveContext-#if MIN_VERSION_ghc(9,3,0)             -> Bool-#endif             -> Module -> ModLocation -> CoreProgram-#if MIN_VERSION_ghc(9,3,0)             -> IO ( [CgStgTopBinding] -- output program-#else-            -> IO ( [StgTopBinding] -- output program-#endif                   , InfoTableProvMap                   , CollectedCCs )  -- CAF cost centre info (declared and used) myCoreToStg logger dflags ictxt-#if MIN_VERSION_ghc(9,3,0)             for_bytecode-#endif             this_mod ml prepd_binds = do     let (stg_binds, denv, cost_centre_info)          = {-# SCC "Core2Stg" #-}            coreToStg-#if MIN_VERSION_ghc(9,5,0)              (initCoreToStgOpts dflags)-#else-             dflags-#endif              this_mod ml prepd_binds  #if MIN_VERSION_ghc(9,8,0)     (unzip -> (stg_binds2,_),_)-#elif MIN_VERSION_ghc(9,4,2)-    (stg_binds2,_) #else-    stg_binds2+    (stg_binds2,_) #endif         <- {-# SCC "Stg2Stg" #-}-#if MIN_VERSION_ghc(9,3,0)            stg2stg logger-#if MIN_VERSION_ghc(9,5,0)                    (interactiveInScope ictxt)-#else-                   ictxt-#endif                    (initStgPipelineOpts dflags for_bytecode) this_mod stg_binds-#else-           stg2stg logger dflags ictxt this_mod stg_binds-#endif      return (stg_binds2, denv, cost_centre_info) -+#if MIN_VERSION_ghc(9,9,0)+reLocA :: (HasLoc (GenLocated a e), HasAnnotation b)+      => GenLocated a e -> GenLocated b e+reLocA = reLoc+#endif  getDependentMods :: ModIface -> [ModuleName]-#if MIN_VERSION_ghc(9,3,0)-getDependentMods = map (gwib_mod . snd) . S.toList . dep_direct_mods . mi_deps+#if MIN_VERSION_ghc(9,13,0)+getDependentMods = map (gwib_mod . (\(_,_,x) -> x)) . S.toList . dep_direct_mods . mi_deps #else-getDependentMods = map gwib_mod . dep_mods . mi_deps+getDependentMods = map (gwib_mod . snd) . S.toList . dep_direct_mods . mi_deps #endif  simplifyExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr-#if MIN_VERSION_ghc(9,5,0) simplifyExpr _ env = GHC.simplifyExpr (Development.IDE.GHC.Compat.Env.hsc_logger env) (ue_eps (Development.IDE.GHC.Compat.Env.hsc_unit_env env)) (initSimplifyExprOpts (hsc_dflags env) (hsc_IC env))-#else-simplifyExpr _ = GHC.simplifyExpr-#endif  corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr-#if MIN_VERSION_ghc(9,5,0) corePrepExpr _ env expr = do   cfg <- initCorePrepConfig env   GHC.corePrepExpr (Development.IDE.GHC.Compat.Env.hsc_logger env) cfg expr-#else-corePrepExpr _ = GHC.corePrepExpr-#endif  renderMessages :: PsMessages -> (Bag WarnMsg, Bag ErrMsg) renderMessages msgs =-#if MIN_VERSION_ghc(9,3,0)-  let renderMsgs extractor = (fmap . fmap) renderDiagnosticMessageWithHints . getMessages $ extractor msgs+  let renderMsgs extractor = (fmap . fmap) GhcPsMessage . getMessages $ extractor msgs   in (renderMsgs psWarnings, renderMsgs psErrors)-#else-  msgs-#endif -pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope DecoratedSDoc)) -> ParseResult a+pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope GhcMessage)) -> ParseResult a pattern PFailedWithErrorMessages msgs-#if MIN_VERSION_ghc(9,3,0)-     <- PFailed (const . fmap (fmap renderDiagnosticMessageWithHints) . getMessages . getPsErrorMessages -> msgs)-#else-     <- PFailed (const . fmap pprError . getErrorMessages -> msgs)-#endif+     <- PFailed (const . fmap (fmap GhcPsMessage) . getMessages . getPsErrorMessages -> msgs) {-# COMPLETE POk, PFailedWithErrorMessages #-}  hieExportNames :: HieFile -> [(SrcSpan, Name)] hieExportNames = nameListFromAvails . hie_exports -#if MIN_VERSION_ghc(9,3,0) type NameCacheUpdater = NameCache-#else -lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)--- Lookup up the (Module,OccName) in the NameCache--- If you find it, return it; if not, allocate a fresh original name and extend--- the NameCache.--- Reason: this may the first occurrence of (say) Foo.bar we have encountered.--- If we need to explore its value we will load Foo.hi; but meanwhile all we--- need is a Name for it.-lookupNameCache mod occ name_cache =-  case lookupOrigNameCache (nsNames name_cache) mod occ of {-    Just name -> (name_cache, name);-    Nothing   ->-        case takeUniqFromSupply (nsUniqs name_cache) of {-          (uniq, us) ->-              let-                name      = mkExternalName uniq mod occ noSrcSpan-                new_cache = extendNameCache (nsNames name_cache) mod occ name-              in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }}--upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c-upNameCache = updNameCache-#endif- mkHieFile' :: ModSummary            -> [Avail.AvailInfo]+#if MIN_VERSION_ghc(9,11,0)+           -> (HieASTs Type, NameEntityInfo)+#else            -> HieASTs Type+#endif            -> BS.ByteString            -> Hsc HieFile-mkHieFile' ms exports asts src = do+mkHieFile' ms exports+#if MIN_VERSION_ghc(9,11,0)+            (asts, entityInfo)+#else+            asts+#endif+            src = do   let Just src_file = ml_hs_file $ ms_location ms       (asts',arr) = compressTypes asts   return $ HieFile@@ -432,6 +335,9 @@       , hie_module = ms_mod ms       , hie_types = arr       , hie_asts = asts'+#if MIN_VERSION_ghc(9,11,0)+      , hie_entity_infos = entityInfo+#endif       -- mkIfaceExports sorts the AvailInfos for stability       , hie_exports = mkIfaceExports exports       , hie_hs_src = src@@ -447,7 +353,7 @@ dontWriteHieFiles :: DynFlags -> DynFlags dontWriteHieFiles d = gopt_unset d Opt_WriteHie -setUpTypedHoles ::DynFlags -> DynFlags+setUpTypedHoles :: DynFlags -> DynFlags setUpTypedHoles df   = flip gopt_unset Opt_AbstractRefHoleFits    -- too spammy   $ flip gopt_unset Opt_ShowDocsOfHoleFits     -- not used@@ -460,9 +366,13 @@   $ 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+  { refLevelHoleFits = refLevelHoleFits df <|> Just 1   -- becomes slow at higher levels++   -- Sometimes GHC can emit a lot of hole fits, this causes editors to be slow+   -- or just crash, we limit the hole fits to 10. The number was chosen+   -- arbirtarily by the author.+  , maxRefHoleFits   = maxRefHoleFits df <|> Just 10+  , maxValidHoleFits = maxValidHoleFits df <|> Just 10   }  @@ -472,7 +382,11 @@   getModuleHash :: ModIface -> Fingerprint+#if MIN_VERSION_ghc(9,13,0)+getModuleHash = mi_mod_hash+#else getModuleHash = mi_mod_hash . mi_final_exts+#endif   disableWarningsAsErrors :: DynFlags -> DynFlags@@ -484,7 +398,9 @@ isQualifiedImport ImportDecl{}                              = True isQualifiedImport _                                         = False -+-- | Like getNodeIds but with generated node removed+getSourceNodeIds :: HieAST a -> Map.Map Identifier (IdentifierDetails a)+getSourceNodeIds = Map.foldl' combineNodeIds Map.empty . Map.filterWithKey (\k _ -> k == SourceInfo) . getSourcedNodeInfo . sourcedNodeInfo  getNodeIds :: HieAST a -> Map.Map Identifier (IdentifierDetails a) getNodeIds = Map.foldl' combineNodeIds Map.empty . getSourcedNodeInfo . sourcedNodeInfo@@ -517,26 +433,27 @@ generatedNodeInfo = Map.lookup GeneratedInfo . getSourcedNodeInfo . sourcedNodeInfo  data GhcVersion-  = GHC810-  | GHC90-  | GHC92-  | GHC94-  | GHC96+  = GHC96   | GHC98-  deriving (Eq, Ord, Show)+  | GHC910+  | GHC912+  | GHC914+  deriving (Eq, Ord, Show, Enum)  ghcVersionStr :: String ghcVersionStr = VERSION_ghc  ghcVersion :: GhcVersion-#if MIN_VERSION_GLASGOW_HASKELL(9,8,0,0)+#if MIN_VERSION_GLASGOW_HASKELL(9,14,0,0)+ghcVersion = GHC914+#elif MIN_VERSION_GLASGOW_HASKELL(9,12,0,0)+ghcVersion = GHC912+#elif MIN_VERSION_GLASGOW_HASKELL(9,10,0,0)+ghcVersion = GHC910+#elif MIN_VERSION_GLASGOW_HASKELL(9,8,0,0) ghcVersion = GHC98-#elif MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)+#else ghcVersion = GHC96-#elif MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)-ghcVersion = GHC94-#elif MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)-ghcVersion = GHC92 #endif  simpleNodeInfoCompat :: FastStringCompat -> FastStringCompat -> NodeInfo a@@ -567,29 +484,28 @@ loadModulesHome     :: [HomeModInfo]     -> HscEnv+#if MIN_VERSION_ghc(9,13,0)+    -> IO HscEnv+loadModulesHome mod_infos e = do+  let hug = hsc_HUG (e { hsc_type_env_vars = emptyKnotVars })+  mapM_ (`addHomeModInfoToHug` hug) mod_infos+  pure (e { hsc_type_env_vars = emptyKnotVars })+#else     -> HscEnv loadModulesHome mod_infos e =-#if MIN_VERSION_ghc(9,3,0)   hscUpdateHUG (\hug -> foldl' (flip addHomeModInfoToHug) hug mod_infos) (e { hsc_type_env_vars = emptyKnotVars })-#else-  let !new_modules = addListToHpt (hsc_HPT e) [(mod_name x, x) | x <- mod_infos]-  in e { hsc_HPT = new_modules-       , hsc_type_env_var = Nothing-       }-    where-      mod_name = moduleName . mi_module . hm_iface #endif +#if MIN_VERSION_ghc(9,13,0)+hugElts :: HomeUnitGraph -> [(UnitId, HomeUnitEnv)]+hugElts = unitEnv_assocs+#endif+ recDotDot :: HsRecFields (GhcPass p) arg -> Maybe Int recDotDot x =-#if MIN_VERSION_ghc(9,5,0)             unRecFieldsDotDot <$>-#endif             unLoc <$> rec_dotdot x -#if MIN_VERSION_ghc(9,5,0)-extract_cons (NewTypeCon x) = [x]+extract_cons :: DataDefnCons a -> [a]+extract_cons (NewTypeCon x)      = [x] extract_cons (DataTypeCons _ xs) = xs-#else-extract_cons = id-#endif
+ src/Development/IDE/GHC/Compat/CmdLine.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE CPP #-}++-- | Compat module Interface file relevant code.+module Development.IDE.GHC.Compat.CmdLine (+          processCmdLineP+        , CmdLineP (..)+        , getCmdLineState+        , putCmdLineState+        , Flag(..)+        , OptKind(..)+        , EwM+        , defFlag+        , liftEwM+    ) where++import           GHC.Driver.CmdLine+import           GHC.Driver.Session (CmdLineP (..), getCmdLineState,+                                     processCmdLineP, putCmdLineState)+
src/Development/IDE/GHC/Compat/Core.hs view
@@ -1,8 +1,5 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE ConstraintKinds   #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PatternSynonyms   #-}-{-# LANGUAGE ViewPatterns   #-}+{-# LANGUAGE CPP             #-}+{-# LANGUAGE PatternSynonyms #-}  -- | Compat Core module that handles the GHC module hierarchy re-organization -- by re-exporting everything we care about.@@ -61,9 +58,6 @@     pattern ExposePackage,     parseDynamicFlagsCmdLine,     parseDynamicFilePragma,-#if !MIN_VERSION_ghc(9,3,0)-    WarnReason(..),-#endif     wWarningFlags,     updOptLevel,     -- slightly unsafe@@ -75,17 +69,20 @@     IfaceTyCon(..),     ModIface,     ModIface_(..),+#if MIN_VERSION_ghc(9,11,0)+    pattern ModIface,+    set_mi_top_env,+#if !MIN_VERSION_ghc(9,13,0)+    set_mi_usages,+#endif+#endif     HscSource(..),     WhereFrom(..),     loadInterface,-#if !MIN_VERSION_ghc(9,3,0)-    SourceModified(..),-#endif     loadModuleInterface,     RecompileRequired(..),     mkPartialIface,     mkFullIface,-    checkOldIface,     IsBootInterface(..),     -- * Fixity     LexicalFixity(..),@@ -120,14 +117,11 @@     pattern ConPatIn,     conPatDetails,     mapConPatDetail,-    mkVisFunTys,     -- * Specs     ImpDeclSpec(..),     ImportSpec(..),     -- * SourceText     SourceText(..),-    -- * Name-    tyThingParent_maybe,     -- * Ways     Way,     wayGeneralFlags,@@ -168,6 +162,7 @@     hscInteractive,     hscSimplify,     hscTypecheckRename,+    hscUpdateHPT,     Development.IDE.GHC.Compat.Core.makeSimpleDetails,     -- * Typecheck utils     tcSplitForAllTyVars,@@ -176,7 +171,6 @@     Development.IDE.GHC.Compat.Core.mkIfaceTc,     Development.IDE.GHC.Compat.Core.mkBootModDetailsTc,     Development.IDE.GHC.Compat.Core.initTidyOpts,-    hscUpdateHPT,     driverNoStop,     tidyProgram,     ImportedModsVal(..),@@ -204,8 +198,9 @@     pattern RealSrcLoc,     SrcLoc.SrcLoc(SrcLoc.UnhelpfulLoc),     BufSpan,-    SrcSpanAnn',+#if !MIN_VERSION_ghc(9,9,0)     GHC.SrcAnn,+#endif     SrcLoc.leftmost_smallest,     SrcLoc.containsSpan,     SrcLoc.mkGeneralSrcSpan,@@ -232,18 +227,22 @@     SrcLoc.noSrcSpan,     SrcLoc.noSrcLoc,     SrcLoc.noLoc,+    SrcLoc.srcSpanToRealSrcSpan,     mapLoc,     -- * Finder     FindResult(..),     mkHomeModLocation,-    addBootSuffixLocnOut,     findObjectLinkableMaybe,     InstalledFindResult(..),     -- * Module and Package     ModuleOrigin(..),     PackageName(..),     -- * Linker+#if MIN_VERSION_ghc(9,11,0)+    LinkablePart(..),+#else     Unlinked(..),+#endif     Linkable(..),     unload,     -- * Hooks@@ -262,7 +261,7 @@     -- * Driver-Make     Target(..),     TargetId(..),-    mkModuleGraph,+    mkSimpleTarget,     -- * GHCi     initObjLinker,     loadDLL,@@ -284,8 +283,6 @@     Role(..),     -- * Panic     Plain.PlainGhcException,-    panic,-    panicDoc,     -- * Other     GHC.CoreModule(..),     GHC.SafeHaskellMode(..),@@ -320,6 +317,7 @@     module GHC.HsToCore.Monad,      module GHC.Iface.Syntax,+    module GHC.Iface.Recomp,      module GHC.Hs.Decls,     module GHC.Hs.Expr,@@ -343,9 +341,8 @@      module GHC.Types.Basic,     module GHC.Types.Id,-    module GHC.Types.Name            ,+    module GHC.Types.Name,     module GHC.Types.Name.Set,-     module GHC.Types.Name.Cache,     module GHC.Types.Name.Env,     module GHC.Types.Name.Reader,@@ -360,52 +357,38 @@     module GHC.Types.Unique.Supply,     module GHC.Types.Var,     module GHC.Unit.Module,+    module GHC.Unit.Module.Graph,     -- * Syntax re-exports     module GHC.Hs,     module GHC.Hs.Binds,     module GHC.Parser,     module GHC.Parser.Header,     module GHC.Parser.Lexer,-#if MIN_VERSION_ghc(9,3,0)+    module GHC.Utils.Panic,     CompileReason(..),     hsc_type_env_vars,-    hscUpdateHUG, hscUpdateHPT, hsc_HUG,+    hscUpdateHUG, hsc_HUG,     GhcMessage(..),     getKey,     module GHC.Driver.Env.KnotVars,-    module GHC.Iface.Recomp,     module GHC.Linker.Types,-    module GHC.Unit.Module.Graph,     module GHC.Types.Unique.Map,     module GHC.Utils.TmpFs,-    module GHC.Utils.Panic,     module GHC.Unit.Finder.Types,     module GHC.Unit.Env,     module GHC.Driver.Phases,-#endif-# if !MIN_VERSION_ghc(9,4,0)-    pattern HsFieldBind,-    hfbAnn,-    hfbLHS,-    hfbRHS,-    hfbPun,-#endif-#if !MIN_VERSION_ghc_boot_th(9,4,1)-    Extension(.., NamedFieldPuns),-#else     Extension(..),-#endif-    UniqFM,     mkCgInteractiveGuts,     justBytecode,     justObjects,     emptyHomeModInfoLinkable,     homeModInfoByteCode,     homeModInfoObject,-# if !MIN_VERSION_ghc(9,5,0)-    field_label,-#endif     groupOrigin,+    isVisibleFunArg,+#if MIN_VERSION_ghc(9,8,0)+    lookupGlobalRdrEnv+#endif     ) where  import qualified GHC@@ -413,182 +396,202 @@ -- NOTE(ozkutuk): Cpp clashes Phase.Cpp, so we hide it. -- Not the greatest solution, but gets the job done -- (until the CPP extension is actually needed).-import GHC.LanguageExtensions.Type hiding (Cpp)--import           GHC.Hs.Binds---- See Note [Guidelines For Using CPP In GHCIDE Import Statements]+import           GHC.LanguageExtensions.Type hiding (Cpp) -import           GHC.Builtin.Names            hiding (Unique, printName)+import           GHC.Builtin.Names           hiding (Unique, printName) import           GHC.Builtin.Types import           GHC.Builtin.Types.Prim import           GHC.Builtin.Utils+import           GHC.Core                    (CoreProgram) import           GHC.Core.Class import           GHC.Core.Coercion import           GHC.Core.ConLike-import           GHC.Core.DataCon             hiding (dataConExTyCoVars)-import qualified GHC.Core.DataCon             as DataCon-import           GHC.Core.FamInstEnv          hiding (pprFamInst)+import           GHC.Core.DataCon            hiding (dataConExTyCoVars)+import qualified GHC.Core.DataCon            as DataCon+import           GHC.Core.FamInstEnv         hiding (pprFamInst) import           GHC.Core.InstEnv-import           GHC.Types.Unique.FM  import           GHC.Core.PatSyn import           GHC.Core.Predicate import           GHC.Core.TyCo.Ppr-import qualified GHC.Core.TyCo.Rep            as TyCoRep+import qualified GHC.Core.TyCo.Rep           as TyCoRep import           GHC.Core.TyCon-import           GHC.Core.Type                +import           GHC.Core.Type import           GHC.Core.Unify import           GHC.Core.Utils-import           GHC.Driver.CmdLine           (Warn (..))+import           GHC.Driver.CmdLine          (Warn (..)) import           GHC.Driver.Hooks-import           GHC.Driver.Main              as GHC+import           GHC.Driver.Main             as GHC import           GHC.Driver.Monad import           GHC.Driver.Phases import           GHC.Driver.Pipeline import           GHC.Driver.Plugins-import           GHC.Driver.Session           hiding (ExposePackage)-import qualified GHC.Driver.Session           as DynFlags+import           GHC.Driver.Session          hiding (ExposePackage)+import qualified GHC.Driver.Session          as DynFlags+import           GHC.Hs.Binds import           GHC.HsToCore.Docs import           GHC.HsToCore.Expr import           GHC.HsToCore.Monad import           GHC.Iface.Load-import           GHC.Iface.Make               as GHC+import           GHC.Iface.Make              as GHC import           GHC.Iface.Recomp import           GHC.Iface.Syntax-import           GHC.Iface.Tidy               as GHC+import           GHC.Iface.Tidy              as GHC import           GHC.IfaceToCore import           GHC.Parser-import           GHC.Parser.Header            hiding (getImports)-import           GHC.Rename.Fixity            (lookupFixityRn)+import           GHC.Parser.Header           hiding (getImports)+import           GHC.Rename.Fixity           (lookupFixityRn) import           GHC.Rename.Names import           GHC.Rename.Splice-import qualified GHC.Runtime.Interpreter      as GHCi+import qualified GHC.Runtime.Interpreter     as GHCi import           GHC.Tc.Instance.Family import           GHC.Tc.Module import           GHC.Tc.Types-import           GHC.Tc.Types.Evidence        hiding ((<.>))+import           GHC.Tc.Types.Evidence       hiding ((<.>)) import           GHC.Tc.Utils.Env-import           GHC.Tc.Utils.Monad           hiding (Applicative (..), IORef,-                                               MonadFix (..), MonadIO (..),-                                               allM, anyM, concatMapM,-                                               mapMaybeM, (<$>))-import           GHC.Tc.Utils.TcType          as TcType-import qualified GHC.Types.Avail              as Avail+import           GHC.Tc.Utils.Monad          hiding (Applicative (..), IORef,+                                              MonadFix (..), MonadIO (..), allM,+                                              anyM, concatMapM, mapMaybeM, foldMapM,+                                              (<$>))+import           GHC.Tc.Utils.TcType         as TcType+import qualified GHC.Types.Avail             as Avail import           GHC.Types.Basic import           GHC.Types.Id-import           GHC.Types.Name               hiding (varName)+import           GHC.Types.Name              hiding (varName) import           GHC.Types.Name.Cache import           GHC.Types.Name.Env-import           GHC.Types.Name.Reader        hiding (GRE, gre_name, gre_imp, gre_lcl, gre_par)-import qualified GHC.Types.Name.Reader        as RdrName-import           GHC.Types.SrcLoc             (BufPos, BufSpan,-                                               SrcLoc (UnhelpfulLoc),-                                               SrcSpan (UnhelpfulSpan))-import qualified GHC.Types.SrcLoc             as SrcLoc+import           GHC.Types.Name.Reader       hiding (GRE, gre_imp, gre_lcl,+                                              gre_name, gre_par)+import qualified GHC.Types.Name.Reader       as RdrName+import           GHC.Types.SrcLoc            (BufPos, BufSpan,+                                              SrcLoc (UnhelpfulLoc),+                                              SrcSpan (UnhelpfulSpan))+import qualified GHC.Types.SrcLoc            as SrcLoc+import           GHC.Types.Unique.FM import           GHC.Types.Unique.Supply-import           GHC.Types.Var                (Var (varName), setTyVarUnique,-                                               setVarUnique)-import           GHC.Unit.Info                (PackageName (..))-import           GHC.Unit.Module              hiding (ModLocation (..), UnitId,-                                               moduleUnit,-                                               toUnitId)-import qualified GHC.Unit.Module              as Module-import           GHC.Unit.State               (ModuleOrigin (..))-import           GHC.Utils.Error              (Severity (..), emptyMessages)-import           GHC.Utils.Panic              hiding (try)-import qualified GHC.Utils.Panic.Plain        as Plain+import           GHC.Types.Var               (Var (varName), setTyVarUnique,+                                              setVarUnique) +import qualified GHC.Types.Var               as TypesVar+import           GHC.Unit.Info               (PackageName (..))+import           GHC.Unit.Module             hiding (ModLocation (..), UnitId,+                                              moduleUnit, toUnitId)+import qualified GHC.Unit.Module             as Module+import           GHC.Unit.State              (ModuleOrigin (..))+import           GHC.Utils.Error             (Severity (..), emptyMessages)+import           GHC.Utils.Panic             hiding (try)+import qualified GHC.Utils.Panic.Plain       as Plain -import           Data.Foldable (toList)-import           GHC.Data.Bag-import           GHC.Core.Multiplicity        (scaledThing)++import           Data.Foldable               (toList)+import           GHC.Core.Multiplicity       (scaledThing)+import qualified GHC.Data.Strict             as Strict+import qualified GHC.Driver.Config.Finder    as GHC+import qualified GHC.Driver.Config.Tidy      as GHC import           GHC.Driver.Env-import           GHC.Hs                       (HsModule (..), SrcSpanAnn')-import           GHC.Hs.Decls                 hiding (FunDep)+import           GHC.Driver.Env              as GHCi+import           GHC.Driver.Env.KnotVars+import           GHC.Driver.Errors.Types+import           GHC.Hs                      (HsModule (..))+import           GHC.Hs.Decls                hiding (FunDep) import           GHC.Hs.Doc import           GHC.Hs.Expr import           GHC.Hs.Extension import           GHC.Hs.ImpExp import           GHC.Hs.Pat import           GHC.Hs.Type-import           GHC.Hs.Utils                 hiding (collectHsBindsBinders)-import qualified GHC.Linker.Loader            as Linker+import           GHC.Hs.Utils                hiding (collectHsBindsBinders)+import qualified GHC.Linker.Loader           as Linker import           GHC.Linker.Types-import           GHC.Parser.Lexer             hiding (initParserState, getPsMessages)-import           GHC.Parser.Annotation        (EpAnn (..))+import           GHC.Parser.Annotation       (EpAnn (..))+import           GHC.Parser.Lexer            hiding (getPsMessages,+                                              initParserState) import           GHC.Platform.Ways-import           GHC.Runtime.Context          (InteractiveImport (..))-#if !MIN_VERSION_ghc(9,7,0)-import           GHC.Types.Avail              (greNamePrintableName)-#endif-import           GHC.Types.Fixity             (LexicalFixity (..), Fixity (..), defaultFixity)+import           GHC.Runtime.Context         (InteractiveImport (..))+import           GHC.Types.Fixity            (Fixity (..), LexicalFixity (..),+                                              defaultFixity) import           GHC.Types.Meta import           GHC.Types.Name.Set-import           GHC.Types.SourceFile         (HscSource (..))+import           GHC.Types.SourceFile        (HscSource (..)) import           GHC.Types.SourceText-import           GHC.Types.Target             (Target (..), TargetId (..))+import           GHC.Types.Target            (Target (..), TargetId (..)) import           GHC.Types.TyThing import           GHC.Types.TyThing.Ppr-import           GHC.Unit.Finder              hiding (mkHomeModLocation)+import           GHC.Types.Unique+import           GHC.Types.Unique.Map+import           GHC.Unit.Env+import           GHC.Unit.Finder             hiding (mkHomeModLocation)+import qualified GHC.Unit.Finder             as GHC+import           GHC.Unit.Finder.Types import           GHC.Unit.Home.ModInfo+#if MIN_VERSION_ghc(9,13,0)+import           GHC.Unit.Home.PackageTable  (addToHpt, addListToHpt)+#endif+import           GHC.Unit.Module.Graph import           GHC.Unit.Module.Imported import           GHC.Unit.Module.ModDetails import           GHC.Unit.Module.ModGuts-import           GHC.Unit.Module.ModIface     (IfaceExport, ModIface (..),-                                               ModIface_ (..), mi_fix)-import           GHC.Unit.Module.ModSummary   (ModSummary (..))-import           Language.Haskell.Syntax hiding (FunDep)+import           GHC.Unit.Module.ModIface    (IfaceExport, ModIface,+                                              ModIface_ (..), mi_fix+#if MIN_VERSION_ghc(9,11,0)+                                             , pattern ModIface+                                             , set_mi_top_env+#if !MIN_VERSION_ghc(9,13,0)+                                             , set_mi_usages+#endif+#endif+                                             )+import           GHC.Unit.Module.ModSummary  (ModSummary (..))+import           GHC.Utils.Error             (mkPlainErrorMsgEnvelope)+import           GHC.Utils.Panic+import           GHC.Utils.TmpFs+import           Language.Haskell.Syntax     hiding (FunDep) -#if !MIN_VERSION_ghc(9,3,0)-import           GHC.Types.SourceFile         (SourceModified(..))-import           GHC.Unit.Module.Graph        (mkModuleGraph)-import qualified GHC.Unit.Finder as GHC++-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if MIN_VERSION_ghc(9,11,0)+import System.OsPath #endif -#if MIN_VERSION_ghc(9,3,0)-import GHC.Driver.Env.KnotVars-import GHC.Unit.Module.Graph-import GHC.Driver.Errors.Types-import GHC.Types.Unique.Map-import GHC.Types.Unique-import GHC.Utils.TmpFs-import GHC.Utils.Panic-import GHC.Unit.Finder.Types-import GHC.Unit.Env-import qualified GHC.Driver.Config.Tidy       as GHC-import qualified GHC.Data.Strict              as Strict-import GHC.Driver.Env as GHCi-import qualified GHC.Unit.Finder as GHC-import qualified GHC.Driver.Config.Finder as GHC+#if MIN_VERSION_ghc(9,13,0)+import qualified System.FilePath as FP #endif +#if !MIN_VERSION_ghc(9,7,0)+import           GHC.Types.Avail             (greNamePrintableName)+#endif++#if !MIN_VERSION_ghc(9,9,0)+import           GHC.Hs                      (SrcSpanAnn')+#endif+ mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO Module.ModLocation-#if MIN_VERSION_ghc(9,3,0)-mkHomeModLocation df mn f = pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn f+#if MIN_VERSION_ghc(9,13,0)+mkHomeModLocation df mn f =+  let (basename, ext) = FP.splitExtension f+      osBasename = unsafeEncodeUtf basename+      osExt = unsafeEncodeUtf ext+      hscSrc = case ext of+        ".hs-boot" -> HsBootFile+        ".hsig" -> HsigFile+        _ -> HsSrcFile+  in pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn osBasename osExt hscSrc+#elif MIN_VERSION_ghc(9,11,0)+mkHomeModLocation df mn f =+  let osf = unsafeEncodeUtf f+  in pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn osf #else-mkHomeModLocation = GHC.mkHomeModLocation+mkHomeModLocation df mn f = pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn f #endif -#if MIN_VERSION_ghc(9,3,0) pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan-#else-pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan-#endif -#if MIN_VERSION_ghc(9,3,0) pattern RealSrcSpan x y <- SrcLoc.RealSrcSpan x ((\case Strict.Nothing -> Nothing; Strict.Just a -> Just a) -> y) where   RealSrcSpan x y = SrcLoc.RealSrcSpan x (case y of Nothing -> Strict.Nothing; Just a -> Strict.Just a) -#else-pattern RealSrcSpan x y = SrcLoc.RealSrcSpan x y-#endif {-# COMPLETE RealSrcSpan, UnhelpfulSpan #-} -#if MIN_VERSION_ghc(9,3,0) pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Strict.Maybe BufPos-> SrcLoc.SrcLoc-#else-pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Maybe BufPos-> SrcLoc.SrcLoc-#endif pattern RealSrcLoc x y = SrcLoc.RealSrcLoc x y {-# COMPLETE RealSrcLoc, UnhelpfulLoc #-} @@ -596,7 +599,7 @@ pattern AvailTC :: Name -> [Name] -> [FieldLabel] -> Avail.AvailInfo #if __GLASGOW_HASKELL__ >= 907 pattern AvailTC n names pieces <- Avail.AvailTC n ((,[]) -> (names,pieces))-#else +#else pattern AvailTC n names pieces <- Avail.AvailTC n ((\gres -> foldr (\gre (names, pieces) -> case gre of       Avail.NormalGreName name -> (name: names, pieces)       Avail.FieldGreName label -> (names, label:pieces)) ([], []) gres) -> (names, pieces))@@ -605,14 +608,14 @@ pattern AvailName :: Name -> Avail.AvailInfo #if __GLASGOW_HASKELL__ >= 907 pattern AvailName n <- Avail.Avail n-#else +#else pattern AvailName n <- Avail.Avail (Avail.NormalGreName n) #endif  pattern AvailFL :: FieldLabel -> Avail.AvailInfo #if __GLASGOW_HASKELL__ >= 907 pattern AvailFL fl <- (const Nothing -> Just fl) -- this pattern always fails as this field was removed in 9.7-#else +#else pattern AvailFL fl <- Avail.Avail (Avail.FieldGreName fl) #endif @@ -629,11 +632,11 @@ pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr #endif -pattern FunTy :: Type -> Type -> Type-pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res}---- type HasSrcSpan x a = (GenLocated SrcSpan a ~ x)--- type HasSrcSpan x = () :: Constraint+isVisibleFunArg :: Development.IDE.GHC.Compat.Core.FunTyFlag -> Bool+isVisibleFunArg = TypesVar.isVisibleFunArg+type FunTyFlag = TypesVar.FunTyFlag+pattern FunTy :: Development.IDE.GHC.Compat.Core.FunTyFlag -> Type -> Type -> Type+pattern FunTy af arg res <- TyCoRep.FunTy {ft_af = af, ft_arg = arg, ft_res = res}  class HasSrcSpan a where   getLoc :: a -> SrcSpan@@ -644,10 +647,22 @@ instance HasSrcSpan (SrcLoc.GenLocated SrcSpan a) where   getLoc = GHC.getLoc +#if MIN_VERSION_ghc(9,9,0)+instance HasSrcSpan (EpAnn a) where+  getLoc = GHC.getHasLoc+#endif++#if MIN_VERSION_ghc(9,9,0)+instance HasSrcSpan (SrcLoc.GenLocated (EpAnn ann) a) where+  getLoc (L l _) = getLoc l+instance HasSrcSpan (SrcLoc.GenLocated (GHC.EpaLocation) a) where+  getLoc = GHC.getHasLoc+#else instance HasSrcSpan (SrcSpanAnn' ann) where   getLoc = GHC.locA instance HasSrcSpan (SrcLoc.GenLocated (SrcSpanAnn' ann) a) where   getLoc (L l _) = l+#endif  pattern L :: HasSrcSpan a => SrcSpan -> e -> SrcLoc.GenLocated a e pattern L l a <- GHC.L (getLoc -> l) a@@ -655,9 +670,15 @@  -- This is from the old api, but it still simplifies pattern ConPatIn :: SrcLoc.Located (ConLikeP GhcPs) -> HsConPatDetails GhcPs -> Pat GhcPs+#if MIN_VERSION_ghc(9,9,0)+pattern ConPatIn con args <- ConPat _ (L _ (SrcLoc.noLoc -> con)) args+  where+    ConPatIn con args = ConPat GHC.noAnn (GHC.noLocA $ SrcLoc.unLoc con) args+#else pattern ConPatIn con args <- ConPat EpAnnNotUsed (L _ (SrcLoc.noLoc -> con)) args   where     ConPatIn con args = ConPat EpAnnNotUsed (GHC.noLocA $ SrcLoc.unLoc con) args+#endif  conPatDetails :: Pat p -> Maybe (HsConPatDetails p) conPatDetails (ConPat _ _ args) = Just args@@ -673,8 +694,16 @@     GHCi.initObjLinker (GHCi.hscInterp env)  loadDLL :: HscEnv -> String -> IO (Maybe String)-loadDLL env =-    GHCi.loadDLL (GHCi.hscInterp env)+loadDLL env str = do+    res <- GHCi.loadDLL (GHCi.hscInterp env) str+#if MIN_VERSION_ghc(9,11,0) || (MIN_VERSION_ghc(9, 8, 3) && !MIN_VERSION_ghc(9, 9, 0)) || (MIN_VERSION_ghc(9, 10, 2) && !MIN_VERSION_ghc(9, 11, 0))+    pure $+      case res of+        Left err_msg -> Just err_msg+        Right _      -> Nothing+#else+    pure res+#endif  unload :: HscEnv -> [Linkable] -> IO () unload hsc_env linkables =@@ -682,12 +711,6 @@     (GHCi.hscInterp hsc_env)     hsc_env linkables -#if !MIN_VERSION_ghc(9,3,0)-setOutputFile :: FilePath -> DynFlags -> DynFlags-setOutputFile f d = d {-  outputFile_    = Just f-  }-#endif  isSubspanOfA :: LocatedAn la a -> LocatedAn lb b -> Bool isSubspanOfA a b = SrcLoc.isSubspanOf (GHC.getLocA a) (GHC.getLocA b)@@ -708,7 +731,7 @@ #endif     ,gre_par, gre_lcl, gre_imp = (toList -> gre_imp)} -collectHsBindsBinders :: CollectPass p => Bag (XRec p (HsBindLR p idR)) -> [IdP p]+collectHsBindsBinders :: CollectPass p => LHsBindsLR p idR -> [IdP p] collectHsBindsBinders x = GHC.collectHsBindsBinders CollNoDictBinders x  @@ -716,92 +739,32 @@ makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails makeSimpleDetails hsc_env =   GHC.makeSimpleDetails-#if MIN_VERSION_ghc(9,3,0)               (hsc_logger hsc_env)-#else-              hsc_env-#endif -mkIfaceTc hsc_env sf details _ms tcGblEnv = -- ms is only used in GHC >= 9.4-  GHC.mkIfaceTc hsc_env sf details-#if MIN_VERSION_ghc(9,3,0)-              _ms-#endif-              tcGblEnv+mkIfaceTc :: HscEnv -> GHC.SafeHaskellMode -> ModDetails -> ModSummary -> Maybe CoreProgram -> TcGblEnv -> IO ModIface+mkIfaceTc hscEnv shm md _ms _mcp =+  GHC.mkIfaceTc hscEnv shm md _ms _mcp -- mcp::Maybe CoreProgram is only used in GHC >= 9.6  mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails mkBootModDetailsTc session = GHC.mkBootModDetailsTc-#if MIN_VERSION_ghc(9,3,0)           (hsc_logger session)-#else-          session-#endif -#if !MIN_VERSION_ghc(9,3,0)-type TidyOpts = HscEnv-#endif  initTidyOpts :: HscEnv -> IO TidyOpts initTidyOpts =-#if MIN_VERSION_ghc(9,3,0)   GHC.initTidyOpts-#else-  pure-#endif -driverNoStop =-#if MIN_VERSION_ghc(9,3,0)-                                         NoStop-#else-                                         StopLn-#endif--#if !MIN_VERSION_ghc(9,3,0)-hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv-hscUpdateHPT k session = session { hsc_HPT = k (hsc_HPT session) }-#endif--#if !MIN_VERSION_ghc(9,4,0)-pattern HsFieldBind :: XHsRecField id -> id -> arg -> Bool -> HsRecField' id arg-pattern HsFieldBind {hfbAnn, hfbLHS, hfbRHS, hfbPun} <- HsRecField hfbAnn (SrcLoc.unLoc -> hfbLHS) hfbRHS hfbPun where-  HsFieldBind ann lhs rhs pun = HsRecField ann (SrcLoc.noLoc lhs) rhs pun-#endif--#if !MIN_VERSION_ghc_boot_th(9,4,1)-pattern NamedFieldPuns :: Extension-pattern NamedFieldPuns = RecordPuns-#endif+driverNoStop :: StopPhase+driverNoStop = NoStop -#if MIN_VERSION_ghc(9,5,0)-mkVisFunTys = mkScaledFunctionTys+groupOrigin :: MatchGroup GhcRn body -> Origin mapLoc :: (a -> b) -> SrcLoc.GenLocated l a -> SrcLoc.GenLocated l b mapLoc = fmap groupOrigin = mg_ext-#else-mapLoc :: (a -> b) -> SrcLoc.GenLocated l a -> SrcLoc.GenLocated l b-mapLoc = SrcLoc.mapLoc-groupOrigin :: MatchGroup p body -> Origin-groupOrigin = mg_origin-#endif --#if !MIN_VERSION_ghc(9,5,0)-mkCgInteractiveGuts :: CgGuts -> CgGuts-mkCgInteractiveGuts = id--emptyHomeModInfoLinkable :: Maybe Linkable-emptyHomeModInfoLinkable = Nothing--justBytecode :: Linkable -> Maybe Linkable-justBytecode = Just--justObjects :: Linkable -> Maybe Linkable-justObjects = Just--homeModInfoByteCode, homeModInfoObject :: HomeModInfo -> Maybe Linkable-homeModInfoByteCode = hm_linkable-homeModInfoObject = hm_linkable+mkSimpleTarget :: DynFlags -> FilePath -> Target+mkSimpleTarget df fp = Target (TargetFile fp Nothing) True (homeUnitId_ df) Nothing -field_label :: a -> a-field_label = id+#if MIN_VERSION_ghc(9,7,0)+lookupGlobalRdrEnv gre_env occ = lookupGRE gre_env (LookupOccName occ AllRelevantGREs) #endif
+ src/Development/IDE/GHC/Compat/Driver.hs view
@@ -0,0 +1,142 @@+-- ============================================================================+-- DO NOT EDIT+-- This module copies parts of the driver code in GHC.Driver.Main to provide+-- `hscTypecheckRenameWithDiagnostics`.+-- Issue to add this function: https://gitlab.haskell.org/ghc/ghc/-/issues/24996+-- MR to add this function: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12891+-- ============================================================================++{-# LANGUAGE CPP #-}++module Development.IDE.GHC.Compat.Driver+    ( hscTypecheckRenameWithDiagnostics+    ) where++#if MIN_VERSION_ghc(9,11,0)++import           GHC.Driver.Main            (hscTypecheckRenameWithDiagnostics)++#else++import           Control.Monad+import           GHC.Core+import           GHC.Data.FastString+import           GHC.Data.Maybe+import           GHC.Driver.Env+import           GHC.Driver.Errors.Types+import           GHC.Driver.Main+import           GHC.Driver.Session+import           GHC.Hs+import           GHC.Hs.Dump+import           GHC.Iface.Ext.Ast          (mkHieFile)+import           GHC.Iface.Ext.Binary       (hie_file_result, readHieFile,+                                             writeHieFile)+import           GHC.Iface.Ext.Debug        (diffFile, validateScopes)+import           GHC.Iface.Ext.Types        (getAsts, hie_asts, hie_module)+import           GHC.Tc.Module+import           GHC.Tc.Utils.Monad+import           GHC.Types.SourceFile+import           GHC.Types.SrcLoc+import           GHC.Unit+import           GHC.Unit.Module.ModDetails+import           GHC.Unit.Module.ModIface+import           GHC.Unit.Module.ModSummary+import           GHC.Utils.Error+import           GHC.Utils.Logger+import           GHC.Utils.Outputable+import           GHC.Utils.Panic.Plain++hscTypecheckRenameWithDiagnostics :: HscEnv -> ModSummary -> HsParsedModule+                   -> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage)+hscTypecheckRenameWithDiagnostics hsc_env mod_summary rdr_module =+    runHsc' hsc_env $ hsc_typecheck True mod_summary (Just rdr_module)++-- ============================================================================+-- DO NOT EDIT - Refer to top of file+-- ============================================================================+hsc_typecheck :: Bool -- ^ Keep renamed source?+              -> ModSummary -> Maybe HsParsedModule+              -> Hsc (TcGblEnv, RenamedStuff)+hsc_typecheck keep_rn mod_summary mb_rdr_module = do+    hsc_env <- getHscEnv+    let hsc_src = ms_hsc_src mod_summary+        dflags = hsc_dflags hsc_env+        home_unit = hsc_home_unit hsc_env+        outer_mod = ms_mod mod_summary+        mod_name = moduleName outer_mod+        outer_mod' = mkHomeModule home_unit mod_name+        inner_mod = homeModuleNameInstantiation home_unit mod_name+        src_filename  = ms_hspp_file mod_summary+        real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1+        keep_rn' = gopt Opt_WriteHie dflags || keep_rn+    massert (isHomeModule home_unit outer_mod)+    tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)+        then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc+        else+         do hpm <- case mb_rdr_module of+                    Just hpm -> return hpm+                    Nothing  -> hscParse' mod_summary+            tc_result0 <- tcRnModule' mod_summary keep_rn' hpm+            if hsc_src == HsigFile+                then+                     do (iface, _) <- liftIO $ hscSimpleIface hsc_env Nothing tc_result0 mod_summary+                        ioMsgMaybe $ hoistTcRnMessage $+                            tcRnMergeSignatures hsc_env hpm tc_result0 iface+                else return tc_result0+    rn_info <- extract_renamed_stuff mod_summary tc_result+    return (tc_result, rn_info)++-- ============================================================================+-- DO NOT EDIT - Refer to top of file+-- ============================================================================+extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff+extract_renamed_stuff mod_summary tc_result = do+    let rn_info = getRenamedStuff tc_result++    dflags <- getDynFlags+    logger <- getLogger+    liftIO $ putDumpFileMaybe logger Opt_D_dump_rn_ast "Renamer"+                FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info)++    -- Create HIE files+    when (gopt Opt_WriteHie dflags) $ do+        -- I assume this fromJust is safe because `-fwrite-hie-file`+        -- enables the option which keeps the renamed source.+        hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)+        let out_file = ml_hie_file $ ms_location mod_summary+        liftIO $ writeHieFile out_file hieFile+        liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)++        -- Validate HIE files+        when (gopt Opt_ValidateHie dflags) $ do+            hs_env <- Hsc $ \e w -> return (e, w)+            liftIO $ do+              -- Validate Scopes+              case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of+                  [] -> putMsg logger $ text "Got valid scopes"+                  xs -> do+                    putMsg logger $ text "Got invalid scopes"+                    mapM_ (putMsg logger) xs+              -- Roundtrip testing+              file' <- readHieFile (hsc_NC hs_env) out_file+              case diffFile hieFile (hie_file_result file') of+                [] ->+                  putMsg logger $ text "Got no roundtrip errors"+                xs -> do+                  putMsg logger $ text "Got roundtrip errors"+                  let logger' = updateLogFlags logger (log_set_dopt Opt_D_ppr_debug)+                  mapM_ (putMsg logger') xs+    return rn_info++-- ============================================================================+-- DO NOT EDIT - Refer to top of file+-- ============================================================================+hscSimpleIface :: HscEnv+               -> Maybe CoreProgram+               -> TcGblEnv+               -> ModSummary+               -> IO (ModIface, ModDetails)+hscSimpleIface hsc_env mb_core_program tc_result summary+    = runHsc hsc_env $ hscSimpleIface' mb_core_program tc_result summary++#endif
src/Development/IDE/GHC/Compat/Env.hs view
@@ -3,13 +3,10 @@ -- | Compat module for the main Driver types, such as 'HscEnv', -- 'UnitEnv' and some DynFlags compat functions. module Development.IDE.GHC.Compat.Env (-    Env.HscEnv(hsc_FC, hsc_NC, hsc_IC, hsc_mod_graph-#if MIN_VERSION_ghc(9,3,0)+    Env.HscEnv(hsc_FC, hsc_NC, hsc_IC               , hsc_type_env_vars-#else-              , hsc_type_env_var-#endif               ),+    Env.hsc_mod_graph,     Env.hsc_HPT,     InteractiveContext(..),     setInteractivePrintName,@@ -29,7 +26,7 @@     Home.mkHomeModule,     -- * Provide backwards Compatible     -- types and helper functions.-    Logger(..),+    Logger,     UnitEnv,     hscSetUnitEnv,     hscSetFlags,@@ -52,13 +49,16 @@     setBackend,     ghciBackend,     Development.IDE.GHC.Compat.Env.platformDefaultBackend,+    workingDirectory,+    setWorkingDirectory,+    hscSetActiveUnitId,+    reexportedModules,     ) where  import           GHC                 (setInteractiveDynFlags) --- See Note [Guidelines For Using CPP In GHCIDE Import Statements]- import           GHC.Driver.Backend  as Backend+import           GHC.Driver.Env      (HscEnv, hscSetActiveUnitId) import qualified GHC.Driver.Env      as Env import           GHC.Driver.Hooks    (Hooks) import           GHC.Driver.Session@@ -71,19 +71,12 @@ import           GHC.Utils.Logger import           GHC.Utils.TmpFs -#if !MIN_VERSION_ghc(9,3,0)-import           GHC.Driver.Env      (HscEnv, hsc_EPS)-#endif -#if MIN_VERSION_ghc(9,3,0)-import           GHC.Driver.Env      (HscEnv)-#endif--#if MIN_VERSION_ghc(9,3,0) hsc_EPS :: HscEnv -> UnitEnv hsc_EPS = Env.hsc_unit_env-#endif +setWorkingDirectory :: FilePath -> DynFlags -> DynFlags+setWorkingDirectory p d = d { workingDirectory =  Just p }  setHomeUnitId_ :: UnitId -> DynFlags -> DynFlags setHomeUnitId_ uid df = df { Session.homeUnitId_ = uid }@@ -113,22 +106,14 @@ setBytecodeLinkerOptions :: DynFlags -> DynFlags setBytecodeLinkerOptions df = df {     ghcLink   = LinkInMemory-#if MIN_VERSION_ghc(9,5,0)   , backend = noBackend-#else-  , backend = NoBackend-#endif   , ghcMode = CompManager     }  setInterpreterLinkerOptions :: DynFlags -> DynFlags setInterpreterLinkerOptions df = df {     ghcLink   = LinkInMemory-#if MIN_VERSION_ghc(9,5,0)    , backend = interpreterBackend-#else-  , backend = Interpreter-#endif   , ghcMode = CompManager     }
+ src/Development/IDE/GHC/Compat/Error.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE TemplateHaskell #-}+module Development.IDE.GHC.Compat.Error (+  -- * Top-level error types and lens for easy access+  MsgEnvelope(..),+  msgEnvelopeErrorL,+  GhcMessage(..),+  -- * Error messages for the typechecking and renamer phase+  TcRnMessage (..),+  TcRnMessageDetailed (..),+  Hole(..),+  stripTcRnMessageContext,+  -- * Parsing error message+  PsMessage(..),+  -- * Desugaring diagnostic+  DsMessage (..),+  -- * Driver error message+  DriverMessage (..),+  -- * General Diagnostics+  Diagnostic(..),+  -- * GHC Hints+  GhcHint (SuggestExtension),+  LanguageExtensionHint (..),+  -- * Prisms and lenses for error selection+  _TcRnMessage,+  _TcRnMessageWithCtx,+  _GhcPsMessage,+  _GhcDsMessage,+  _GhcDriverMessage,+  _ReportHoleError,+  _TcRnIllegalWildcardInType,+  _TcRnPartialTypeSignatures,+  _TcRnMissingSignature,+  _TcRnSolverReport,+  _TcRnMessageWithInfo,+  _TypeHole,+  _ConstraintHole,+  reportContextL,+  reportContentL,+  _MismatchMessage,+  _TypeEqMismatchActual,+  _TypeEqMismatchExpected,+  ) where++import           Control.Lens+import           Development.IDE.GHC.Compat (Type)+import           GHC.Driver.Errors.Types+import           GHC.HsToCore.Errors.Types+import           GHC.Tc.Errors.Types+import           GHC.Tc.Types.Constraint    (Hole (..), HoleSort)+import           GHC.Types.Error++-- | Some 'TcRnMessage's are nested in other constructors for additional context.+-- For example, 'TcRnWithHsDocContext' and 'TcRnMessageWithInfo'.+-- However, in most occasions you don't need the additional context and you just want+-- the error message. @'_TcRnMessage'@ recursively unwraps these constructors,+-- until there are no more constructors with additional context.+--+-- Use @'_TcRnMessageWithCtx'@ if you need the additional context. You can always+-- strip it later using @'stripTcRnMessageContext'@.+--+_TcRnMessage :: Fold GhcMessage TcRnMessage+_TcRnMessage = _TcRnMessageWithCtx . to stripTcRnMessageContext++_TcRnMessageWithCtx :: Prism' GhcMessage TcRnMessage+_TcRnMessageWithCtx = prism' GhcTcRnMessage (\case+  GhcTcRnMessage tcRnMsg -> Just tcRnMsg+  _ -> Nothing)++_GhcPsMessage :: Prism' GhcMessage PsMessage+_GhcPsMessage = prism' GhcPsMessage (\case+  GhcPsMessage psMsg -> Just psMsg+  _ -> Nothing)++_GhcDsMessage :: Prism' GhcMessage DsMessage+_GhcDsMessage = prism' GhcDsMessage (\case+  GhcDsMessage dsMsg -> Just dsMsg+  _ -> Nothing)++_GhcDriverMessage :: Prism' GhcMessage DriverMessage+_GhcDriverMessage = prism' GhcDriverMessage (\case+  GhcDriverMessage driverMsg -> Just driverMsg+  _ -> Nothing)++-- | Some 'TcRnMessage's are nested in other constructors for additional context.+-- For example, 'TcRnWithHsDocContext' and 'TcRnMessageWithInfo'.+-- However, in some occasions you don't need the additional context and you just want+-- the error message. @'stripTcRnMessageContext'@ recursively unwraps these constructors,+-- until there are no more constructors with additional context.+--+stripTcRnMessageContext :: TcRnMessage -> TcRnMessage+stripTcRnMessageContext = \case+#if MIN_VERSION_ghc(9, 6, 1)+  TcRnWithHsDocContext _ tcMsg -> stripTcRnMessageContext tcMsg+#endif+  TcRnMessageWithInfo _ (TcRnMessageDetailed _ tcMsg) -> stripTcRnMessageContext tcMsg+  msg -> msg++msgEnvelopeErrorL :: Lens' (MsgEnvelope e) e+msgEnvelopeErrorL = lens errMsgDiagnostic (\envelope e -> envelope { errMsgDiagnostic = e } )++makePrisms ''TcRnMessage++makeLensesWith+    (lensRules & lensField .~ mappingNamer (pure . (++ "L")))+    ''SolverReportWithCtxt++makePrisms ''TcSolverReportMsg++makePrisms ''HoleSort++-- | Focus 'MismatchMsg' from 'TcSolverReportMsg'. Currently, 'MismatchMsg' can be+-- extracted from 'CannotUnifyVariable' and 'Mismatch' constructors.+_MismatchMessage :: Traversal' TcSolverReportMsg MismatchMsg+_MismatchMessage focus (Mismatch msg t a c) = (\msg' -> Mismatch msg' t a c) <$> focus msg+_MismatchMessage focus (CannotUnifyVariable msg a) = flip CannotUnifyVariable a <$> focus msg+_MismatchMessage _ report = pure report++-- | Focus 'teq_mismatch_expected' from 'TypeEqMismatch'.+_TypeEqMismatchExpected :: Traversal' MismatchMsg Type+#if MIN_VERSION_ghc(9,10,2)+_TypeEqMismatchExpected focus mismatch@(TypeEqMismatch _ _ _ expected _ _ _) =+    (\expected' -> mismatch { teq_mismatch_expected = expected' }) <$> focus expected+#else+_TypeEqMismatchExpected focus mismatch@(TypeEqMismatch _ _ _ _ expected _ _ _) =+    (\expected' -> mismatch { teq_mismatch_expected = expected' }) <$> focus expected+#endif+_TypeEqMismatchExpected _ mismatch = pure mismatch++-- | Focus 'teq_mismatch_actual' from 'TypeEqMismatch'.+_TypeEqMismatchActual :: Traversal' MismatchMsg Type+#if MIN_VERSION_ghc(9,10,2)+_TypeEqMismatchActual focus mismatch@(TypeEqMismatch _ _ _ _ actual _ _) =+    (\actual' -> mismatch { teq_mismatch_actual = actual' }) <$> focus actual+#else+_TypeEqMismatchActual focus mismatch@(TypeEqMismatch _ _ _ _ _ actual _ _) =+    (\actual' -> mismatch { teq_mismatch_expected = actual' }) <$> focus actual+#endif+_TypeEqMismatchActual _ mismatch = pure mismatch
src/Development/IDE/GHC/Compat/Iface.hs view
@@ -9,6 +9,9 @@ import           Development.IDE.GHC.Compat.Env import           Development.IDE.GHC.Compat.Outputable import           GHC+import           GHC.Driver.Session                    (targetProfile)+import qualified GHC.Iface.Load                        as Iface+import           GHC.Unit.Finder.Types                 (FindResult)  -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] @@ -17,19 +20,11 @@ import           GHC.Iface.Errors.Types                (IfaceMessage) #endif --import qualified GHC.Iface.Load                        as Iface-import           GHC.Unit.Finder.Types                 (FindResult)--#if MIN_VERSION_ghc(9,3,0)-import           GHC.Driver.Session                    (targetProfile)-#endif- writeIfaceFile :: HscEnv -> FilePath -> ModIface -> IO ()-#if MIN_VERSION_ghc(9,3,0)-writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (targetProfile $ hsc_dflags env) fp iface+#if MIN_VERSION_ghc(9,11,0)+writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (targetProfile $ hsc_dflags env) (Iface.flagsToIfCompression $ hsc_dflags env) fp iface #else-writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (hsc_dflags env) fp iface+writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (targetProfile $ hsc_dflags env) fp iface #endif  cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc
src/Development/IDE/GHC/Compat/Logger.hs view
@@ -13,39 +13,23 @@ import           Development.IDE.GHC.Compat.Env        as Env import           Development.IDE.GHC.Compat.Outputable --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -import           GHC.Utils.Outputable--import           GHC.Utils.Logger                      as Logger--#if MIN_VERSION_ghc(9,3,0) import           GHC.Types.Error-#endif+import           GHC.Utils.Logger                      as Logger+import           GHC.Utils.Outputable  putLogHook :: Logger -> HscEnv -> HscEnv putLogHook logger env =   env { hsc_logger = logger } -#if MIN_VERSION_ghc(9,3,0) type LogActionCompat = LogFlags -> Maybe DiagnosticReason -> Maybe Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO ()  -- alwaysQualify seems to still do the right thing here, according to the "unqualified warnings" test. logActionCompat :: LogActionCompat -> LogAction #if MIN_VERSION_ghc(9,7,0) logActionCompat logAction logFlags (MCDiagnostic severity (ResolvedDiagnosticReason wr) _) loc = logAction logFlags (Just wr) (Just severity) loc alwaysQualify-#elif MIN_VERSION_ghc(9,5,0)-logActionCompat logAction logFlags (MCDiagnostic severity wr _) loc = logAction logFlags (Just wr) (Just severity) loc alwaysQualify #else-logActionCompat logAction logFlags (MCDiagnostic severity wr) loc = logAction logFlags (Just wr) (Just severity) loc alwaysQualify+logActionCompat logAction logFlags (MCDiagnostic severity wr _) loc = logAction logFlags (Just wr) (Just severity) loc alwaysQualify #endif logActionCompat logAction logFlags _cls loc = logAction logFlags Nothing Nothing loc alwaysQualify -#else-type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO ()---- alwaysQualify seems to still do the right thing here, according to the "unqualified warnings" test.-logActionCompat :: LogActionCompat -> LogAction-logActionCompat logAction dynFlags wr severity loc = logAction dynFlags wr severity loc alwaysQualify--#endif
src/Development/IDE/GHC/Compat/Outputable.hs view
@@ -9,35 +9,30 @@     ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest, punctuate,     printSDocQualifiedUnsafe,     printWithoutUniques,+    printWithoutUniquesOneLine,     mkPrintUnqualifiedDefault,-    PrintUnqualified(..),+    PrintUnqualified,     defaultUserStyle,     withPprStyle,     -- * Parser errors     PsWarning,     PsError,-#if MIN_VERSION_ghc(9,5,0)     defaultDiagnosticOpts,     GhcMessage,     DriverMessage,     Messages,     initDiagOpts,     pprMessages,-#endif-#if MIN_VERSION_ghc(9,3,0)     DiagnosticReason(..),     renderDiagnosticMessageWithHints,     pprMsgEnvelopeBagWithLoc,     Error.getMessages,     renderWithContext,+    showSDocOneLine,     defaultSDocContext,     errMsgDiagnostic,     unDecorated,     diagnosticMessage,-#else-    pprWarning,-    pprError,-#endif     -- * Error infrastructure     DecoratedSDoc,     MsgEnvelope,@@ -53,51 +48,44 @@     textDoc,     ) where --- See Note [Guidelines For Using CPP In GHCIDE Import Statements]--+import           Data.Maybe+import           GHC.Driver.Config.Diagnostic import           GHC.Driver.Env+import           GHC.Driver.Errors.Types      (DriverMessage, GhcMessage) import           GHC.Driver.Ppr import           GHC.Driver.Session+import           GHC.Parser.Errors.Types import qualified GHC.Types.Error              as Error-#if MIN_VERSION_ghc(9,7,0)-import           GHC.Types.Error              (defaultDiagnosticOpts)-#endif import           GHC.Types.Name.Ppr import           GHC.Types.Name.Reader import           GHC.Types.SourceError import           GHC.Types.SrcLoc import           GHC.Unit.State-import           GHC.Utils.Error              hiding (mkWarnMsg)+import           GHC.Utils.Error import           GHC.Utils.Outputable         as Out import           GHC.Utils.Panic -#if !MIN_VERSION_ghc(9,3,0)-import           GHC.Parser.Errors-import qualified GHC.Parser.Errors.Ppr        as Ppr-#endif--#if MIN_VERSION_ghc(9,3,0)-import           Data.Maybe-import           GHC.Driver.Config.Diagnostic-import           GHC.Parser.Errors.Types-#endif+-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if MIN_VERSION_ghc(9,5,0)-import           GHC.Driver.Errors.Types      (DriverMessage, GhcMessage)+#if MIN_VERSION_ghc(9,7,0)+import           GHC.Types.Error              (defaultDiagnosticOpts) #endif -#if MIN_VERSION_ghc(9,5,0) type PrintUnqualified = NamePprCtx-#endif  -- | A compatible function to print `Outputable` instances -- without unique symbols. -- -- It print with a user-friendly style like: `a_a4ME` as `a`. printWithoutUniques :: Outputable a => a -> String-printWithoutUniques =-  renderWithContext (defaultSDocContext+printWithoutUniques = printWithoutUniques' renderWithContext++printWithoutUniquesOneLine :: Outputable a => a -> String+printWithoutUniquesOneLine = printWithoutUniques' showSDocOneLine++printWithoutUniques' :: Outputable a => (SDocContext -> SDoc -> String) -> a -> String+printWithoutUniques' showSDoc =+  showSDoc (defaultSDocContext     {       sdocStyle = defaultUserStyle     , sdocSuppressUniques = True@@ -113,75 +101,41 @@     doc' = pprWithUnitState emptyUnitState doc  -#if !MIN_VERSION_ghc(9,3,0)-pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc-pprWarning =-  Ppr.pprWarning -pprError :: PsError -> MsgEnvelope DecoratedSDoc-pprError =-  Ppr.pprError-#endif- formatErrorWithQual :: DynFlags -> MsgEnvelope DecoratedSDoc -> String formatErrorWithQual dflags e =   showSDoc dflags (pprNoLocMsgEnvelope e) -#if MIN_VERSION_ghc(9,3,0) pprNoLocMsgEnvelope :: MsgEnvelope DecoratedSDoc -> SDoc-#else-pprNoLocMsgEnvelope :: Error.RenderableDiagnostic e => MsgEnvelope e -> SDoc-#endif pprNoLocMsgEnvelope (MsgEnvelope { errMsgDiagnostic = e                                  , errMsgContext   = unqual })   = sdocWithContext $ \_ctx ->     withErrStyle unqual $ #if MIN_VERSION_ghc(9,7,0)-      (formatBulleted e)-#elif MIN_VERSION_ghc(9,3,0)-      (formatBulleted _ctx $ e)+      formatBulleted e #else-      (formatBulleted _ctx $ Error.renderDiagnostic e)+      formatBulleted _ctx e #endif   -type ErrMsg  = MsgEnvelope DecoratedSDoc-#if MIN_VERSION_ghc(9,3,0)-type WarnMsg  = MsgEnvelope DecoratedSDoc-#endif+type ErrMsg  = MsgEnvelope GhcMessage+type WarnMsg  = MsgEnvelope GhcMessage  mkPrintUnqualifiedDefault :: HscEnv -> GlobalRdrEnv -> PrintUnqualified-#if MIN_VERSION_ghc(9,5,0) mkPrintUnqualifiedDefault env =   mkNamePprCtx ptc (hsc_unit_env env)     where       ptc = initPromotionTickContext (hsc_dflags env)-#else-mkPrintUnqualifiedDefault env =-  -- GHC 9.2 version-  -- mkPrintUnqualified :: UnitEnv -> GlobalRdrEnv -> PrintUnqualified-  mkPrintUnqualified (hsc_unit_env env)-#endif -#if MIN_VERSION_ghc(9,3,0) renderDiagnosticMessageWithHints :: forall a. Diagnostic a => a -> DecoratedSDoc renderDiagnosticMessageWithHints a = Error.unionDecoratedSDoc   (diagnosticMessage-#if MIN_VERSION_ghc(9,5,0)     (defaultDiagnosticOpts @a)-#endif     a) (mkDecorated $ map ppr $ diagnosticHints a)-#endif -#if MIN_VERSION_ghc(9,3,0) mkWarnMsg :: DynFlags -> Maybe DiagnosticReason -> b -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc mkWarnMsg df reason _logFlags l st doc = fmap renderDiagnosticMessageWithHints $ mkMsgEnvelope (initDiagOpts df) l st (mkPlainDiagnostic (fromMaybe WarningWithoutFlag reason) [] doc)-#else-mkWarnMsg :: a -> b -> DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc-mkWarnMsg _ _ =-  const Error.mkWarnMsg-#endif  textDoc :: String -> SDoc textDoc = text
src/Development/IDE/GHC/Compat/Parser.hs view
@@ -1,36 +1,30 @@ {-# LANGUAGE CPP             #-} {-# LANGUAGE PatternSynonyms #-}-{-# HLINT ignore "Unused LANGUAGE pragma" #-}  -- | Parser compatibility module. module Development.IDE.GHC.Compat.Parser (     initParserOpts,     initParserState,-    ApiAnns,     PsSpan(..),     pattern HsParsedModule,     type GHC.HsParsedModule,     Development.IDE.GHC.Compat.Parser.hpm_module,     Development.IDE.GHC.Compat.Parser.hpm_src_files,-    Development.IDE.GHC.Compat.Parser.hpm_annotations,     pattern ParsedModule,     Development.IDE.GHC.Compat.Parser.pm_parsed_source,     type GHC.ParsedModule,     Development.IDE.GHC.Compat.Parser.pm_mod_summary,     Development.IDE.GHC.Compat.Parser.pm_extra_src_files,-    Development.IDE.GHC.Compat.Parser.pm_annotations,-    mkApiAnns,     -- * API Annotations+#if !MIN_VERSION_ghc(9,11,0)     Anno.AnnKeywordId(..),+#endif     pattern EpaLineComment,     pattern EpaBlockComment     ) where  import           Development.IDE.GHC.Compat.Core import           Development.IDE.GHC.Compat.Util---- See Note [Guidelines For Using CPP In GHCIDE Import Statements]- import qualified GHC.Parser.Annotation           as Anno import qualified GHC.Parser.Lexer                as Lexer import           GHC.Types.SrcLoc                (PsSpan (..))@@ -42,15 +36,8 @@                                                   pm_mod_summary,                                                   pm_parsed_source) import qualified GHC-import           GHC.Hs                          (hpm_module, hpm_src_files)--#if !MIN_VERSION_ghc(9,3,0)-import qualified GHC.Driver.Config               as Config-#endif--#if MIN_VERSION_ghc(9,3,0) import qualified GHC.Driver.Config.Parser        as Config-#endif+import           GHC.Hs                          (hpm_module, hpm_src_files)   @@ -62,34 +49,24 @@ initParserState =   Lexer.initParserState --- GHC 9.2 does not have ApiAnns anymore packaged in ParsedModule. Now the--- annotations are found in the ast.-type ApiAnns = ()--#if MIN_VERSION_ghc(9,5,0)-pattern HsParsedModule :: Located (HsModule GhcPs) -> [FilePath] -> ApiAnns -> GHC.HsParsedModule-#else-pattern HsParsedModule :: Located HsModule -> [FilePath] -> ApiAnns -> GHC.HsParsedModule-#endif+pattern HsParsedModule :: Located (HsModule GhcPs) -> [FilePath] -> GHC.HsParsedModule pattern HsParsedModule     { hpm_module     , hpm_src_files-    , hpm_annotations-    } <- ( (,()) -> (GHC.HsParsedModule{..}, hpm_annotations))+    } <- GHC.HsParsedModule{..}     where-        HsParsedModule hpm_module hpm_src_files _hpm_annotations =+        HsParsedModule hpm_module hpm_src_files =             GHC.HsParsedModule hpm_module hpm_src_files  -pattern ParsedModule :: ModSummary -> ParsedSource -> [FilePath] -> ApiAnns -> GHC.ParsedModule+pattern ParsedModule :: ModSummary -> ParsedSource -> [FilePath] -> GHC.ParsedModule pattern ParsedModule     { pm_mod_summary     , pm_parsed_source     , pm_extra_src_files-    , pm_annotations-    } <- ( (,()) -> (GHC.ParsedModule{..}, pm_annotations))+    } <- GHC.ParsedModule{..}     where-        ParsedModule ms parsed extra_src_files _anns =+        ParsedModule ms parsed extra_src_files =             GHC.ParsedModule              { pm_mod_summary = ms              , pm_parsed_source = parsed@@ -97,6 +74,4 @@              } {-# COMPLETE ParsedModule :: GHC.ParsedModule #-} -mkApiAnns :: PState -> ApiAnns-mkApiAnns = const ()
src/Development/IDE/GHC/Compat/Plugins.hs view
@@ -7,8 +7,6 @@     defaultPlugin,     PluginWithArgs(..),     applyPluginsParsedResultAction,-    initializePlugins,-    initPlugins,      -- * Static plugins     StaticPlugin(..),@@ -20,89 +18,32 @@     ) where  import           Development.IDE.GHC.Compat.Core-import           Development.IDE.GHC.Compat.Env        (hscSetFlags, hsc_dflags)-import           Development.IDE.GHC.Compat.Parser     as Parser---- See Note [Guidelines For Using CPP In GHCIDE Import Statements]--import           GHC.Driver.Plugins                    (Plugin (..),-                                                        PluginWithArgs (..),-                                                        StaticPlugin (..),-                                                        defaultPlugin,-                                                        withPlugins)-import qualified GHC.Runtime.Loader                    as Loader--#if !MIN_VERSION_ghc(9,3,0)-import           Development.IDE.GHC.Compat.Outputable as Out-#endif--import qualified GHC.Driver.Env                        as Env--#if !MIN_VERSION_ghc(9,3,0)-import           Data.Bifunctor                        (bimap)-#endif--#if !MIN_VERSION_ghc(9,3,0)-import           Development.IDE.GHC.Compat.Util       (Bag)-#endif+import           Development.IDE.GHC.Compat.Parser as Parser -#if MIN_VERSION_ghc(9,3,0)-import           GHC.Driver.Plugins                    (ParsedResult (..),-                                                        PsMessages (..),-                                                        staticPlugins)-import qualified GHC.Parser.Lexer                      as Lexer-#endif+import qualified GHC.Driver.Env                    as Env+import           GHC.Driver.Plugins                (ParsedResult (..),+                                                    Plugin (..),+                                                    PluginWithArgs (..),+                                                    PsMessages (..),+                                                    StaticPlugin (..),+                                                    defaultPlugin,+                                                    staticPlugins, withPlugins)+import qualified GHC.Parser.Lexer                  as Lexer  -#if !MIN_VERSION_ghc(9,3,0)-type PsMessages = (Bag WarnMsg, Bag ErrMsg)-#endif--getPsMessages :: PState -> DynFlags -> PsMessages-getPsMessages pst _dflags = --dfags is only used if GHC < 9.2-#if MIN_VERSION_ghc(9,3,0)+getPsMessages :: PState -> PsMessages+getPsMessages pst =   uncurry PsMessages $ Lexer.getPsMessages pst-#else-                 bimap (fmap pprWarning) (fmap pprError) $-                 getMessages pst-#endif -applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> Parser.ApiAnns -> ParsedSource -> PsMessages -> IO (ParsedSource, PsMessages)-applyPluginsParsedResultAction env _dflags ms hpm_annotations parsed msgs = do-  -- dflags is only used in GHC < 9.2+applyPluginsParsedResultAction :: HscEnv -> ModSummary -> ParsedSource -> PsMessages -> IO (ParsedSource, PsMessages)+applyPluginsParsedResultAction env ms parsed msgs = do   -- Apply parsedResultAction of plugins   let applyPluginAction p opts = parsedResultAction p opts ms-#if MIN_VERSION_ghc(9,3,0)-  fmap (\result -> (hpm_module (parsedResultModule result), (parsedResultMessages result))) $ runHsc env $ withPlugins-#else-  fmap (\parsed_module -> (hpm_module parsed_module, msgs)) $ runHsc env $ withPlugins-#endif-#if MIN_VERSION_ghc(9,3,0)+  fmap (\result -> (hpm_module (parsedResultModule result), parsedResultMessages result)) $ runHsc env $ withPlugins       (Env.hsc_plugins env)-#else-      env-#endif       applyPluginAction-#if MIN_VERSION_ghc(9,3,0)-      (ParsedResult (HsParsedModule parsed [] hpm_annotations) msgs)-#else-      (HsParsedModule parsed [] hpm_annotations)-#endif+      (ParsedResult (HsParsedModule parsed []) msgs) -initializePlugins :: HscEnv -> IO HscEnv-initializePlugins env = do-    Loader.initializePlugins env --- | Plugins aren't stored in ModSummary anymore since GHC 9.2, but this--- function still returns it for compatibility with 8.10-initPlugins :: HscEnv -> ModSummary -> IO (ModSummary, HscEnv)-initPlugins session modSummary = do-    session1 <- initializePlugins (hscSetFlags (ms_hspp_opts modSummary) session)-    return (modSummary{ms_hspp_opts = hsc_dflags session1}, session1)- hsc_static_plugins :: HscEnv -> [StaticPlugin]-#if MIN_VERSION_ghc(9,3,0) hsc_static_plugins = staticPlugins . Env.hsc_plugins-#else-hsc_static_plugins = Env.hsc_static_plugins-#endif
src/Development/IDE/GHC/Compat/Units.hs view
@@ -1,14 +1,10 @@-{-# LANGUAGE CPP             #-}-{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE CPP #-}  -- | Compat module for 'UnitState' and 'UnitInfo'. module Development.IDE.GHC.Compat.Units (     -- * UnitState     UnitState,-#if MIN_VERSION_ghc(9,3,0)     initUnits,-#endif-    oldInitUnits,     unitState,     getUnitName,     explicitUnits,@@ -39,7 +35,7 @@     installedModule,     -- * Module     toUnitId,-    Development.IDE.GHC.Compat.Units.moduleUnitId,+    moduleUnitId,     moduleUnit,     -- * ExternalPackageState     ExternalPackageState(..),@@ -56,9 +52,17 @@ import           Development.IDE.GHC.Compat.Outputable import           Prelude                               hiding (mod) --- See Note [Guidelines For Using CPP In GHCIDE Import Statements]-+import           Control.Monad+import qualified Data.List.NonEmpty                    as NE+import qualified Data.Map.Strict                       as Map+import qualified GHC+import qualified GHC.Data.ShortText                    as ST+import qualified GHC.Driver.Session                    as DynFlags+import           GHC.Types.PkgQual                     (PkgQual (NoPkgQual)) import           GHC.Types.Unique.Set+import           GHC.Unit.External+import qualified GHC.Unit.Finder                       as GHC+import           GHC.Unit.Home.ModInfo import qualified GHC.Unit.Info                         as UnitInfo import           GHC.Unit.State                        (LookupResult, UnitInfo,                                                         UnitInfoMap,@@ -70,32 +74,12 @@                                                         unitPackageVersion) import qualified GHC.Unit.State                        as State import           GHC.Unit.Types-import qualified GHC.Unit.Types                        as Unit --#if !MIN_VERSION_ghc(9,3,0)-import           GHC.Data.FastString--#endif--import qualified GHC.Data.ShortText                    as ST-import           GHC.Unit.External-import qualified GHC.Unit.Finder                       as GHC--#if !MIN_VERSION_ghc(9,3,0)-import           GHC.Unit.Env-import           GHC.Unit.Finder                       hiding-                                                       (findImportedModule)-#endif--#if MIN_VERSION_ghc(9,3,0)-import           Control.Monad-import qualified Data.List.NonEmpty                    as NE-import qualified Data.Map.Strict                       as Map-import qualified GHC-import qualified GHC.Driver.Session                    as DynFlags-import           GHC.Types.PkgQual                     (PkgQual (NoPkgQual))-import           GHC.Unit.Home.ModInfo+#if MIN_VERSION_ghc(9,13,0)+import qualified Data.Set                              as Set+import           GHC.Unit.Home.Graph+import           GHC.Unit.Home.PackageTable            (emptyHomePackageTable)+import           GHC.Unit.Module.Graph                 (emptyMG) #endif  @@ -104,21 +88,27 @@ unitState :: HscEnv -> UnitState unitState = ue_units . hsc_unit_env -#if MIN_VERSION_ghc(9,3,0)-createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> HomeUnitGraph-createUnitEnvFromFlags unitDflags =-  let-    newInternalUnitEnv dflags = mkHomeUnitEnv dflags emptyHomePackageTable Nothing-    unitEnvList = NE.map (\dflags -> (homeUnitId_ dflags, newInternalUnitEnv dflags)) unitDflags-  in-    unitEnv_new (Map.fromList (NE.toList (unitEnvList)))+createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> IO HomeUnitGraph+createUnitEnvFromFlags unitDflags = do+#if MIN_VERSION_ghc(9,13,0)+  let mkEntry dflags = do+        hpt <- emptyHomePackageTable+        let us = State.emptyUnitState -- placeholder UnitState+        pure (homeUnitId_ dflags, mkHomeUnitEnv us Nothing dflags hpt Nothing)+  unitEnvList <- mapM mkEntry (NE.toList unitDflags)+  pure $ unitEnv_new (Map.fromList unitEnvList)+#else+  let newInternalUnitEnv dflags = mkHomeUnitEnv dflags emptyHomePackageTable Nothing+      unitEnvList = NE.map (\dflags -> (homeUnitId_ dflags, newInternalUnitEnv dflags)) unitDflags+  pure $ unitEnv_new (Map.fromList (NE.toList unitEnvList))+#endif  initUnits :: [DynFlags] -> HscEnv -> IO HscEnv initUnits unitDflags env = do   let dflags0         = hsc_dflags env   -- additionally, set checked dflags so we don't lose fixes-  let initial_home_graph = createUnitEnvFromFlags (dflags0 NE.:| unitDflags)-      home_units = unitEnv_keys initial_home_graph+  initial_home_graph <- createUnitEnvFromFlags (dflags0 NE.:| unitDflags)+  let home_units = unitEnv_keys initial_home_graph   home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do     let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv         dflags = homeUnitEnv_dflags homeUnitEnv@@ -142,23 +132,16 @@         , ue_home_unit_graph = home_unit_graph         , ue_current_unit    = homeUnitId_ dflags0         , ue_eps             = ue_eps (hsc_unit_env env)+#if MIN_VERSION_ghc(9,13,0)+        , ue_module_graph    = emptyMG+#endif         }   pure $ hscSetFlags dflags1 $ hscSetUnitEnv unit_env env-#endif --- | oldInitUnits only needs to modify DynFlags for GHC <9.2--- For GHC >= 9.2, we need to set the hsc_unit_env also, that is--- done later by initUnits-oldInitUnits :: DynFlags -> IO DynFlags-oldInitUnits = pure  explicitUnits :: UnitState -> [Unit] explicitUnits ue =-#if MIN_VERSION_ghc(9,3,0)   map fst $ State.explicitUnits ue-#else-  State.explicitUnits ue-#endif  listVisibleModuleNames :: HscEnv -> [ModuleName] listVisibleModuleNames env =@@ -171,11 +154,7 @@ lookupModuleWithSuggestions   :: HscEnv   -> ModuleName-#if MIN_VERSION_ghc(9,3,0)   -> GHC.PkgQual-#else-  -> Maybe FastString-#endif   -> LookupResult lookupModuleWithSuggestions env modname mpkg =   State.lookupModuleWithSuggestions (unitState env) modname mpkg@@ -210,10 +189,6 @@ installedModule        = Module  -moduleUnitId :: Module -> UnitId-moduleUnitId =-    Unit.toUnitId . Unit.moduleUnit- filterInplaceUnits :: [UnitId] -> [PackageFlag] -> ([UnitId], [PackageFlag]) filterInplaceUnits us packageFlags =   partitionEithers (map isInplace packageFlags)@@ -230,11 +205,7 @@  findImportedModule :: HscEnv -> ModuleName -> IO (Maybe Module) findImportedModule env mn = do-#if MIN_VERSION_ghc(9,3,0)     res <- GHC.findImportedModule env mn NoPkgQual-#else-    res <- GHC.findImportedModule env mn Nothing-#endif     case res of         Found _ mod -> pure . pure $ mod         _           -> pure Nothing
src/Development/IDE/GHC/Compat/Util.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE CPP             #-}-{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-} -- | GHC Utils and Datastructures re-exports. -- -- Mainly handles module hierarchy re-organisation of GHC@@ -32,6 +31,7 @@     Pair(..),     -- * EnumSet     EnumSet,+    member,     toList,     -- * FastString exports     FastString,@@ -67,13 +67,11 @@     atEnd,     ) where --- See Note [Guidelines For Using CPP In GHCIDE Import Statements]- import           Control.Exception.Safe  (MonadCatch, catch, try) import           GHC.Data.Bag+import           GHC.Data.Bool import           GHC.Data.BooleanFormula import           GHC.Data.EnumSet- import           GHC.Data.FastString import           GHC.Data.Maybe import           GHC.Data.Pair@@ -83,12 +81,3 @@ import           GHC.Utils.Fingerprint import           GHC.Utils.Outputable    (pprHsString) import           GHC.Utils.Panic         hiding (try)--#if !MIN_VERSION_ghc(9,3,0)-import           GHC.Utils.Misc-#endif--#if MIN_VERSION_ghc(9,3,0)-import           GHC.Data.Bool-#endif-
src/Development/IDE/GHC/CoreFile.hs view
@@ -1,6 +1,5 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE CPP             #-}+{-# LANGUAGE RecordWildCards #-}  -- | CoreFiles let us serialize Core to a file in order to later recover it -- without reparsing or retypechecking@@ -11,33 +10,26 @@   , readBinCoreFile   , writeBinCoreFile   , getImplicitBinds-  , occNamePrefixes) where+  ) where  import           Control.Monad-import           Control.Monad.IO.Class-import           Data.Foldable import           Data.IORef-import           Data.List                       (isPrefixOf) import           Data.Maybe-import qualified Data.Text                       as T import           Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat.Util as Util-import           GHC.Fingerprint-import           Prelude                         hiding (mod)---- See Note [Guidelines For Using CPP In GHCIDE Import Statements]- import           GHC.Core import           GHC.CoreToIface+import           GHC.Fingerprint import           GHC.Iface.Binary-import           GHC.Iface.Env+#if MIN_VERSION_ghc(9,11,0)+import qualified GHC.Iface.Load                  as Iface+#endif import           GHC.Iface.Recomp.Binary         (fingerprintBinMem) import           GHC.IfaceToCore import           GHC.Types.Id.Make-import           GHC.Utils.Binary-- import           GHC.Types.TypeEnv+import           GHC.Utils.Binary+import           Prelude                         hiding (mod)   -- | Initial ram buffer to allocate for writing interface files@@ -46,38 +38,11 @@  data CoreFile   = CoreFile-  { cf_bindings   :: [TopIfaceBinding IfaceId]+  { cf_bindings   :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]   -- ^ The actual core file bindings, deserialized lazily   , cf_iface_hash :: !Fingerprint   } --- | Like IfaceBinding, but lets us serialize internal names as well-data TopIfaceBinding v-  = TopIfaceNonRec v IfaceExpr-  | TopIfaceRec    [(v, IfaceExpr)]-  deriving (Functor, Foldable, Traversable)---- | GHC doesn't export 'tcIdDetails', 'tcIfaceInfo', or 'tcIfaceType',--- but it does export 'tcIfaceDecl'--- so we use `IfaceDecl` as a container for all of these--- invariant: 'IfaceId' is always a 'IfaceId' constructor-type IfaceId = IfaceDecl--instance Binary (TopIfaceBinding IfaceId) where-  put_ bh (TopIfaceNonRec d e) = do-    putByte bh 0-    put_ bh d-    put_ bh e-  put_ bh (TopIfaceRec vs) = do-    putByte bh 1-    put_ bh vs-  get bh = do-    t <- getByte bh-    case t of-      0 -> TopIfaceNonRec <$> get bh <*> get bh-      1 -> TopIfaceRec <$> get bh-      _ -> error "Binary TopIfaceBinding"- instance Binary CoreFile where   put_ bh (CoreFile core fp) = lazyPut bh core >> put_ bh fp   get bh = CoreFile <$> lazyGet bh <*> get bh@@ -93,14 +58,20 @@     return (file, fp)  -- | Write a core file-writeBinCoreFile :: FilePath -> CoreFile -> IO Fingerprint-writeBinCoreFile core_path fat_iface = do+writeBinCoreFile :: DynFlags -> FilePath -> CoreFile -> IO Fingerprint+writeBinCoreFile _dflags core_path fat_iface = do     bh <- openBinMem initBinMemSize      let quietTrace =           QuietBinIFace -    putWithUserData quietTrace bh fat_iface+    putWithUserData+      quietTrace+#if MIN_VERSION_ghc(9,11,0)+      (Iface.flagsToIfCompression _dflags)+#endif+      bh+      fat_iface      -- And send the result to the file     writeBinMem bh core_path@@ -115,21 +86,8 @@   :: Fingerprint -- ^ Hash of the interface this was generated from   -> CgGuts   -> CoreFile-#if MIN_VERSION_ghc(9,5,0) -- In GHC 9.6, implicit binds are tidied and part of core binds-codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind1 cg_module) cg_binds) hash-#else-codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind1 cg_module) $ filter isNotImplictBind cg_binds) hash---- | Implicit binds can be generated from the interface and are not tidied,--- so we must filter them out-isNotImplictBind :: CoreBind -> Bool-isNotImplictBind bind = any (not . isImplicitId) $ bindBindings bind--bindBindings :: CoreBind -> [Var]-bindBindings (NonRec b _) = [b]-bindBindings (Rec bnds)   = map fst bnds-#endif+codeGutsToCoreFile hash CgGuts{..} = CoreFile (map toIfaceTopBind cg_binds) hash  getImplicitBinds :: TyCon -> [CoreBind] getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc@@ -147,112 +105,13 @@     | (op, val_index) <- classAllSelIds cls `zip` [0..] ]  get_defn :: Id -> CoreBind-get_defn identifier = NonRec identifier (unfoldingTemplate (realIdUnfolding identifier))--toIfaceTopBndr1 :: Module -> Id -> IfaceId-toIfaceTopBndr1 mod identifier-  = IfaceId (mangleDeclName mod $ getName identifier)-            (toIfaceType (idType identifier))-            (toIfaceIdDetails (idDetails identifier))-            (toIfaceIdInfo (idInfo identifier))--toIfaceTopBind1 :: Module -> Bind Id -> TopIfaceBinding IfaceId-toIfaceTopBind1 mod (NonRec b r) = TopIfaceNonRec (toIfaceTopBndr1 mod b) (toIfaceExpr r)-toIfaceTopBind1 mod (Rec prs)    = TopIfaceRec [(toIfaceTopBndr1 mod b, toIfaceExpr r) | (b,r) <- prs]+get_defn identifier = NonRec identifier templ+  where+    templ = case maybeUnfoldingTemplate (realIdUnfolding identifier) of+              Nothing -> error "get_dfn: no unfolding template"+              Just x  -> x  typecheckCoreFile :: Module -> IORef TypeEnv -> CoreFile -> IfG CoreProgram typecheckCoreFile this_mod type_var (CoreFile prepd_binding _) =   initIfaceLcl this_mod (text "typecheckCoreFile") NotBoot $ do-    tcTopIfaceBindings1 type_var prepd_binding---- | Internal names can't be serialized, so we mange them--- to an external name and restore at deserialization time--- This is necessary because we rely on stuffing TopIfaceBindings into--- a IfaceId because we don't have access to 'tcIfaceType' etc..-mangleDeclName :: Module -> Name -> Name-mangleDeclName mod name-  | isExternalName name = name-  | otherwise = mkExternalName (nameUnique name) (mangleModule mod) (nameOccName name) (nameSrcSpan name)---- | Mangle the module name too to avoid conflicts-mangleModule :: Module -> Module-mangleModule mod = mkModule (moduleUnit mod) (mkModuleName $ "GHCIDEINTERNAL" ++ moduleNameString (moduleName mod))--isGhcideModule :: Module -> Bool-isGhcideModule mod = "GHCIDEINTERNAL" `isPrefixOf` (moduleNameString $ moduleName mod)---- Is this a fake external name that we need to make into an internal name?-isGhcideName :: Name -> Bool-isGhcideName = isGhcideModule . nameModule--tcTopIfaceBindings1 :: IORef TypeEnv -> [TopIfaceBinding IfaceId]-          -> IfL [CoreBind]-tcTopIfaceBindings1 ty_var ver_decls-   = do-     int <- mapM (traverse $ tcIfaceId) ver_decls-     let all_ids = concatMap toList int-     liftIO $ modifyIORef ty_var (flip extendTypeEnvList $ map AnId all_ids)-     extendIfaceIdEnv all_ids $ mapM tc_iface_bindings int--tcIfaceId :: IfaceId -> IfL Id-tcIfaceId = fmap getIfaceId . tcIfaceDecl False <=< unmangle_decl_name-  where-    unmangle_decl_name ifid@IfaceId{ ifName = name }-    -- Check if the name is mangled-      | isGhcideName name = do-        name' <- newIfaceName (mkVarOcc $ getOccString name)-        pure $ ifid{ ifName = name' }-      | otherwise = pure ifid-    -- invariant: 'IfaceId' is always a 'IfaceId' constructor-    getIfaceId (AnId identifier) = identifier-    getIfaceId _                 = error "tcIfaceId: got non Id"--tc_iface_bindings :: TopIfaceBinding Id -> IfL CoreBind-tc_iface_bindings (TopIfaceNonRec v e) = do-  e' <- tcIfaceExpr e-  pure $ NonRec v e'-tc_iface_bindings (TopIfaceRec vs) = do-  vs' <- traverse (\(v, e) -> (,) <$> pure v <*> tcIfaceExpr e) vs-  pure $ Rec vs'---- | Prefixes that can occur in a GHC OccName-occNamePrefixes :: [T.Text]-occNamePrefixes =-  [-    -- 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"-  ]+    tcTopIfaceBindings type_var prepd_binding
src/Development/IDE/GHC/Error.hs view
@@ -1,11 +1,15 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP                      #-}+{-# LANGUAGE DisambiguateRecordFields #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 module Development.IDE.GHC.Error   (     -- * Producing Diagnostic values-    diagFromErrMsgs+    diagFromGhcErrorMessages+  , diagFromErrMsgs   , diagFromErrMsg+  , diagFromSDocErrMsgs+  , diagFromSDocErrMsg   , diagFromString   , diagFromStrings   , diagFromGhcException@@ -17,6 +21,8 @@   , realSrcSpanToRange   , realSrcLocToPosition   , realSrcSpanToLocation+  , realSrcSpanToCodePointRange+  , realSrcLocToCodePointPosition   , srcSpanToFilename   , rangeToSrcSpan   , rangeToRealSrcSpan@@ -31,10 +37,13 @@   , toDSeverity   ) where +import           Control.Lens import           Data.Maybe import           Data.String                       (fromString) import qualified Data.Text                         as T-import           Development.IDE.GHC.Compat        (DecoratedSDoc, MsgEnvelope,+import           Data.Tuple.Extra                  (uncurry3)+import           Development.IDE.GHC.Compat        (GhcMessage, MsgEnvelope,+                                                    errMsgDiagnostic,                                                     errMsgSeverity, errMsgSpan,                                                     formatErrorWithQual,                                                     srcErrorMessages)@@ -45,32 +54,49 @@ import           Development.IDE.Types.Location import           GHC import           Language.LSP.Protocol.Types       (isSubrangeOf)+import           Language.LSP.VFS                  (CodePointPosition (CodePointPosition),+                                                    CodePointRange (CodePointRange))  -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-    , _codeDescription = Nothing-    , _data_   = Nothing-    }+diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> Maybe (MsgEnvelope GhcMessage) -> FileDiagnostic+diagFromText diagSource sev loc msg origMsg =+  D.ideErrorWithSource+    (Just diagSource) (Just sev)+    (toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc)+    msg origMsg+    & fdLspDiagnosticL %~ \diag -> diag { D._range = fromMaybe noRange $ srcSpanToRange loc }  -- | Produce a GHC-style error from a source span and a message.-diagFromErrMsg :: T.Text -> DynFlags -> MsgEnvelope DecoratedSDoc -> [FileDiagnostic]-diagFromErrMsg diagSource dflags e =-    [ diagFromText diagSource sev (errMsgSpan e)-      $ T.pack $ formatErrorWithQual dflags e-    | Just sev <- [toDSeverity $ errMsgSeverity e]]+diagFromErrMsg :: T.Text -> DynFlags -> MsgEnvelope GhcMessage -> [FileDiagnostic]+diagFromErrMsg diagSource dflags origErr =+    let err = fmap (\e -> (Compat.renderDiagnosticMessageWithHints e, Just origErr)) origErr+    in+    diagFromSDocWithOptionalOrigMsg diagSource dflags err -diagFromErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic]+-- | Compatibility function for creating '[FileDiagnostic]' from+-- a 'Compat.Bag' of GHC error messages.+-- The function signature changes based on the GHC version.+-- While this is not desirable, it avoids more CPP statements in code+-- that implements actual logic.+diagFromGhcErrorMessages :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope GhcMessage) -> [FileDiagnostic]+diagFromGhcErrorMessages sourceParser dflags errs =+    diagFromErrMsgs sourceParser dflags errs++diagFromErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope GhcMessage) -> [FileDiagnostic] diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . Compat.bagToList +diagFromSDocErrMsg :: T.Text -> DynFlags -> MsgEnvelope Compat.DecoratedSDoc -> [FileDiagnostic]+diagFromSDocErrMsg diagSource dflags err =+    diagFromSDocWithOptionalOrigMsg diagSource dflags (fmap (,Nothing) err)++diagFromSDocErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope Compat.DecoratedSDoc) -> [FileDiagnostic]+diagFromSDocErrMsgs diagSource dflags = concatMap (diagFromSDocErrMsg diagSource dflags) . Compat.bagToList++diagFromSDocWithOptionalOrigMsg :: T.Text -> DynFlags -> MsgEnvelope (Compat.DecoratedSDoc, Maybe (MsgEnvelope GhcMessage)) -> [FileDiagnostic]+diagFromSDocWithOptionalOrigMsg diagSource dflags err =+    [ diagFromText diagSource sev (errMsgSpan err) (T.pack (formatErrorWithQual dflags (fmap fst err))) (snd (errMsgDiagnostic err))+    | Just sev <- [toDSeverity $ errMsgSeverity err]]+ -- | Convert a GHC SrcSpan to a DAML compiler Range srcSpanToRange :: SrcSpan -> Maybe Range srcSpanToRange (UnhelpfulSpan _)           = Nothing@@ -86,6 +112,29 @@ realSrcLocToPosition real =   Position (fromIntegral $ srcLocLine real - 1) (fromIntegral $ srcLocCol real - 1) +-- Note [Unicode support]+-- ~~~~~~~~~~~~~~~~~~~~~~+-- the current situation is:+-- LSP Positions use UTF-16 code units(Unicode may count as variable columns);+-- GHC use Unicode code points(Unicode count as one column).+-- To support unicode, ideally range should be in lsp standard,+-- and codePoint should be in ghc standard.+-- see https://github.com/haskell/lsp/pull/407++-- | Convert a GHC SrcSpan to CodePointRange+-- see Note [Unicode support]+realSrcSpanToCodePointRange :: RealSrcSpan -> CodePointRange+realSrcSpanToCodePointRange real =+  CodePointRange+    (realSrcLocToCodePointPosition $ Compat.realSrcSpanStart real)+    (realSrcLocToCodePointPosition $ Compat.realSrcSpanEnd real)++-- | Convert a GHC RealSrcLoc to CodePointPosition+-- see Note [Unicode support]+realSrcLocToCodePointPosition :: RealSrcLoc -> CodePointPosition+realSrcLocToCodePointPosition real =+  CodePointPosition (fromIntegral $ srcLocLine real - 1) (fromIntegral $ 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@@ -130,27 +179,19 @@ -- | Convert a GHC severity to a DAML compiler Severity. Severities below -- "Warning" level are dropped (returning Nothing). toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity-#if !MIN_VERSION_ghc(9,3,0)-toDSeverity SevOutput      = Nothing-toDSeverity SevInteractive = Nothing-toDSeverity SevDump        = Nothing-toDSeverity SevInfo        = Just DiagnosticSeverity_Information-toDSeverity SevFatal       = Just DiagnosticSeverity_Error-#else-toDSeverity SevIgnore      = Nothing-#endif-toDSeverity SevWarning     = Just DiagnosticSeverity_Warning-toDSeverity SevError       = Just DiagnosticSeverity_Error+toDSeverity SevIgnore  = Nothing+toDSeverity SevWarning = Just DiagnosticSeverity_Warning+toDSeverity SevError   = Just DiagnosticSeverity_Error   -- | 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))+diagFromStrings :: T.Text -> D.DiagnosticSeverity -> [(SrcSpan, String, Maybe (MsgEnvelope GhcMessage))] -> [FileDiagnostic]+diagFromStrings diagSource sev = concatMap (uncurry3 (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]+diagFromString :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> String -> Maybe (MsgEnvelope GhcMessage) -> [FileDiagnostic]+diagFromString diagSource sev sp x origMsg = [diagFromText diagSource sev sp (T.pack x) origMsg]   -- | Produces an "unhelpful" source span with the given string.@@ -180,15 +221,11 @@       Right <$> ghcM     where         ghcExceptionToDiagnostics = return . Left . diagFromGhcException fromWhere dflags-        sourceErrorToDiagnostics = return . Left . diagFromErrMsgs fromWhere dflags-#if MIN_VERSION_ghc(9,3,0)-                                        . fmap (fmap Compat.renderDiagnosticMessageWithHints) . Compat.getMessages-#endif-                                        . srcErrorMessages-+        sourceErrorToDiagnostics diag = pure $ Left $+          diagFromErrMsgs fromWhere dflags (Compat.getMessages (srcErrorMessages diag))  diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic]-diagFromGhcException diagSource dflags exc = diagFromString diagSource DiagnosticSeverity_Error (noSpan "<Internal>") (showGHCE dflags exc)+diagFromGhcException diagSource dflags exc = diagFromString diagSource DiagnosticSeverity_Error (noSpan "<Internal>") (showGHCE dflags exc) Nothing  showGHCE :: DynFlags -> GhcException -> String showGHCE dflags exc = case exc of
src/Development/IDE/GHC/Orphans.hs view
@@ -1,8 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP               #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans #-}  -- | Orphan instances for GHC.@@ -12,35 +11,30 @@ import           Development.IDE.GHC.Util  import           Control.DeepSeq-import           Control.Monad.Trans.Reader (ReaderT (..))+import           Control.Monad.Trans.Reader        (ReaderT (..)) import           Data.Aeson import           Data.Hashable-import           Data.String                (IsString (fromString))-import           Data.Text                  (unpack)---- See Note [Guidelines For Using CPP In GHCIDE Import Statements]+import           Data.String                       (IsString (fromString))+import           Data.Text                         (unpack) +import           Data.Bifunctor                    (Bifunctor (..)) import           GHC.ByteCode.Types import           GHC.Data.Bag import           GHC.Data.FastString-import qualified GHC.Data.StringBuffer      as SB-import           GHC.Types.SrcLoc--#if !MIN_VERSION_ghc(9,3,0)-import           GHC                        (ModuleGraph)-import           GHC.Types.Unique           (getKey)-#endif--import           Data.Bifunctor             (Bifunctor (..))+import qualified GHC.Data.StringBuffer             as SB+import           GHC.Iface.Ext.Types import           GHC.Parser.Annotation--#if MIN_VERSION_ghc(9,3,0) import           GHC.Types.PkgQual+import           GHC.Types.SrcLoc+#if MIN_VERSION_ghc(9,13,0)+import           GHC.Types.Basic                   (ImportLevel) #endif -#if MIN_VERSION_ghc(9,5,0)+-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]+ import           GHC.Unit.Home.ModInfo-#endif+import           GHC.Unit.Module.Location          (ModLocation (..))+import           GHC.Unit.Module.WholeCoreBindings  -- Orphan instance for Shake.hs -- https://hub.darcs.net/ross/transformers/issue/86@@ -53,14 +47,45 @@ instance NFData CgGuts where rnf = rwhnf instance Show ModDetails where show = const "<moddetails>" instance NFData ModDetails where rnf = rwhnf+#if !MIN_VERSION_ghc(9,13,0) instance NFData SafeHaskellMode where rnf = rwhnf+#endif instance Show Linkable where show = unpack . printOutputable+#if MIN_VERSION_ghc(9,11,0)+instance NFData Linkable where rnf (Linkable a b c) = rnf a `seq` rnf b `seq` rnf c+instance NFData LinkableObjectSort where rnf = rwhnf+instance NFData LinkablePart where+  rnf (DotO a b)         = rnf a `seq` rnf b+  rnf (DotA f)           = rnf f+  rnf (DotDLL f)         = rnf f+  rnf (BCOs a)           = seqCompiledByteCode a+  rnf (CoreBindings wcb) = rnf wcb+  rnf (LazyBCOs a b)     = seqCompiledByteCode a `seq` rnf b+#else instance NFData Linkable where rnf (LM a b c) = rnf a `seq` rnf b `seq` rnf c instance NFData Unlinked where-  rnf (DotO f)   = rnf f-  rnf (DotA f)   = rnf f-  rnf (DotDLL f) = rnf f-  rnf (BCOs a b) = seqCompiledByteCode a `seq` liftRnf rwhnf b+  rnf (DotO f)           = rnf f+  rnf (DotA f)           = rnf f+  rnf (DotDLL f)         = rnf f+  rnf (BCOs a b)         = seqCompiledByteCode a `seq` liftRnf rwhnf b+  rnf (CoreBindings wcb) = rnf wcb+  rnf (LoadedBCOs us)    = rnf us+#endif++instance NFData WholeCoreBindings where+#if MIN_VERSION_ghc(9,11,0)+  rnf (WholeCoreBindings bs m ml f) = rnf bs `seq` rnf m `seq` rnf ml `seq` rnf f+#else+  rnf (WholeCoreBindings bs m ml) = rnf bs `seq` rnf m `seq` rnf ml+#endif++instance NFData ModLocation where+#if MIN_VERSION_ghc(9,11,0)+    rnf (OsPathModLocation mf f1 f2 f3 f4 f5) = rnf mf `seq` rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5+#else+    rnf (ModLocation mf f1 f2 f3 f4 f5) = rnf mf `seq` rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5+#endif+ instance Show PackageFlag where show = unpack . printOutputable instance Show InteractiveImport where show = unpack . printOutputable instance Show PackageName  where show = unpack . printOutputable@@ -74,15 +99,6 @@ instance Show Module where     show = moduleNameString . moduleName -#if !MIN_VERSION_ghc(9,3,0)-instance Outputable a => Show (GenLocated SrcSpan a) where show = unpack . printOutputable-#endif--#if !MIN_VERSION_ghc(9,5,0)-instance (NFData l, NFData e) => NFData (GenLocated l e) where-    rnf (L l e) = rnf l `seq` rnf e-#endif- instance Show ModSummary where     show = show . ms_mod @@ -95,14 +111,19 @@ instance Ord FastString where     compare a b = if a == b then EQ else compare (fs_sbs a) (fs_sbs b) ++#if MIN_VERSION_ghc(9,9,0)+instance NFData (EpAnn a) where+  rnf = rwhnf+#else instance NFData (SrcSpanAnn' a) where     rnf = rwhnf+deriving instance Functor SrcSpanAnn'+#endif -instance Bifunctor (GenLocated) where+instance Bifunctor GenLocated where     bimap f g (L l x) = L (f l) (g x) -deriving instance Functor SrcSpanAnn'- instance NFData ParsedModule where     rnf = rwhnf @@ -112,12 +133,6 @@ instance NFData HieFile where     rnf = rwhnf -#if !MIN_VERSION_ghc(9,3,0)-deriving instance Eq SourceModified-deriving instance Show SourceModified-instance NFData SourceModified where-    rnf = rwhnf-#endif  instance Hashable ModuleName where     hashWithSalt salt = hashWithSalt salt . show@@ -126,8 +141,10 @@ instance NFData a => NFData (IdentifierDetails a) where     rnf (IdentifierDetails a b) = rnf a `seq` rnf (length b) +#if !MIN_VERSION_ghc(9,13,0) instance NFData RealSrcSpan where     rnf = rwhnf+#endif  srcSpanFileTag, srcSpanStartLineTag, srcSpanStartColTag,     srcSpanEndLineTag, srcSpanEndColTag :: String@@ -166,11 +183,6 @@ instance Show a => Show (Bag a) where     show = show . bagToList -#if !MIN_VERSION_ghc(9,5,0)-instance NFData HsDocString where-    rnf = rwhnf-#endif- instance Show ModGuts where     show _ = "modguts" instance NFData ModGuts where@@ -179,11 +191,7 @@ instance NFData (ImportDecl GhcPs) where     rnf = rwhnf -#if MIN_VERSION_ghc(9,5,0) instance (NFData (HsModule a)) where-#else-instance (NFData HsModule) where-#endif   rnf = rwhnf  instance Show OccName where show = unpack . printOutputable@@ -203,23 +211,21 @@ instance NFData HomeModInfo where   rnf (HomeModInfo iface dets link) = rwhnf iface `seq` rnf dets `seq` rnf link -#if MIN_VERSION_ghc(9,3,0) instance NFData PkgQual where   rnf NoPkgQual      = ()   rnf (ThisPkg uid)  = rnf uid   rnf (OtherPkg uid) = rnf uid +#if !MIN_VERSION_ghc(9,13,0) instance NFData UnitId where   rnf = rwhnf+#endif  instance NFData NodeKey where   rnf = rwhnf-#endif -#if MIN_VERSION_ghc(9,5,0) instance NFData HomeModLinkable where   rnf = rwhnf-#endif  instance NFData (HsExpr (GhcPass Renamed)) where     rnf = rwhnf@@ -227,8 +233,19 @@ instance NFData (Pat (GhcPass Renamed)) where     rnf = rwhnf +instance NFData (HsExpr (GhcPass Typechecked)) where+    rnf = rwhnf++instance NFData (Pat (GhcPass Typechecked)) where+    rnf = rwhnf+ instance NFData Extension where   rnf = rwhnf  instance NFData (UniqFM Name [Name]) where   rnf (ufmToIntMap -> m) = rnf m++#if MIN_VERSION_ghc(9,13,0)+instance NFData ImportLevel where+  rnf = rwhnf+#endif
src/Development/IDE/GHC/Util.hs view
@@ -27,7 +27,10 @@     dontWriteHieFiles,     disableWarningsAsErrors,     printOutputable,-    getExtensions+    printOutputableOneLine,+    getExtensions,+    getExtensionsSet,+    stripOccNamePrefix,     ) where  import           Control.Concurrent@@ -62,9 +65,7 @@ import           Ide.PluginUtils                   (unescape) import           System.FilePath --- See Note [Guidelines For Using CPP In GHCIDE Import Statements]--+import           Data.Monoid                       (First (..)) import           GHC.Data.EnumSet import           GHC.Data.FastString import           GHC.Data.StringBuffer@@ -168,7 +169,7 @@ --   Will produce an 8 byte unreadable ByteString. fingerprintToBS :: Fingerprint -> BS.ByteString fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do-    ptr' <- pure $ castPtr ptr+    let ptr' = castPtr ptr     pokeElemOff ptr' 0 a     pokeElemOff ptr' 1 b @@ -258,7 +259,6 @@ -- Tracing exactprint terms  -- | Print a GHC value in `defaultUserStyle` without unique symbols.--- It uses `showSDocUnsafe` with `unsafeGlobalDynFlags` internally. -- -- This is the most common print utility. -- It will do something additionally compared to what the 'Outputable' instance does.@@ -266,12 +266,72 @@ --   1. print with a user-friendly style: `a_a4ME` as `a`. --   2. unescape escape sequences of printable unicode characters within a pair of double quotes printOutputable :: Outputable a => a -> T.Text-printOutputable =+printOutputable = printOutputable' printWithoutUniques++printOutputableOneLine :: Outputable a => a -> T.Text+printOutputableOneLine = printOutputable' printWithoutUniquesOneLine++printOutputable' :: Outputable a => (a -> String) -> a -> T.Text+printOutputable' print =     -- IfaceTyLit from GHC.Iface.Type implements Outputable with 'show'.     -- Showing a String escapes non-ascii printable characters. We unescape it here.     -- More discussion at https://github.com/haskell/haskell-language-server/issues/3115.-    unescape . T.pack . printWithoutUniques+    unescape . T.pack . print {-# INLINE printOutputable #-}  getExtensions :: ParsedModule -> [Extension]-getExtensions = toList . extensionFlags . ms_hspp_opts . pm_mod_summary+getExtensions = toList . getExtensionsSet++getExtensionsSet :: ParsedModule -> EnumSet Extension+getExtensionsSet = extensionFlags . ms_hspp_opts . pm_mod_summary++-- | 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+stripOccNamePrefix :: T.Text -> T.Text+stripOccNamePrefix name = T.takeWhile (/=':') $ fromMaybe name $+    getFirst $ foldMap (First . (`T.stripPrefix` name))+    occNamePrefixes++-- | Prefixes that can occur in a GHC OccName+occNamePrefixes :: [T.Text]+occNamePrefixes =+  [+    -- 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"+  ]
src/Development/IDE/GHC/Warnings.hs view
@@ -6,15 +6,37 @@ module Development.IDE.GHC.Warnings(withWarnings) where  import           Control.Concurrent.Strict-import           Data.List+import           Control.Lens                      (over) import qualified Data.Text                         as T  import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Error import           Development.IDE.Types.Diagnostics-import           Language.LSP.Protocol.Types       (type (|?) (..)) +{-+ Note [withWarnings and its dangers]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    withWarnings collects warnings by registering a custom logger which extracts+    the SDocs of those warnings. If you receive warnings this way, you will not+    get them in a structured form. In the medium term we'd like to remove all+    uses of withWarnings to get structured messages everywhere we can. +    For the time being, withWarnings is no longer used for anything in the main+    typecheckModule codepath, but it is still used for bytecode/object code+    generation, as well as a few other places.++    I suspect some of these functions (e.g. codegen) will need deeper changes to+    be able to get diagnostics as a list, though I don't have great evidence for+    that atm. I haven't taken a look to see if those functions that are wrapped+    with this could produce diagnostics another way.++    It would be good for someone to take a look. What we've done so far gives us+    diagnostics for renaming and typechecking, and doesn't require us to copy+    too much code from GHC or make any deeper changes, and lets us get started+    with the bulk of the useful plugin work, but it would be good to have all+    diagnostics with structure be collected that way.+-}+ -- | 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'@@ -24,42 +46,16 @@ --   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-#if MIN_VERSION_ghc(9,3,0)+--+-- Also, See Note [withWarnings and its dangers] for some commentary on this function. withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(Maybe DiagnosticReason, FileDiagnostic)], a)-#else-withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a)-#endif withWarnings diagSource action = do   warnings <- newVar []   let newAction :: DynFlags -> LogActionCompat       newAction dynFlags logFlags wr _ loc prUnqual msg = do-        let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags wr logFlags loc prUnqual msg+        let wr_d = map ((wr,) . over fdLspDiagnosticL (attachReason wr)) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg)         modifyVar_ warnings $ return . (wr_d:)       newLogger env = pushLogHook (const (logActionCompat (newAction (hsc_dflags env)))) (hsc_logger env)   res <- action $ \env -> putLogHook (newLogger env) env   warns <- readVar warnings   return (reverse $ concat warns, res)-  where-    third3 :: (c -> d) -> (a, b, c) -> (a, b, d)-    third3 f (a, b, c) = (a, b, f c)--#if MIN_VERSION_ghc(9,3,0)-attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic-attachReason Nothing d = d-attachReason (Just wr) d = d{_code = InR <$> showReason wr}- where-  showReason = \case-    WarningWithFlag flag -> showFlag flag-    _                    -> Nothing-#else-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-#endif--showFlag :: WarningFlag -> Maybe T.Text-showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags
src/Development/IDE/Import/DependencyInformation.hs view
@@ -20,6 +20,7 @@   , insertImport   , pathToId   , idToPath+  , idToModLocation   , reachableModules   , processDependencyInformation   , transitiveDeps@@ -28,6 +29,7 @@   , lookupModuleFile   , BootIdMap   , insertBootId+  , lookupFingerprint   ) where  import           Control.DeepSeq@@ -47,22 +49,17 @@ import qualified Data.List.NonEmpty                 as NonEmpty import           Data.Maybe import           Data.Tuple.Extra                   hiding (first, second)+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat.Util    (Fingerprint)+import qualified Development.IDE.GHC.Compat.Util    as Util import           Development.IDE.GHC.Orphans        ()-import           GHC.Generics                       (Generic)-import           Prelude                            hiding (mod)- import           Development.IDE.Import.FindImports (ArtifactsLocation (..)) import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Location+import           GHC.Generics                       (Generic)+import           Prelude                            hiding (mod) -import           Development.IDE.GHC.Compat --- See Note [Guidelines For Using CPP In GHCIDE Import Statements]--#if !MIN_VERSION_ghc(9,3,0)-import           GHC-#endif- -- | The imports for a given module. newtype ModuleImports = ModuleImports     { moduleImports :: [(Located ModuleName, Maybe FilePathId)]@@ -142,23 +139,35 @@  data DependencyInformation =   DependencyInformation-    { depErrorNodes        :: !(FilePathIdMap (NonEmpty NodeError))+    { depErrorNodes         :: !(FilePathIdMap (NonEmpty NodeError))     -- ^ Nodes that cannot be processed correctly.-    , depModules           :: !(FilePathIdMap ShowableModule)-    , depModuleDeps        :: !(FilePathIdMap FilePathIdSet)+    , depModules            :: !(FilePathIdMap ShowableModule)+    , depModuleDeps         :: !(FilePathIdMap FilePathIdSet)     -- ^ For a non-error node, this contains the set of module immediate dependencies     -- in the same package.-    , depReverseModuleDeps :: !(IntMap IntSet)+    , depReverseModuleDeps  :: !(IntMap IntSet)     -- ^ Contains a reverse mapping from a module to all those that immediately depend on it.-    , depPathIdMap         :: !PathIdMap+    , depPathIdMap          :: !PathIdMap     -- ^ Map from FilePath to FilePathId-    , depBootMap           :: !BootIdMap+    , depBootMap            :: !BootIdMap     -- ^ Map from hs-boot file to the corresponding hs file-    , depModuleFiles       :: !(ShowableModuleEnv FilePathId)+    , depModuleFiles        :: !(ShowableModuleEnv FilePathId)     -- ^ Map from Module to the corresponding non-boot hs file-    , depModuleGraph       :: !ModuleGraph+    , depModuleGraph        :: !ModuleGraph+    , depTransDepsFingerprints :: !(FilePathIdMap Fingerprint)+    -- ^ Map from Module to fingerprint of the transitive dependencies of the module.+    , depTransReverseDepsFingerprints :: !(FilePathIdMap Fingerprint)+    -- ^ Map from FilePathId to the fingerprint of the transitive reverse dependencies of the module.+    , depImmediateReverseDepsFingerprints :: !(FilePathIdMap Fingerprint)+    -- ^ Map from FilePathId to the fingerprint of the immediate reverse dependencies of the module.     } deriving (Show, Generic) +lookupFingerprint :: NormalizedFilePath -> DependencyInformation -> FilePathIdMap Fingerprint -> Maybe Fingerprint+lookupFingerprint fileId DependencyInformation {..} depFingerprintMap =+  do+    FilePathId cur_id <- lookupPathToId depPathIdMap fileId+    IntMap.lookup cur_id depFingerprintMap+ newtype ShowableModule =   ShowableModule {showableModule :: Module}   deriving NFData@@ -234,8 +243,8 @@    SuccessNode _ <> ErrorNode errs   = ErrorNode errs    SuccessNode a <> SuccessNode _    = SuccessNode a -processDependencyInformation :: RawDependencyInformation -> BootIdMap -> ModuleGraph -> DependencyInformation-processDependencyInformation RawDependencyInformation{..} rawBootMap mg =+processDependencyInformation :: RawDependencyInformation -> BootIdMap -> ModuleGraph -> FilePathIdMap Fingerprint -> DependencyInformation+processDependencyInformation RawDependencyInformation{..} rawBootMap mg shallowFingerMap =   DependencyInformation     { depErrorNodes = IntMap.fromList errorNodes     , depModuleDeps = moduleDeps@@ -245,6 +254,9 @@     , depBootMap = rawBootMap     , depModuleFiles = ShowableModuleEnv reverseModuleMap     , depModuleGraph = mg+    , depTransDepsFingerprints = buildTransDepsFingerprintMap moduleDeps shallowFingerMap+    , depTransReverseDepsFingerprints = buildTransDepsFingerprintMap reverseModuleDeps shallowFingerMap+    , depImmediateReverseDepsFingerprints = buildImmediateDepsFingerprintMap reverseModuleDeps shallowFingerMap     }   where resultGraph = buildResultGraph rawImports         (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph@@ -404,3 +416,44 @@  instance Show NamedModuleDep where   show NamedModuleDep{..} = show nmdFilePath+++buildImmediateDepsFingerprintMap :: FilePathIdMap FilePathIdSet -> FilePathIdMap Fingerprint -> FilePathIdMap Fingerprint+buildImmediateDepsFingerprintMap modulesDeps shallowFingers =+  IntMap.fromList+    $ map+      ( \k ->+          ( k,+            Util.fingerprintFingerprints $+              map+                (shallowFingers IntMap.!)+                (k : IntSet.toList (IntMap.findWithDefault IntSet.empty k modulesDeps))+          )+      )+    $ IntMap.keys shallowFingers++-- | Build a map from file path to its full fingerprint.+-- The fingerprint is depend on both the fingerprints of the file and all its dependencies.+-- This is used to determine if a file has changed and needs to be reloaded.+buildTransDepsFingerprintMap :: FilePathIdMap FilePathIdSet -> FilePathIdMap Fingerprint -> FilePathIdMap Fingerprint+buildTransDepsFingerprintMap modulesDeps shallowFingers = go keys IntMap.empty+  where+    keys = IntMap.keys shallowFingers+    go :: [IntSet.Key] -> FilePathIdMap Fingerprint -> FilePathIdMap Fingerprint+    go keys acc =+      case keys of+        [] -> acc+        k : ks ->+          if IntMap.member k acc+            -- already in the map, so we can skip+            then go ks acc+            -- not in the map, so we need to add it+            else+              let -- get the dependencies of the current key+                  deps = IntSet.toList $ IntMap.findWithDefault IntSet.empty k modulesDeps+                  -- add fingerprints of the dependencies to the accumulator+                  depFingerprints = go deps acc+                  -- combine the fingerprints of the dependencies with the current key+                  combinedFingerprints = Util.fingerprintFingerprints $ shallowFingers IntMap.! k : map (depFingerprints IntMap.!) deps+               in -- add the combined fingerprints to the accumulator+                  go ks (IntMap.insert k combinedFingerprints depFingerprints)
src/Development/IDE/Import/FindImports.hs view
@@ -14,28 +14,23 @@   ) where  import           Control.DeepSeq+import           Control.Monad.Extra+import           Control.Monad.IO.Class+import           Data.List                         (find, isSuffixOf)+import           Data.Maybe+import qualified Data.Set                          as S import           Development.IDE.GHC.Compat        as Compat import           Development.IDE.GHC.Error         as ErrUtils import           Development.IDE.GHC.Orphans       () import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Location---- standard imports-import           Control.Monad.Extra-import           Control.Monad.IO.Class-import           Data.List                         (isSuffixOf)-import           Data.Maybe+import           GHC.Types.PkgQual+import           GHC.Unit.State import           System.FilePath --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0)-import           Development.IDE.GHC.Compat.Util-#endif--#if MIN_VERSION_ghc(9,3,0)-import           GHC.Types.PkgQual-import           GHC.Unit.State+#if MIN_VERSION_ghc(9,11,0)+import           GHC.Driver.DynFlags #endif  data Import@@ -70,19 +65,30 @@       Just modSum -> isSource (ms_hsc_src modSum)     mbMod = ms_mod <$> ms +data LocateResult+  = LocateNotFound+  | LocateFoundReexport UnitId+  | LocateFoundFile UnitId NormalizedFilePath+ -- | locate a module in the file system. Where we go from *daml to Haskell locateModuleFile :: MonadIO m-             => [(UnitId, [FilePath])]+             => [(UnitId, [FilePath], S.Set ModuleName)]              -> [String]              -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath))              -> Bool              -> ModuleName-             -> m (Maybe (UnitId, NormalizedFilePath))+             -> m LocateResult locateModuleFile import_dirss exts targetFor isSource modName = do   let candidates import_dirs =         [ toNormalizedFilePath' (prefix </> moduleNameSlashes modName <.> maybeBoot ext)            | prefix <- import_dirs , ext <- exts]-  firstJustM go (concat [map (uid,) (candidates dirs) | (uid, dirs) <- import_dirss])+  mf <- firstJustM go (concat [map (uid,) (candidates dirs) | (uid, dirs, _) <- import_dirss])+  case mf of+    Nothing ->+      case find (\(_ , _, reexports) -> S.member modName reexports) import_dirss of+        Just (uid,_,_) -> pure $ LocateFoundReexport uid+        Nothing        -> pure LocateNotFound+    Just (uid,file) -> pure $ LocateFoundFile uid file   where     go (uid, candidate) = fmap ((uid,) <$>) $ targetFor modName candidate     maybeBoot ext@@ -93,12 +99,11 @@ -- 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.-#if MIN_VERSION_ghc(9,3,0)-mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (UnitId, [FilePath])-mkImportDirs _env (i, flags) = Just (i, importPaths flags)+mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (UnitId, ([FilePath], S.Set ModuleName))+#if MIN_VERSION_ghc(9,11,0)+mkImportDirs _env (i, flags) = Just (i, (importPaths flags, S.fromList $ map reexportTo $ reexportedModules flags)) #else-mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, (UnitId, [FilePath]))-mkImportDirs env (i, flags) = (, (i, importPaths flags)) <$> getUnitName env i+mkImportDirs _env (i, flags) = Just (i, (importPaths flags, reexportedModules flags)) #endif  -- | locate a module in either the file system or the package database. Where we go from *daml to@@ -110,87 +115,66 @@     -> [String]                        -- ^ File extensions     -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath))  -- ^ does file exist predicate     -> Located ModuleName              -- ^ Module name-#if MIN_VERSION_ghc(9,3,0)     -> PkgQual                -- ^ Package name-#else-    -> Maybe FastString                -- ^ Package name-#endif     -> Bool                            -- ^ Is boot module     -> m (Either [FileDiagnostic] Import) locateModule env comp_info exts targetFor modName mbPkgName isSource = do   case mbPkgName of-    -- "this" means that we should only look in the current package-#if MIN_VERSION_ghc(9,3,0)-    ThisPkg _ -> do-#else-    Just "this" -> do-#endif-      lookupLocal (homeUnitId_ dflags) (importPaths dflags)+    -- 'ThisPkg' just means some home module, not the current unit+    ThisPkg uid+      | Just (dirs, reexports) <- lookup uid import_paths+          -> lookupLocal uid dirs reexports+      | otherwise -> return $ Left $ notFoundErr env modName $ LookupNotFound []     -- if a package name is given we only go look for a package-#if MIN_VERSION_ghc(9,3,0)     OtherPkg uid-      | Just dirs <- lookup uid import_paths-          -> lookupLocal uid dirs-#else-    Just pkgName-      | Just (uid, dirs) <- lookup (PackageName pkgName) import_paths-          -> lookupLocal uid dirs-#endif+      | Just (dirs, reexports) <- lookup uid import_paths+          -> lookupLocal uid dirs reexports       | otherwise -> lookupInPackageDB-#if MIN_VERSION_ghc(9,3,0)     NoPkgQual -> do-#else-    Nothing -> do-#endif -      mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags) : other_imports) exts targetFor isSource $ unLoc modName+      -- Reexports for current unit have to be empty because they only apply to other units depending on the+      -- current unit. If we set the reexports to be the actual reexports then we risk looping forever trying+      -- to find the module from the perspective of the current unit.+      mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags, S.empty) : other_imports) exts targetFor isSource $ unLoc modName       case mbFile of-        Nothing          -> lookupInPackageDB-        Just (uid, file) -> toModLocation uid file+        LocateNotFound -> lookupInPackageDB+        -- Lookup again with the perspective of the unit reexporting the file+        LocateFoundReexport uid -> locateModule (hscSetActiveUnitId uid env) comp_info exts targetFor modName noPkgQual isSource+        LocateFoundFile uid file -> toModLocation uid file   where     dflags = hsc_dflags env     import_paths = mapMaybe (mkImportDirs env) comp_info     other_imports =-#if MIN_VERSION_ghc(9,4,0)-      -- On 9.4+ instead of bringing all the units into scope, only bring into scope the units-      -- this one depends on+      -- Instead of bringing all the units into scope, only bring into scope the units+      -- this one depends on.       -- This way if you have multiple units with the same module names, we won't get confused       -- For example if unit a imports module M from unit B, when there is also a module M in unit C,       -- and unit a only depends on unit b, without this logic there is the potential to get confused       -- about which module unit a imports.       -- Without multi-component support it is hard to recontruct the dependency environment so       -- unit a will have both unit b and unit c in scope.-      map (\uid -> (uid, importPaths (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps+#if MIN_VERSION_ghc(9,11,0)+      map (\uid -> let this_df = homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue) in (uid, importPaths this_df, S.fromList $ map reexportTo $ reexportedModules this_df)) hpt_deps+#else+      map (\uid -> let this_df = homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue) in (uid, importPaths this_df, reexportedModules this_df)) hpt_deps+#endif     ue = hsc_unit_env env     units = homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId_ dflags) ue     hpt_deps :: [UnitId]     hpt_deps = homeUnitDepends units-#else-      _import_paths'-#endif -      -- 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.-    _import_paths' = -- import_paths' is only used in GHC < 9.4-#if MIN_VERSION_ghc(9,3,0)-            import_paths-#else-            map snd import_paths-#endif-     toModLocation uid file = liftIO $ do         loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)         let genMod = mkModule (RealUnit $ Definite uid) (unLoc modName)  -- TODO support backpack holes         return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) (Just genMod) -    lookupLocal uid dirs = do-      mbFile <- locateModuleFile [(uid, dirs)] exts targetFor isSource $ unLoc modName+    lookupLocal uid dirs reexports = do+      mbFile <- locateModuleFile [(uid, dirs, reexports)] exts targetFor isSource $ unLoc modName       case mbFile of-        Nothing   -> return $ Left $ notFoundErr env modName $ LookupNotFound []-        Just (uid', file) -> toModLocation uid' file+        LocateNotFound -> return $ Left $ notFoundErr env modName $ LookupNotFound []+        -- Lookup again with the perspective of the unit reexporting the file+        LocateFoundReexport uid' -> locateModule (hscSetActiveUnitId uid' env) comp_info exts targetFor modName noPkgQual isSource+        LocateFoundFile uid' file -> toModLocation uid' file      lookupInPackageDB = do       case Compat.lookupModuleWithSuggestions env (unLoc modName) mbPkgName of@@ -203,7 +187,7 @@   mkError' $ ppr' $ cannotFindModule env modName0 $ lookupToFindResult reason   where     dfs = hsc_dflags env-    mkError' = diagFromString "not found" DiagnosticSeverity_Error (Compat.getLoc modName)+    mkError' doc = diagFromString "not found" DiagnosticSeverity_Error (Compat.getLoc modName) doc Nothing     modName0 = unLoc modName     ppr' = showSDoc dfs     -- We convert the lookup result to a find result to reuse GHC's cannotFindModule pretty printer.@@ -219,7 +203,11 @@              }         LookupUnusable unusable ->           let unusables' = map get_unusable unusable+#if MIN_VERSION_ghc(9,6,4) && (!MIN_VERSION_ghc(9,8,1) || MIN_VERSION_ghc(9,8,2))+              get_unusable (_m, ModUnusable r) = r+#else               get_unusable (m, ModUnusable r) = (moduleUnit m, r)+#endif               get_unusable (_, r) =                 pprPanic "findLookupResult: unexpected origin" (ppr r)            in notFound {fr_unusables = unusables'}@@ -235,3 +223,6 @@   , fr_unusables = []   , fr_suggestions = []   }++noPkgQual :: PkgQual+noPkgQual = NoPkgQual
src/Development/IDE/LSP/HoverDefinition.hs view
@@ -1,15 +1,16 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0-{-# LANGUAGE GADTs      #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}  -- | Display information on hover. module Development.IDE.LSP.HoverDefinition-    (+    ( Log(..)     -- * For haskell-language-server-    hover+    , hover+    , foundHover     , gotoDefinition     , gotoTypeDefinition+    , gotoImplementation     , documentHighlight     , references     , wsSymbols@@ -19,38 +20,51 @@ import           Control.Monad.IO.Class import           Data.Maybe                     (fromMaybe) import           Development.IDE.Core.Actions-import           Development.IDE.Core.Rules-import           Development.IDE.Core.Shake+import qualified Development.IDE.Core.Rules     as Shake+import           Development.IDE.Core.Shake     (IdeAction, IdeState (..),+                                                 runIdeAction) import           Development.IDE.Types.Location import           Ide.Logger import           Ide.Plugin.Error import           Ide.Types import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types-import qualified Language.LSP.Server            as LSP  import qualified Data.Text                      as T -gotoDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentDefinition)-hover          :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (Hover |? Null)-gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentTypeDefinition)-documentHighlight :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) ([DocumentHighlight] |? Null)-gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR)-gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR)++data Log+  = LogWorkspaceSymbolRequest !T.Text+  | LogRequest !T.Text !Position !NormalizedFilePath+  deriving (Show)++instance Pretty Log where+  pretty = \case+    LogWorkspaceSymbolRequest query -> "Workspace symbols request:" <+> pretty query+    LogRequest label pos nfp ->+      pretty label <+> "request at position" <+> pretty (showPosition pos) <+>+        "in file:" <+> pretty (fromNormalizedFilePath nfp)++gotoDefinition     :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentDefinition)+hover              :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (Hover |? Null)+gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentTypeDefinition)+gotoImplementation :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentImplementation)+documentHighlight  :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) ([DocumentHighlight] |? Null)+gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition . InR . map fst)+gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition . InR . map fst)+gotoImplementation = request "Implementation" getImplementationDefinition (InR $ InR Null) (InL . Definition . InR) hover          = request "Hover"      getAtPoint     (InR Null)     foundHover documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL -references :: PluginMethodHandler IdeState Method_TextDocumentReferences-references ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do+references :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentReferences+references recorder ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do   nfp <- getNormalizedFilePathE uri-  liftIO $ logDebug (ideLogger ide) $-        "References request at position " <> T.pack (showPosition pos) <>-        " in file: " <> T.pack (show nfp)-  InL <$> (liftIO $ runAction "references" ide $ refsAtPoint nfp pos)+  liftIO $ logWith recorder Debug $ LogRequest "References" pos nfp+  InL <$> (liftIO $ Shake.runAction "references" ide $ refsAtPoint nfp pos) -wsSymbols :: PluginMethodHandler IdeState Method_WorkspaceSymbol-wsSymbols ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do-  logDebug (ideLogger ide) $ "Workspace symbols request: " <> query+wsSymbols :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_WorkspaceSymbol+wsSymbols recorder ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do+  logWith recorder Debug $ LogWorkspaceSymbolRequest query   runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ InL . fromMaybe [] <$> workspaceSymbols query  foundHover :: (Maybe Range, [T.Text]) -> Hover |? Null@@ -63,19 +77,18 @@   -> (NormalizedFilePath -> Position -> IdeAction (Maybe a))   -> b   -> (a -> b)+  -> Recorder (WithPriority Log)   -> IdeState   -> TextDocumentPositionParams-  -> ExceptT PluginError (LSP.LspM c) b-request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do+  -> ExceptT PluginError (HandlerM c) b+request label getResults notFound found recorder ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do     mbResult <- case uriToFilePath' uri of-        Just path -> logAndRunRequest label getResults ide pos path+        Just path -> logAndRunRequest recorder label getResults ide pos path         Nothing   -> pure Nothing     pure $ maybe notFound found mbResult -logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b-logAndRunRequest label getResults ide pos path = do+logAndRunRequest :: Recorder (WithPriority Log) -> T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b+logAndRunRequest recorder 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+  logWith recorder Debug $ LogRequest label pos filePath   runIdeAction (T.unpack label) (shakeExtras ide) (getResults filePath pos)
src/Development/IDE/LSP/LanguageServer.hs view
@@ -1,18 +1,18 @@-      -- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE DuplicateRecordFields     #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE PolyKinds                 #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE StarIsType                #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs                 #-} -- 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     , setupLSP     , Log(..)+    , ThreadQueue+    , runWithWorkerThreads+    , Setup (..)+    , ServerLifecycleContext (..)     ) where  import           Control.Concurrent.STM@@ -36,17 +36,26 @@ import           UnliftIO.Exception  import qualified Colog.Core                            as Colog+import           Control.Concurrent.Extra              (newBarrier,+                                                        signalBarrier,+                                                        waitBarrier) import           Control.Monad.IO.Unlift               (MonadUnliftIO)+import           Control.Monad.Trans.Cont              (ContT (..), evalContT)+import           Data.Foldable                         (traverse_) import           Development.IDE.Core.IdeConfiguration-import           Development.IDE.Core.Shake            hiding (Log, Priority)+import           Development.IDE.Core.Service          (shutdown)+import           Development.IDE.Core.Shake            hiding (Log) import           Development.IDE.Core.Tracing+import           Development.IDE.Core.WorkerThread import qualified Development.IDE.Session               as Session-import           Development.IDE.Types.Shake           (WithHieDb)+import           Development.IDE.Types.Shake           (WithHieDb,+                                                        WithHieDbShield (..)) import           Ide.Logger import           Language.LSP.Server                   (LanguageContextEnv,                                                         LspServerLog,                                                         type (<~>))-import           System.IO.Unsafe                      (unsafeInterleaveIO)+import           System.Timeout                        (timeout)+ data Log   = LogRegisteringIdeConfig !IdeConfiguration   | LogReactorThreadException !SomeException@@ -55,10 +64,26 @@   | LogCancelledRequest !SomeLspId   | LogSession Session.Log   | LogLspServer LspServerLog+  | LogReactorShutdownRequested Bool+  | LogShutDownTimeout Int+  | LogServerExitWith (Either () Int)+  | LogReactorShutdownConfirmed !T.Text   deriving Show  instance Pretty Log where   pretty = \case+    LogReactorShutdownRequested b ->+      "Requested reactor shutdown; stop signal posted: " <+> pretty b+    LogReactorShutdownConfirmed msg ->+      "Reactor shutdown confirmed: " <+> pretty msg+    LogServerExitWith (Right 0) ->+      "Server exited successfully"+    LogServerExitWith (Right code) ->+      "Server exited with failure code" <+> pretty code+    LogServerExitWith (Left ()) ->+      "Server forcefully exited due to exception in reactor thread"+    LogShutDownTimeout seconds ->+      "Shutdown timeout, the server will exit now after waiting for" <+> pretty seconds  <+> "seconds"     LogRegisteringIdeConfig ideConfig ->       -- This log is also used to identify if HLS starts successfully in vscode-haskell,       -- don't forget to update the corresponding test in vscode-haskell if the text in@@ -79,9 +104,44 @@     LogSession msg -> pretty msg     LogLspServer msg -> pretty msg --- used to smuggle RankNType WithHieDb through dbMVar-newtype WithHieDbShield = WithHieDbShield WithHieDb+-- | Context of the LSP language server.+-- This record encapsulates all the configuration and callback functions+-- needed to set up and run the language server initialization process.+data ServerLifecycleContext config = ServerLifecycleContext+  { ctxRecorder :: Recorder (WithPriority Log)+    -- ^ Logger for recording server events and diagnostics+  , ctxDefaultRoot :: FilePath+    -- ^ Default root directory for the workspace, see Note [Root Directory]+  , ctxGetHieDbLoc :: FilePath -> IO FilePath+    -- ^ Function to determine the HIE database location for a given root path+  , ctxGetIdeState :: LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState+    -- ^ Function to create and initialize the IDE state with the given environment+  , ctxUntilReactorStopSignal :: IO () -> IO ()+    -- ^ Lifetime control: MVar to signal reactor shutdown+  , ctxConfirmReactorShutdown :: T.Text -> IO ()+    -- ^ Callback to log/confirm reactor shutdown with a reason+  , ctxForceShutdown :: IO ()+    -- ^ Action to forcefully exit the server when exception occurs+  , ctxClearReqId :: SomeLspId -> IO ()+    -- ^ Function to clear/cancel a request by its ID+  , ctxWaitForCancel :: SomeLspId -> IO ()+    -- ^ Function to wait for a request cancellation by its ID+  , ctxClientMsgChan :: Chan ReactorMessage+    -- ^ Channel for communicating with the reactor message loop+  } +data Setup config m a+  = MkSetup+  { doInitialize :: LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) (LSP.LanguageContextEnv config, a))+  -- ^ the callback invoked when the language server receives the 'Method_Initialize' request+  , staticHandlers :: LSP.Handlers m+  -- ^ the statically known handlers of the lsp server+  , interpretHandler :: (LanguageContextEnv config, a) -> m <~> IO+  -- ^ how to interpret @m@ to 'IO' and how to lift 'IO' into @m@+  , onExit :: [IO ()]+  -- ^ a list of 'IO' actions that clean up resources and must be run when the server shuts down+  }+ runLanguageServer     :: forall config a m. (Show config)     => Recorder (WithPriority Log)@@ -90,18 +150,16 @@     -> Handle -- output     -> config     -> (config -> Value -> Either T.Text config)-    -> (config -> m config ())-    -> (MVar ()-        -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv config, a)),-               LSP.Handlers (m config),-               (LanguageContextEnv config, a) -> m config <~> IO))+    -> (config -> m ())+    -> (MVar () -> IO (Setup config m a))     -> IO () runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigChange setup = do     -- This MVar becomes full when the server thread exits or we receive exit message from client.     -- LSP server will be canceled when it's full.     clientMsgVar <- newEmptyMVar -    (doInitialize, staticHandlers, interpretHandler) <- setup clientMsgVar+    MkSetup+      { doInitialize, staticHandlers, interpretHandler, onExit } <- setup clientMsgVar      let serverDefinition = LSP.ServerDefinition             { LSP.parseConfig = parseConfig@@ -110,41 +168,56 @@             -- TODO: magic string             , LSP.configSection = "haskell"             , LSP.doInitialize = doInitialize-            , LSP.staticHandlers = (const staticHandlers)+            , LSP.staticHandlers = const staticHandlers             , LSP.interpretHandler = interpretHandler             , LSP.options = modifyOptions options             } -    let lspCologAction :: MonadIO m2 => Colog.LogAction m2 (Colog.WithSeverity LspServerLog)+    let lspCologAction :: forall io. MonadIO io => Colog.LogAction io (Colog.WithSeverity LspServerLog)         lspCologAction = toCologActionWithPrio (cmapWithPrio LogLspServer recorder) -    void $ untilMVar clientMsgVar $-          void $ LSP.runServerWithHandles+    let runServer =+          LSP.runServerWithHandles             lspCologAction             lspCologAction             inH             outH             serverDefinition +    untilMVar' clientMsgVar runServer `finally` sequence_ onExit+        >>= logWith recorder Info . LogServerExitWith+ setupLSP ::-     forall config err.+     forall config.      Recorder (WithPriority Log)+  -> FilePath -- ^ root directory, see Note [Root Directory]   -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project   -> LSP.Handlers (ServerM config)-  -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)+  -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState)   -> MVar ()-  -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)),-         LSP.Handlers (ServerM config),-         (LanguageContextEnv config, IdeState) -> ServerM config <~> IO)-setupLSP  recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do+  -> IO (Setup config (ServerM config) IdeState)+setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar = do   -- Send everything over a channel, since you need to wait until after initialise before   -- LspFuncs is available   clientMsgChan :: Chan ReactorMessage <- newChan    -- An MVar to control the lifetime of the reactor loop.   -- The loop will be stopped and resources freed when it's full-  reactorLifetime <- newEmptyMVar-  let stopReactorLoop = void $ tryPutMVar reactorLifetime ()+  reactorStopSignal <- newEmptyMVar+  reactorConfirmBarrier <- newBarrier+  let+    untilReactorStopSignal = untilMVar reactorStopSignal+    confirmReactorShutdown reason = do+      logWith recorder Debug $ LogReactorShutdownConfirmed reason+      signalBarrier reactorConfirmBarrier ()+    requestReactorShutdown = do+      k <- tryPutMVar reactorStopSignal ()+      logWith recorder Info $ LogReactorShutdownRequested k+      let timeOutSeconds = 2+      timeout (timeOutSeconds * 1_000_000) (waitBarrier reactorConfirmBarrier) >>= \case+        Just () -> pure ()+        -- If we don't get confirmation within 2 seconds, we log a warning and shutdown anyway.+        Nothing -> logWith recorder Warning $ LogShutDownTimeout timeOutSeconds    -- Forcefully exit   let exit = void $ tryPutMVar clientMsgVar ()@@ -159,7 +232,7 @@           -- 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) $+          when (reqId `Set.member` queued) $               modifyTVar cancelledRequests (Set.insert reqId)   let clearReqId reqId = atomically $ do           modifyTVar pendingRequests (Set.delete reqId)@@ -170,94 +243,139 @@           cancelled <- readTVar cancelledRequests           unless (reqId `Set.member` cancelled) retry -  let asyncHandlers = mconcat+  let staticHandlers = mconcat         [ userHandlers         , cancelHandler cancelRequest-        , exitHandler exit-        , shutdownHandler stopReactorLoop+        , shutdownHandler recorder requestReactorShutdown         ]         -- Cancel requests are special since they need to be handled         -- out of order to be useful. Existing handlers are run afterwards. -  let doInitialize = handleInit recorder getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan+  let lifecycleCtx = ServerLifecycleContext+        { ctxRecorder = recorder+        , ctxDefaultRoot = defaultRoot+        , ctxGetHieDbLoc = getHieDbLoc+        , ctxGetIdeState = getIdeState+        , ctxUntilReactorStopSignal = untilReactorStopSignal+        , ctxConfirmReactorShutdown = confirmReactorShutdown+        , ctxForceShutdown = exit+        , ctxClearReqId = clearReqId+        , ctxWaitForCancel = waitForCancel+        , ctxClientMsgChan = clientMsgChan+        } +  let doInitialize = handleInit lifecycleCtx+   let interpretHandler (env,  st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO+  let onExit = [void $ tryPutMVar reactorStopSignal ()] -  pure (doInitialize, asyncHandlers, interpretHandler)+  pure MkSetup {doInitialize, staticHandlers, interpretHandler, onExit}   handleInit-    :: Recorder (WithPriority Log)-    -> (FilePath -> IO FilePath)-    -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)-    -> MVar ()-    -> IO ()-    -> (SomeLspId -> IO ())-    -> (SomeLspId -> IO ())-    -> Chan ReactorMessage+    :: ServerLifecycleContext config     -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))-handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do+handleInit lifecycleCtx env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do     traceWithSpan sp params-    let root = LSP.resRootPath env-    dir <- maybe getCurrentDirectory return root-    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-    ~(WithHieDbShield withHieDb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar--    ide <- getIdeState env root withHieDb hieChan-+  -- only shift if lsp root is different from the rootDir+  -- see Note [Root Directory]+    let+      recorder = ctxRecorder lifecycleCtx+      defaultRoot = ctxDefaultRoot lifecycleCtx+      untilReactorStopSignal = ctxUntilReactorStopSignal lifecycleCtx+      lifetimeConfirm = ctxConfirmReactorShutdown lifecycleCtx+    root <- case LSP.resRootPath env of+      Just lspRoot | lspRoot /= defaultRoot -> setCurrentDirectory lspRoot >> return lspRoot+      _ -> pure defaultRoot+    dbLoc <- ctxGetHieDbLoc lifecycleCtx root     let initConfig = parseConfiguration params-     logWith recorder Info $ LogRegisteringIdeConfig initConfig-    registerIdeConfiguration (shakeExtras ide) initConfig+    ideMVar <- newEmptyMVar -    let handleServerException (Left e) = do+    let+      loggedTeardown me = do+        -- shutdown shake+        case me of+          Left e -> do+            lifetimeConfirm "due to exception in reactor thread"             logWith recorder Error $ LogReactorThreadException e-            exitClientMsg-        handleServerException (Right _) = pure ()+            ctxForceShutdown lifecycleCtx+          _ -> do+            lifetimeConfirm "due to shutdown message"+            return () -        exceptionInHandler e = do-            logWith recorder Error $ LogReactorMessageActionException e+      exceptionInHandler e = do+        logWith recorder Error $ LogReactorMessageActionException e -        checkCancelled _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-                            logWith recorder Debug $ LogCancelledRequest _id-                            k $ ResponseError (InL LSPErrorCodes_RequestCancelled) "" Nothing-                        Right res -> pure res-                ) $ \(e :: SomeException) -> do+      checkCancelled :: forall m . LspId m -> IO () -> (TResponseError m -> IO ()) -> IO ()+      checkCancelled _id act k =+        let sid = SomeLspId _id+         in flip finally (ctxClearReqId lifecycleCtx sid) $+              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 (ctxWaitForCancel lifecycleCtx sid) act+                  case cancelOrRes of+                    Left () -> do+                      logWith recorder Debug $ LogCancelledRequest sid+                      k $ TResponseError (InL LSPErrorCodes_RequestCancelled) "" Nothing+                    Right res -> pure res+                )+                $ \(e :: SomeException) -> do                     exceptionInHandler e-                    k $ ResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing-    _ <- flip forkFinally handleServerException $ do-        untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' hieChan' -> do-            putMVar dbMVar (WithHieDbShield withHieDb',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 -> handle exceptionInHandler act-                    ReactorRequest _id act k -> void $ async $ checkCancelled _id act k-        logWith recorder Info LogReactorThreadStopped+                    k $ TResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing+    _ <- flip forkFinally loggedTeardown $ do+      -- Need to be careful about when the shutdown occurs, it needs to be shut+      -- down after the session loader and restarting threads, and before the+      -- hiedb connections are closed.+      let shutdownSession = tryReadMVar ideMVar >>= traverse_ shutdown+      runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc shutdownSession $ \withHieDb' threadQueue' -> do+        ide <- ctxGetIdeState lifecycleCtx env root withHieDb' threadQueue'+        putMVar ideMVar ide+        -- Keep this after putMVar ideMVar ide; otherwise shutdown during+        -- initialization could leave handleInit blocked indefinitely on readMVar.+        untilReactorStopSignal $ forever $ do+          msg <- readChan $ ctxClientMsgChan lifecycleCtx+          -- 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  -> handle exceptionInHandler act+            ReactorRequest _id act k -> void $ async $ checkCancelled _id act k+      logWith recorder Info LogReactorThreadStopped++    ide <- readMVar ideMVar+    registerIdeConfiguration (shakeExtras ide) initConfig     pure $ Right (env,ide)  +-- | runWithWorkerThreads+-- create several threads to run the session, db and session loader+-- see Note [Serializing runs in separate thread]+runWithWorkerThreads :: Recorder (WithPriority Session.Log) -> FilePath -> IO () -> (WithHieDb -> ThreadQueue -> IO ()) -> IO ()+runWithWorkerThreads recorder dbLoc shutdownSession f = evalContT $ do+  (WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc+  -- The shake session needs to be shut down prior to the hiedb connections+  -- being cleaned up, otherwise shake could be referencing dead connections.+  -- This is passed in via the callsites.+  ContT $ \action -> action () `finally` shutdownSession+  sessionRestartTQueue <- withWorkerQueueSimple (cmapWithPrio Session.LogSessionWorkerThread recorder) "RestartTQueue"+  sessionLoaderTQueue <- withWorkerQueueSimple (cmapWithPrio Session.LogSessionWorkerThread recorder) "SessionLoaderTQueue"+  liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue)+ -- | Runs the action until it ends or until the given MVar is put.+--   It is important, that the thread that puts the 'MVar' is not dropped before it puts the 'MVar' i.e. it should+--   occur as the final action in a 'finally' or 'bracket', because otherwise this thread will finish early (as soon+--   as the thread receives the BlockedIndefinitelyOnMVar exception) --   Rethrows any exceptions.-untilMVar :: MonadUnliftIO m => MVar () -> m () -> m ()-untilMVar mvar io = void $-    waitAnyCancel =<< traverse async [ io , readMVar mvar ]+untilMVar :: MonadUnliftIO m => MVar () -> m a -> m ()+untilMVar mvar io = race_ (readMVar mvar) io +untilMVar' :: MonadUnliftIO m => MVar a -> m b -> m (Either a b)+untilMVar' mvar io = race (readMVar mvar) io+ cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \TNotificationMessage{_params=CancelParams{_id}} ->   liftIO $ cancelRequest (SomeLspId (toLspId _id))@@ -265,19 +383,12 @@         toLspId (InL x) = IdInt x         toLspId (InR y) = IdString y -shutdownHandler :: IO () -> LSP.Handlers (ServerM c)-shutdownHandler stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do-    (_, ide) <- ask-    liftIO $ logDebug (ideLogger ide) "Received shutdown message"-    -- stop the reactor to free up the hiedb connection-    liftIO stopReactor-    -- flush out the Shake session to record a Shake profile if applicable-    liftIO $ shakeShut ide+shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM c)+shutdownHandler _recorder requestReactorShutdown = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do+    -- stop the reactor to free up the hiedb connection and shut down shake+    liftIO requestReactorShutdown     resp $ Right Null -exitHandler :: IO () -> LSP.Handlers (ServerM c)-exitHandler exit = LSP.notificationHandler SMethod_Exit $ const $ liftIO exit- modifyOptions :: LSP.Options -> LSP.Options modifyOptions x = x{ LSP.optTextDocumentSync   = Just $ tweakTDS origTDS                    }@@ -285,4 +396,3 @@         tweakTDS tds = tds{_openClose=Just True, _change=Just TextDocumentSyncKind_Incremental, _save=Just $ InR $ SaveOptions Nothing}         origTDS = fromMaybe tdsDefault $ LSP.optTextDocumentSync x         tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing-
src/Development/IDE/LSP/Notifications.hs view
@@ -3,8 +3,6 @@  {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs                 #-}-{-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE RankNTypes            #-}  module Development.IDE.LSP.Notifications     ( whenUriFile@@ -33,7 +31,7 @@ import           Development.IDE.Core.IdeConfiguration import           Development.IDE.Core.OfInterest       hiding (Log, LogShake) import           Development.IDE.Core.Service          hiding (Log, LogShake)-import           Development.IDE.Core.Shake            hiding (Log, Priority)+import           Development.IDE.Core.Shake            hiding (Log) import qualified Development.IDE.Core.Shake            as Shake import           Development.IDE.Types.Location import           Ide.Logger@@ -43,51 +41,63 @@ data Log   = LogShake Shake.Log   | LogFileStore FileStore.Log+  | LogOpenedTextDocument !Uri+  | LogModifiedTextDocument !Uri+  | LogSavedTextDocument !Uri+  | LogClosedTextDocument !Uri+  | LogWatchedFileEvents !Text.Text+  | LogWarnNoWatchedFilesSupport   deriving Show  instance Pretty Log where   pretty = \case     LogShake msg     -> pretty msg     LogFileStore msg -> pretty msg+    LogOpenedTextDocument uri ->  "Opened text document:" <+> pretty (getUri uri)+    LogModifiedTextDocument uri -> "Modified text document:" <+> pretty (getUri uri)+    LogSavedTextDocument uri -> "Saved text document:" <+> pretty (getUri uri)+    LogClosedTextDocument uri -> "Closed text document:" <+> pretty (getUri uri)+    LogWatchedFileEvents msg -> "Watched file events:" <+> pretty msg+    LogWarnNoWatchedFilesSupport -> "Client does not support watched files. Falling back to OS polling"  whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath'  descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState-descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = mconcat+descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificationHandlers = mconcat   [ mkPluginNotificationHandler LSP.SMethod_TextDocumentDidOpen $       \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do       atomically $ updatePositionMapping ide (VersionedTextDocumentIdentifier _uri _version) []       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-          addFileOfInterest ide file Modified{firstOpen=True}-          setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file-          logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri+          setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file $+            addFileOfInterest ide file Modified{firstOpen=True}+      logWith recorder Debug $ LogOpenedTextDocument _uri    , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $       \ide vfs _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do         atomically $ updatePositionMapping ide identifier changes         whenUriFile _uri $ \file -> do-          addFileOfInterest ide file Modified{firstOpen=False}-          setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file-        logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri+          setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file $+            addFileOfInterest ide file Modified{firstOpen=False}+        logWith recorder Debug $ LogModifiedTextDocument _uri    , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $       \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do         whenUriFile _uri $ \file -> do-            addFileOfInterest ide file OnDisk-            setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file-        logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri+            setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file $+                addFileOfInterest ide file OnDisk+        logWith recorder Debug $ LogSavedTextDocument _uri    , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $         \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do           whenUriFile _uri $ \file -> do-              deleteFileOfInterest ide file               let msg = "Closed text document: " <> getUri _uri-              scheduleGarbageCollection ide-              setSomethingModified (VFSModified vfs) ide [] $ Text.unpack msg-              logDebug (ideLogger ide) msg+              setSomethingModified (VFSModified vfs) ide (Text.unpack msg) $ do+                scheduleGarbageCollection ide+                deleteFileOfInterest ide file+              logWith recorder Debug $ LogClosedTextDocument _uri    , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWatchedFiles $       \ide vfs _ (DidChangeWatchedFilesParams fileEvents) -> liftIO $ do@@ -104,10 +114,11 @@                 ]         unless (null fileEvents') $ do             let msg = show fileEvents'-            logDebug (ideLogger ide) $ "Watched file events: " <> Text.pack msg-            modifyFileExists ide fileEvents'-            resetFileStore ide fileEvents'-            setSomethingModified (VFSModified vfs) ide [] msg+            logWith recorder Debug $ LogWatchedFileEvents (Text.pack msg)+            setSomethingModified (VFSModified vfs) ide msg $ do+                ks1 <- resetFileStore ide fileEvents'+                ks2 <- modifyFileExists ide fileEvents'+                return (ks1 <> ks2)    , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWorkspaceFolders $       \ide _ _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do@@ -135,13 +146,15 @@       let globs = watchedGlobs opts       success <- registerFileWatches globs       unless success $-        liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling"+        liftIO $ logWith recorder Warning LogWarnNoWatchedFilesSupport   ],      -- The ghcide descriptors should come last'ish so that the notification handlers     -- (which restart the Shake build) run after everything else         pluginPriority = ghcideNotificationsPluginPriority     }+  where+    desc = "Handles basic notifications for ghcide"  ghcideNotificationsPluginPriority :: Natural ghcideNotificationsPluginPriority = defaultPluginPriority - 900
src/Development/IDE/LSP/Outline.hs view
@@ -2,7 +2,6 @@  {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs                 #-}-{-# LANGUAGE RankNTypes            #-}  module Development.IDE.LSP.Outline   ( moduleOutline@@ -10,33 +9,28 @@ where  import           Control.Monad.IO.Class+import           Data.Foldable                  (toList) import           Data.Functor import           Data.Generics                  hiding (Prefix)+import           Data.List.NonEmpty             (nonEmpty) import           Data.Maybe import           Development.IDE.Core.Rules import           Development.IDE.Core.Shake import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Error      (rangeToRealSrcSpan,                                                  realSrcSpanToRange)-import           Development.IDE.Types.Location import           Development.IDE.GHC.Util       (printOutputable)+import           Development.IDE.Types.Location import           Ide.Types-import           Language.LSP.Protocol.Types             (DocumentSymbol (..),+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types    (DocumentSymbol (..),                                                  DocumentSymbolParams (DocumentSymbolParams, _textDocument),                                                  SymbolKind (..),                                                  TextDocumentIdentifier (TextDocumentIdentifier),-                                                 type (|?) (InL, InR), uriToFilePath)-import          Language.LSP.Protocol.Message+                                                 type (|?) (InL, InR),+                                                 uriToFilePath) --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -import           Data.List.NonEmpty             (nonEmpty)-import           Data.Foldable                  (toList)--#if !MIN_VERSION_ghc(9,3,0)-import qualified Data.Text                      as T-#endif- moduleOutline   :: PluginMethodHandler IdeState Method_TextDocumentDocumentSymbol moduleOutline ideState _ DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri }@@ -120,21 +114,13 @@         , L (locA -> RealSrcSpan l' _) n <- cs         , let l'' = case con of                 L (locA -> RealSrcSpan l''' _) _ -> l'''-                _ -> l'+                _                                -> l'         ]     }   where     cvtFld :: LFieldOcc GhcPs -> Maybe DocumentSymbol-#if MIN_VERSION_ghc(9,3,0)     cvtFld (L (locA -> RealSrcSpan l' _) n) = Just $ (defDocumentSymbol l' :: DocumentSymbol)-#else-    cvtFld (L (RealSrcSpan l' _) n) = Just $ (defDocumentSymbol l' :: DocumentSymbol)-#endif-#if MIN_VERSION_ghc(9,3,0)                 { _name = printOutputable (unLoc (foLabel n))-#else-                { _name = printOutputable (unLoc (rdrNameFieldOcc n))-#endif                 , _kind = SymbolKind_Field                 }     cvtFld _  = Nothing@@ -150,23 +136,13 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl FamEqn { feqn_tycon, feqn_pats } }))   = Just (defDocumentSymbol l :: DocumentSymbol)     { _name =-#if MIN_VERSION_ghc(9,3,0)-        printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix (feqn_pats)-#else-        printOutputable (unLoc feqn_tycon) <> " " <> T.unwords-                (map printOutputable feqn_pats)-#endif+        printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix feqn_pats     , _kind = SymbolKind_Interface     } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl _ FamEqn { feqn_tycon, feqn_pats } }))   = Just (defDocumentSymbol l :: DocumentSymbol)     { _name =-#if MIN_VERSION_ghc(9,3,0)-        printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix (feqn_pats)-#else-        printOutputable (unLoc feqn_tycon) <> " " <> T.unwords-                (map printOutputable feqn_pats)-#endif+        printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix feqn_pats     , _kind = SymbolKind_Interface     } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (DerivD _ DerivDecl { deriv_type })) =@@ -191,12 +167,10 @@     { _name   = case x of                   ForeignImport{} -> name                   ForeignExport{} -> name-                  XForeignDecl{}  -> "?"     , _kind   = SymbolKind_Object     , _detail = case x of                   ForeignImport{} -> Just "import"                   ForeignExport{} -> Just "export"-                  XForeignDecl{}  -> Nothing     }   where name = printOutputable $ unLoc $ fd_name x @@ -271,19 +245,25 @@     get_flds_h98 :: HsConDeclH98Details GhcPs                  -> [LFieldOcc GhcPs]     get_flds_h98 (RecCon flds) = get_flds (reLoc flds)-    get_flds_h98 _ = []+    get_flds_h98 _             = []      get_flds_gadt :: HsConDeclGADTDetails GhcPs-                  -> ([LFieldOcc GhcPs])-#if MIN_VERSION_ghc(9,3,0)-    get_flds_gadt (RecConGADT flds _) = get_flds (reLoc flds)+                  -> [LFieldOcc GhcPs]+#if MIN_VERSION_ghc(9,9,0)+    get_flds_gadt (RecConGADT _ flds) = get_flds (reLoc flds) #else-    get_flds_gadt (RecConGADT flds) = get_flds (reLoc flds)+    get_flds_gadt (RecConGADT flds _) = get_flds (reLoc flds) #endif-    get_flds_gadt _ = []+    get_flds_gadt _                   = [] +#if MIN_VERSION_ghc(9,13,0)+    get_flds :: Located [LHsConDeclRecField GhcPs]+             -> [LFieldOcc GhcPs]+    get_flds flds = concatMap (cdrf_names . unLoc) (unLoc flds)+#else     get_flds :: Located [LConDeclField GhcPs]-             -> ([LFieldOcc GhcPs])+             -> [LFieldOcc GhcPs]     get_flds flds = concatMap (cd_fld_names . unLoc) (unLoc flds)+#endif
src/Development/IDE/LSP/Server.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE UndecidableInstances #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0@@ -23,7 +22,7 @@  data ReactorMessage   = ReactorNotification (IO ())-  | ReactorRequest SomeLspId (IO ()) (ResponseError -> IO ())+  | forall m . ReactorRequest (LspId m) (IO ()) (TResponseError m -> IO ())  type ReactorChan = Chan ReactorMessage newtype ServerM c a = ServerM { unServerM :: ReaderT (ReactorChan, IdeState) (LspM c) a }@@ -32,17 +31,17 @@ requestHandler   :: forall m c. PluginMethod Request m =>      SMethod m-  -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (MessageResult m)))+  -> (IdeState -> MessageParams m -> LspM c (Either (TResponseError m) (MessageResult m)))   -> Handlers (ServerM c) requestHandler m k = LSP.requestHandler m $ \TRequestMessage{_method,_id,_params} resp -> do   st@(chan,ide) <- ask   env <- LSP.getLspEnv-  let resp' :: Either ResponseError (MessageResult m) -> LspM c ()+  let resp' :: Either (TResponseError m) (MessageResult m) -> LspM c ()       resp' = flip (runReaderT . unServerM) 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)+  writeChan chan $ ReactorRequest _id (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left)  notificationHandler   :: forall m c. PluginMethod Notification m =>
src/Development/IDE/Main.hs view
@@ -1,5 +1,4 @@ {-# OPTIONS_GHC -Wno-orphans #-}-{-# LANGUAGE RankNTypes #-} module Development.IDE.Main (Arguments(..) ,defaultArguments@@ -13,19 +12,16 @@ ) where  import           Control.Concurrent.Extra                 (withNumCapabilities)-import           Control.Concurrent.MVar                  (newEmptyMVar,+import           Control.Concurrent.MVar                  (MVar, newEmptyMVar,                                                            putMVar, tryReadMVar) import           Control.Concurrent.STM.Stats             (dumpSTMStats)-import           Control.Exception.Safe                   (SomeException,-                                                           catchAny,-                                                           displayException)+import           Control.Exception.Safe                   as Safe import           Control.Monad.Extra                      (concatMapM, unless,                                                            when) import           Control.Monad.IO.Class                   (liftIO) import qualified Data.Aeson                               as J import           Data.Coerce                              (coerce) import           Data.Default                             (Default (def))-import           Data.Foldable                            (traverse_) import           Data.Hashable                            (hashed) import qualified Data.HashMap.Strict                      as HashMap import           Data.List.Extra                          (intercalate,@@ -34,9 +30,8 @@ import           Data.Maybe                               (catMaybes, isJust) import qualified Data.Text                                as T import           Development.IDE                          (Action,-                                                           Priority (Debug, Error),-                                                           Rules, emptyFilePath,-                                                           hDuplicateTo')+                                                           Priority (Debug),+                                                           Rules, hDuplicateTo') import           Development.IDE.Core.Debouncer           (Debouncer,                                                            newAsyncDebouncer) import           Development.IDE.Core.FileStore           (isWatchSupported,@@ -56,17 +51,17 @@                                                            runAction) import qualified Development.IDE.Core.Service             as Service import           Development.IDE.Core.Shake               (IdeState (shakeExtras),-                                                           IndexQueue,+                                                           ThreadQueue (tLoaderQueue),                                                            shakeSessionInit,                                                            uses) import qualified Development.IDE.Core.Shake               as Shake import           Development.IDE.Graph                    (action) import           Development.IDE.LSP.LanguageServer       (runLanguageServer,+                                                           runWithWorkerThreads,                                                            setupLSP) import qualified Development.IDE.LSP.LanguageServer       as LanguageServer import           Development.IDE.Main.HeapStats           (withHeapStats) import qualified Development.IDE.Main.HeapStats           as HeapStats-import qualified Development.IDE.Monitoring.EKG           as EKG import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry import           Development.IDE.Plugin                   (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) import           Development.IDE.Plugin.HLS               (asGhcIdePlugin)@@ -75,10 +70,9 @@ import qualified Development.IDE.Plugin.Test              as Test import           Development.IDE.Session                  (SessionLoadingOptions,                                                            getHieDbLoc,+                                                           getInitialGhcLibDirDefault,                                                            loadSessionWithOptions,-                                                           retryOnSqliteBusy,-                                                           runWithDb,-                                                           setInitialDynFlags)+                                                           retryOnSqliteBusy) import qualified Development.IDE.Session                  as Session import           Development.IDE.Types.Location           (NormalizedUri,                                                            toNormalizedFilePath')@@ -90,20 +84,20 @@                                                            defaultIdeOptions,                                                            optModifyDynFlags,                                                            optTesting)-import           Development.IDE.Types.Shake              (WithHieDb, toKey)+import           Development.IDE.Types.Shake              (WithHieDb,+                                                           toNoFileKey) import           GHC.Conc                                 (getNumProcessors) import           GHC.IO.Encoding                          (setLocaleEncoding) import           GHC.IO.Handle                            (hDuplicate) import           HIE.Bios.Cradle                          (findCradle) import qualified HieDb.Run                                as HieDb-import           Ide.Logger                               (Logger,-                                                           Pretty (pretty),+import           Ide.Logger                               (Pretty (pretty),                                                            Priority (Info),                                                            Recorder,                                                            WithPriority,                                                            cmapWithPrio,-                                                           logDebug, logWith,-                                                           nest, vsep, (<+>))+                                                           logWith, nest, vsep,+                                                           (<+>)) import           Ide.Plugin.Config                        (CheckParents (NeverCheck),                                                            Config, checkParents,                                                            checkProject,@@ -121,16 +115,17 @@ import           Numeric.Natural                          (Natural) import           Options.Applicative                      hiding (action) import qualified System.Directory.Extra                   as IO-import           System.Exit                              (ExitCode (ExitFailure),+import           System.Exit                              (ExitCode (ExitFailure, ExitSuccess),                                                            exitWith) import           System.FilePath                          (takeExtension,-                                                           takeFileName)+                                                           takeFileName, (</>)) import           System.IO                                (BufferMode (LineBuffering, NoBuffering),                                                            Handle, hFlush,                                                            hPutStrLn,                                                            hSetBuffering,                                                            hSetEncoding, stderr,                                                            stdin, stdout, utf8)+import           System.Process                           (readProcessWithExitCode) import           System.Random                            (newStdGen) import           System.Time.Extra                        (Seconds, offsetTime,                                                            showDuration)@@ -140,7 +135,7 @@   | LogLspStart [PluginId]   | LogLspStartDuration !Seconds   | LogShouldRunSubset !Bool-  | LogSetInitialDynFlagsException !SomeException+  | LogConfigurationChange T.Text   | LogService Service.Log   | LogShake Shake.Log   | LogGhcIde GhcIde.Log@@ -148,6 +143,7 @@   | LogSession Session.Log   | LogPluginHLS PluginHLS.Log   | LogRules Rules.Log+  | LogUsingGit   deriving Show  instance Pretty Log where@@ -163,8 +159,7 @@       "Started LSP server in" <+> pretty (showDuration duration)     LogShouldRunSubset shouldRunSubset ->       "shouldRunSubset:" <+> pretty shouldRunSubset-    LogSetInitialDynFlagsException e ->-      "setInitialDynFlags:" <+> pretty (displayException e)+    LogConfigurationChange msg -> "Configuration changed:" <+> pretty msg     LogService msg -> pretty msg     LogShake msg -> pretty msg     LogGhcIde msg -> pretty msg@@ -172,6 +167,7 @@     LogSession msg -> pretty msg     LogPluginHLS msg -> pretty msg     LogRules msg -> pretty msg+    LogUsingGit -> "Using git to list file, relying on .gitignore"  data Command     = Check [FilePath]  -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures@@ -209,9 +205,8 @@   data Arguments = Arguments-    { argsProjectRoot           :: Maybe FilePath+    { argsProjectRoot           :: FilePath     , argCommand                :: Command-    , argsLogger                :: IO Logger     , argsRules                 :: Rules ()     , argsHlsPlugins            :: IdePlugins IdeState     , argsGhcidePlugin          :: Plugin Config  -- ^ Deprecated@@ -225,14 +220,14 @@     , argsHandleOut             :: IO Handle     , argsThreads               :: Maybe Natural     , argsMonitoring            :: IO Monitoring+    , argsDisableKick           :: Bool -- ^ flag to disable kick used for testing     } -defaultArguments :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> Arguments-defaultArguments recorder logger plugins = Arguments-        { argsProjectRoot = Nothing+defaultArguments :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments+defaultArguments recorder projectRoot plugins = Arguments+        { argsProjectRoot = projectRoot -- ^ see Note [Root Directory]         , argCommand = LSP-        , argsLogger = pure logger-        , argsRules = mainRule (cmapWithPrio LogRules recorder) def >> action kick+        , argsRules = mainRule (cmapWithPrio LogRules recorder) def         , argsGhcidePlugin = mempty         , argsHlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde recorder)) <> plugins         , argsSessionLoadingOptions = def@@ -240,7 +235,15 @@             { optCheckProject = pure $ checkProject config             , optCheckParents = pure $ checkParents config             }-        , argsLspOptions = def {LSP.optCompletionTriggerCharacters = Just "."}+        , argsLspOptions = def+            { LSP.optCompletionTriggerCharacters = Just "."+            -- Generally people start to notice that something is taking a while at about 1s, so+            -- that's when we start reporting progress+            , LSP.optProgressStartDelay = 1_000_000+            -- Once progress is being reported, it's nice to see that it's moving reasonably quickly,+            -- but not so fast that it's ugly. This number is a bit made up+            , LSP.optProgressUpdateDelay = 1_00_000+            }         , argsDefaultHlsConfig = def         , argsGetHieDbLoc = getHieDbLoc         , argsDebouncer = newAsyncDebouncer@@ -260,15 +263,16 @@                 -- the language server tests without the redirection.                 putStr " " >> hFlush stdout                 return newStdout-        , argsMonitoring = OpenTelemetry.monitoring <> EKG.monitoring logger 8999+        , argsMonitoring = OpenTelemetry.monitoring+        , argsDisableKick = False         }  -testing :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> Arguments-testing recorder logger plugins =+testing :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments+testing recorder projectRoot plugins =   let-    arguments@Arguments{ argsHlsPlugins, argsIdeOptions } =-        defaultArguments recorder logger plugins+    arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions } =+        defaultArguments recorder projectRoot plugins     hlsPlugins = pluginDescToIdePlugins $       idePluginsToPluginDesc argsHlsPlugins       ++ [Test.blockCommandDescriptor "block-command", Test.plugin]@@ -277,10 +281,12 @@         defOptions = argsIdeOptions config sessionLoader       in         defOptions{ optTesting = IdeTesting True }+    lspOptions = argsLspOptions { LSP.optProgressStartDelay = 0, LSP.optProgressUpdateDelay = 0 }   in     arguments       { argsHlsPlugins = hlsPlugins       , argsIdeOptions = ideOptions+      , argsLspOptions = lspOptions       }  defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO ()@@ -289,7 +295,6 @@   fun = do     setLocaleEncoding utf8     pid <- T.pack . show <$> getProcessID-    logger <- argsLogger     hSetBuffering stderr LineBuffering      let hlsPlugin = asGhcIdePlugin (cmapWithPrio LogPluginHLS recorder) argsHlsPlugins@@ -297,7 +302,13 @@         plugins = hlsPlugin <> argsGhcidePlugin         options = argsLspOptions { LSP.optExecuteCommandCommands = LSP.optExecuteCommandCommands argsLspOptions <> Just hlsCommands }         argsParseConfig = getConfigFromNotification argsHlsPlugins-        rules = argsRules >> pluginRules plugins+        rules = do+            argsRules+            unless argsDisableKick $ action kick+            pluginRules plugins+        -- install the main and ghcide-plugin rules+        -- install the kick action, which triggers a typecheck on every+        -- Shake database restart, i.e. on every user edit.      debouncer <- argsDebouncer     inH <- argsHandleIn@@ -311,23 +322,11 @@             ioT <- offsetTime             logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) -            ideStateVar <- newEmptyMVar-            let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState-                getIdeState env rootPath withHieDb hieChan = do-                  traverse_ IO.setCurrentDirectory rootPath+            let getIdeState :: MVar IdeState -> LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> Shake.ThreadQueue -> IO IdeState+                getIdeState ideStateVar env rootPath withHieDb threadQueue = do                   t <- ioT                   logWith recorder Info $ LogLspStartDuration t--                  dir <- maybe IO.getCurrentDirectory return rootPath--                  -- We want to set the global DynFlags right now, so that we can use-                  -- `unsafeGlobalDynFlags` even before the project is configured-                  _mlibdir <--                      setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions-                          -- TODO: should probably catch/log/rethrow at top level instead-                          `catchAny` (\e -> logWith recorder Error (LogSetInitialDynFlagsException e) >> pure Nothing)--                  sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir+                  sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath (tLoaderQueue threadQueue)                   config <- LSP.runLspT env LSP.getConfig                   let def_options = argsIdeOptions config sessionLoader @@ -348,18 +347,18 @@                       argsHlsPlugins                       rules                       (Just env)-                      logger                       debouncer                       ideOptions                       withHieDb-                      hieChan+                      threadQueue                       monitoring+                      rootPath                   putMVar ideStateVar ide                   pure ide -            let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState+            let setup ideStateVar = setupLSP (cmapWithPrio LogLanguageServer recorder) argsProjectRoot argsGetHieDbLoc (pluginHandlers plugins) (getIdeState ideStateVar)                 -- See Note [Client configuration in Rules]-                onConfigChange cfg = do+                onConfigChange ideStateVar cfg = do                   -- TODO: this is nuts, we're converting back to JSON just to get a fingerprint                   let cfgObj = J.toJSON cfg                   mide <- liftIO $ tryReadMVar ideStateVar@@ -367,16 +366,19 @@                     Nothing -> pure ()                     Just ide -> liftIO $ do                         let msg = T.pack $ show cfg-                        logDebug (Shake.ideLogger ide) $ "Configuration changed: " <> msg-                        modifyClientSettings ide (const $ Just cfgObj)-                        setSomethingModified Shake.VFSUnmodified ide [toKey Rules.GetClientSettings emptyFilePath] "config change"+                        setSomethingModified Shake.VFSUnmodified ide "config change" $ do+                            logWith recorder Debug $ LogConfigurationChange msg+                            modifyClientSettings ide (const $ Just cfgObj)+                            return [toNoFileKey Rules.GetClientSettings] -            runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup+            do+                ideStateVar <- newEmptyMVar+                runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig (onConfigChange ideStateVar) (setup ideStateVar)             dumpSTMStats         Check argFiles -> do-          dir <- maybe IO.getCurrentDirectory return argsProjectRoot+          let dir = argsProjectRoot           dbLoc <- getHieDbLoc dir-          runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do+          runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc mempty $ \hiedb threadQueue -> do             -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error             hSetEncoding stdout utf8             hSetEncoding stderr utf8@@ -385,7 +387,7 @@             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])+            files <- expandFiles recorder (argFiles ++ ["." | null argFiles])             -- LSP works with absolute file paths, so try and behave similarly             absoluteFiles <- nubOrd <$> mapM IO.canonicalizePath files             putStrLn $ "Found " ++ show (length absoluteFiles) ++ " files"@@ -397,14 +399,14 @@             putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]             when (n > 0) $ putStrLn $ "  (" ++ intercalate ", " (catMaybes ucradles) ++ ")"             putStrLn "\nStep 3/4: Initializing the IDE"-            sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir+            sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir (tLoaderQueue threadQueue)             let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader                 ideOptions = def_options                         { optCheckParents = pure NeverCheck                         , optCheckProject = pure False                         , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins                         }-            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer ideOptions hiedb hieChan mempty+            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb threadQueue mempty dir             shakeSessionInit (cmapWithPrio LogShake recorder) ide             registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -422,41 +424,70 @@              unless (null failed) (exitWith $ ExitFailure (length failed))         Db opts cmd -> do-            root <-  maybe IO.getCurrentDirectory return argsProjectRoot+            let root = argsProjectRoot             dbLoc <- getHieDbLoc root             hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc-            mlibdir <- setInitialDynFlags (cmapWithPrio LogSession recorder) root def+            mlibdir <- getInitialGhcLibDirDefault (cmapWithPrio LogSession recorder) root             rng <- newStdGen             case mlibdir of                 Nothing     -> exitWith $ ExitFailure 1                 Just libdir -> retryOnSqliteBusy (cmapWithPrio LogSession recorder) rng (HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd)          Custom (IdeCommand c) -> do-          root <-  maybe IO.getCurrentDirectory return argsProjectRoot+          let root = argsProjectRoot           dbLoc <- getHieDbLoc root-          runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do-            sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "."+          runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc mempty $ \hiedb threadQueue -> do+            sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." (tLoaderQueue threadQueue)             let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader                 ideOptions = def_options                     { optCheckParents = pure NeverCheck                     , optCheckProject = pure False                     , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins                     }-            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer ideOptions hiedb hieChan mempty+            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb threadQueue mempty root             shakeSessionInit (cmapWithPrio LogShake recorder) ide             registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)             c ide -expandFiles :: [FilePath] -> IO [FilePath]-expandFiles = concatMapM $ \x -> do+-- | List the haskell files given some paths+--+-- It will rely on git if possible to filter-out ignored files.+expandFiles :: Recorder (WithPriority Log) -> [FilePath] -> IO [FilePath]+expandFiles recorder paths = do+  let haskellFind x =+        let recurse "." = True+            recurse y | "." `isPrefixOf` takeFileName y = False -- skip .git etc+            recurse y = takeFileName y `notElem` ["dist", "dist-newstyle"] -- cabal directories+        in filter (\y -> takeExtension y `elem` [".hs", ".lhs"]) <$> IO.listFilesInside (return . recurse) x+      git args = do+        mResult <- (Just <$> readProcessWithExitCode "git" args "") `Safe.catchAny`const (pure Nothing)+        pure $+            case mResult of+              Just (ExitSuccess, gitStdout, _) -> Just gitStdout+              _                                -> Nothing+  mHasGit <- git ["status"]+  when (isJust mHasGit) $ logWith recorder Info LogUsingGit+  let findFiles =+        case mHasGit of+          Just _ -> \path -> do+            let lookups =+                  if takeExtension path `elem` [".hs", ".lhs"]+                      then [path]+                      else [path </> "*.hs", path </> "*.lhs"]+                gitLines args = fmap lines <$> git args+            mTracked <- gitLines ("ls-files":lookups)+            mUntracked <- gitLines ("ls-files":"-o":lookups)+            case mTracked <> mUntracked of+              Nothing    -> haskellFind path+              Just files -> pure files+          _ -> haskellFind++  flip concatMapM paths $ \x -> do     b <- IO.doesFileExist x     if b         then return [x]         else do-            let recurse "." = True-                recurse y | "." `isPrefixOf` takeFileName y = False -- skip .git etc-                recurse y = takeFileName y `notElem` ["dist", "dist-newstyle"] -- cabal directories-            files <- filter (\y -> takeExtension y `elem` [".hs", ".lhs"]) <$> IO.listFilesInside (return . recurse) x+            files <- findFiles x             when (null files) $                 fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x             return files
src/Development/IDE/Main/HeapStats.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE NumericUnderscores #-} -- | Logging utilities for reporting heap statistics module Development.IDE.Main.HeapStats ( withHeapStats, Log(..)) where
− src/Development/IDE/Monitoring/EKG.hs 
@@ -1,49 +0,0 @@-{-# LANGUAGE CPP #-}-module Development.IDE.Monitoring.EKG(monitoring) where--import           Development.IDE.Types.Monitoring (Monitoring (..))-import           Ide.Logger                       (Logger)--#ifdef MONITORING_EKG-import           Control.Concurrent               (killThread)-import           Control.Concurrent.Async         (async, waitCatch)-import           Control.Monad                    (forM_)-import           Data.Text                        (pack)-import           Ide.Logger                       (logInfo)-import qualified System.Metrics                   as Monitoring-import qualified System.Remote.Monitoring.Wai     as Monitoring---- | Monitoring using EKG-monitoring :: Logger -> Int -> IO Monitoring-monitoring logger port = do-    store <- Monitoring.newStore-    Monitoring.registerGcMetrics store-    let registerCounter name read = Monitoring.registerCounter name read store-        registerGauge name read = Monitoring.registerGauge name read store-        start = do-            server <- do-                let startServer = Monitoring.forkServerWith store "localhost" port-                -- this can fail if the port is busy, throwing an async exception back to us-                -- to handle that, wrap the server thread in an async-                mb_server <- async startServer >>= waitCatch-                case mb_server of-                    Right s -> do-                        logInfo logger $ pack $-                            "Started monitoring server on port " <> show port-                        return $ Just s-                    Left e -> do-                        logInfo logger $ pack $-                            "Unable to bind monitoring server on port "-                            <> show port <> ":" <> show e-                        return Nothing-            return $ forM_ server $ \s -> do-                logInfo logger "Stopping monitoring server"-                killThread $ Monitoring.serverThreadId s-    return $ Monitoring {..}--#else--monitoring :: Logger -> Int -> IO Monitoring-monitoring _ _ = mempty--#endif
src/Development/IDE/Plugin/Completions.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP              #-} {-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE RankNTypes       #-} {-# LANGUAGE TypeFamilies     #-}  module Development.IDE.Plugin.Completions@@ -20,6 +19,7 @@ import           Data.Maybe import qualified Data.Text                                as T import           Development.IDE.Core.Compile+import           Development.IDE.Core.FileStore           (getUriContents) import           Development.IDE.Core.PluginUtils import           Development.IDE.Core.PositionMapping import           Development.IDE.Core.RuleTypes@@ -48,7 +48,6 @@ import qualified Language.LSP.Protocol.Lens               as L import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types-import qualified Language.LSP.Server                      as LSP import           Numeric.Natural import           Prelude                                  hiding (mod) import           Text.Fuzzy.Parallel                      (Scored (..))@@ -57,8 +56,6 @@  import qualified Ide.Plugin.Config                        as Config --- See Note [Guidelines For Using CPP In GHCIDE Import Statements]- import qualified GHC.LanguageExtensions                   as LangExt  data Log = LogShake Shake.Log deriving Show@@ -71,13 +68,15 @@ ghcideCompletionsPluginPriority = defaultPluginPriority  descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState-descriptor recorder plId = (defaultPluginDescriptor plId)+descriptor recorder plId = (defaultPluginDescriptor plId desc)   { pluginRules = produceCompletions recorder   , pluginHandlers = mkPluginHandler SMethod_TextDocumentCompletion getCompletionsLSP                      <> mkResolveHandler SMethod_CompletionItemResolve resolveCompletion   , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}   , pluginPriority = ghcideCompletionsPluginPriority   }+  where+    desc = "Provides Haskell completions"   produceCompletions :: Recorder (WithPriority Log) -> Rules ()@@ -115,15 +114,10 @@ -- Drop any explicit imports in ImportDecl if not hidden dropListFromImportDecl :: LImportDecl GhcPs -> LImportDecl GhcPs dropListFromImportDecl iDecl = let-#if MIN_VERSION_ghc(9,5,0)     f d@ImportDecl {ideclImportList} = case ideclImportList of         Just (Exactly, _) -> d {ideclImportList=Nothing}-#else-    f d@ImportDecl {ideclHiding} = case ideclHiding of-        Just (False, _) -> d {ideclHiding=Nothing}-#endif         -- if hiding or Nothing just return d-        _               -> d+        _                 -> d     f x = x     in f <$> iDecl @@ -135,23 +129,19 @@                   $ runIdeActionE "CompletionResolve.GhcSessionDeps" (shakeExtras ide)                   $ useWithStaleFastE GhcSessionDeps file     let nc = ideNc $ shakeExtras ide-#if MIN_VERSION_ghc(9,3,0)     name <- liftIO $ lookupNameCache nc mod occ-#else-    name <- liftIO $ upNameCache nc (lookupNameCache mod occ)-#endif     mdkm <- liftIO $ runIdeAction "CompletionResolve.GetDocMap" (shakeExtras ide) $ useWithStaleFast GetDocMap file     let (dm,km) = case mdkm of-          Just (DKMap docMap kindMap, _) -> (docMap,kindMap)-          Nothing                        -> (mempty, mempty)+          Just (DKMap docMap tyThingMap _argDocMap, _) -> (docMap,tyThingMap)+          Nothing                                      -> (mempty, mempty)     doc <- case lookupNameEnv dm name of       Just doc -> pure $ spanDocToMarkdown doc-      Nothing -> liftIO $ spanDocToMarkdown <$> getDocumentationTryGhc (hscEnv sess) name+      Nothing -> liftIO $ spanDocToMarkdown . fst <$> getDocumentationTryGhc (hscEnv sess) name     typ <- case lookupNameEnv km name of       _ | not needType -> pure Nothing-      Just ty -> pure (safeTyThingType ty)+      Just ty -> pure (safeTyThingType True ty)       Nothing -> do-        (safeTyThingType =<<) <$> liftIO (lookupName (hscEnv sess) name)+        (safeTyThingType True =<<) <$> liftIO (lookupName (hscEnv sess) name)     let det1 = case typ of           Just ty -> Just (":: " <> printOutputable (stripForall ty) <> "\n")           Nothing -> Nothing@@ -171,8 +161,9 @@   CompletionParams{_textDocument=TextDocumentIdentifier uri                   ,_position=position                   ,_context=completionContext} = ExceptT $ do-    contents <- LSP.getVirtualFile $ toNormalizedUri uri-    fmap Right $ case (contents, uriToFilePath' uri) of+    contentsMaybe <-+      liftIO $ runAction "Completion" ide $ getUriContents $ toNormalizedUri uri+    fmap Right $ case (contentsMaybe, uriToFilePath' uri) of       (Just cnts, Just path) -> do         let npath = toNormalizedFilePath' path         (ideOpts, compls, moduleExports, astres) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do@@ -182,7 +173,7 @@             pm <- useWithStaleFast GetParsedModule npath             binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath             knownTargets <- liftIO $ runAction  "Completion" ide $ useNoFile GetKnownTargets-            let localModules = maybe [] Map.keys knownTargets+            let localModules = maybe [] (Map.keys . targetMap) knownTargets             let lModules = mempty{importableModules = map toModueNameText localModules}             -- set up the exports map including both package and project-level identifiers             packageExportsMapIO <- fmap(envPackageExports . fst) <$> useWithStaleFast GhcSession npath@@ -206,7 +197,7 @@             pure (opts, fmap (,pm,binds) compls, moduleExports, astres)         case compls of           Just (cci', parsedMod, bindMap) -> do-            let pfix = getCompletionPrefix position cnts+            let pfix = getCompletionPrefixFromRope position cnts             case (pfix, completionContext) of               (PosPrefixInfo _ "" _ _, Just CompletionContext { _triggerCharacter = Just "."})                 -> return (InL [])@@ -215,7 +206,7 @@                     plugins = idePlugins $ shakeExtras ide                 config <- liftIO $ runAction "" ide $ getCompletionsConfig plId -                allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports uri+                let allCompletions = getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports uri                 pure $ InL (orderedCompletions allCompletions)           _ -> return (InL [])       _ -> return (InL [])
src/Development/IDE/Plugin/Completions/Logic.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs                 #-} {-# LANGUAGE MultiWayIf            #-}-{-# LANGUAGE OverloadedLabels      #-}  -- Mostly taken from "haskell-ide-engine" module Development.IDE.Plugin.Completions.Logic (@@ -12,6 +11,7 @@ , getCompletions , fromIdentInfo , getCompletionPrefix+, getCompletionPrefixFromRope ) where  import           Control.Applicative@@ -23,7 +23,6 @@ import           Data.List.Extra                          as List hiding                                                                   (stripPrefix) import qualified Data.Map                                 as Map-import           Data.Row import           Prelude                                  hiding (mod)  import           Data.Maybe                               (fromMaybe, isJust,@@ -38,50 +37,46 @@ import           Data.Function                            (on)  import qualified Data.HashSet                             as HashSet-import           Data.Monoid                              (First (..)) import           Data.Ord                                 (Down (Down)) import qualified Data.Set                                 as Set import           Development.IDE.Core.PositionMapping import           Development.IDE.GHC.Compat               hiding (isQual, ppr) import qualified Development.IDE.GHC.Compat               as GHC import           Development.IDE.GHC.Compat.Util-import           Development.IDE.GHC.CoreFile             (occNamePrefixes) import           Development.IDE.GHC.Error import           Development.IDE.GHC.Util import           Development.IDE.Plugin.Completions.Types import           Development.IDE.Spans.LocalBindings import           Development.IDE.Types.Exports import           Development.IDE.Types.Options+import           GHC.Iface.Ext.Types                      (HieAST,+                                                           NodeInfo (..))+import           GHC.Iface.Ext.Utils                      (nodeInfo) import           Ide.PluginUtils                          (mkLspCommand) import           Ide.Types                                (CommandId (..),                                                            IdePlugins (..),                                                            PluginId)+import           Language.Haskell.Syntax.Basic import qualified Language.LSP.Protocol.Lens               as L import           Language.LSP.Protocol.Types import qualified Language.LSP.VFS                         as VFS import           Text.Fuzzy.Parallel                      (Scored (score),                                                            original) -import qualified Data.Text.Utf16.Rope                     as Rope+import qualified Data.Text.Utf16.Rope.Mixed               as Rope import           Development.IDE                          hiding (line)  import           Development.IDE.Spans.AtPoint            (pointCommand) --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] +import qualified Development.IDE.Plugin.Completions.Types as C import           GHC.Plugins                              (Depth (AllTheWay),                                                            mkUserStyle,                                                            neverQualify,                                                            sdocStyle) -#if !MIN_VERSION_ghc(9,3,0)-import           GHC.Plugins                              (defaultSDocContext,-                                                           renderWithContext)-#endif+-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if MIN_VERSION_ghc(9,5,0)-import           Language.Haskell.Syntax.Basic-#endif  -- Chunk size used for parallelizing fuzzy matching chunkSize :: Int@@ -143,42 +138,23 @@           | pos `isInsideSrcSpan` r = Just TypeContext         goInline _ = Nothing -#if MIN_VERSION_ghc(9,5,0)         importGo :: GHC.LImportDecl GhcPs -> Maybe Context         importGo (L (locA -> r) impDecl)           | pos `isInsideSrcSpan` r           = importInline importModuleName (fmap (fmap reLoc) $ ideclImportList impDecl)-#else-        importGo :: GHC.LImportDecl GhcPs -> Maybe Context-        importGo (L (locA -> r) impDecl)-          | pos `isInsideSrcSpan` r-          = importInline importModuleName (fmap (fmap reLoc) $ ideclHiding impDecl)-#endif           <|> Just (ImportContext importModuleName)            | otherwise = Nothing           where importModuleName = moduleNameString $ unLoc $ ideclName impDecl          -- importInline :: String -> Maybe (Bool,  GHC.Located [LIE GhcPs]) -> Maybe Context-#if MIN_VERSION_ghc(9,5,0)         importInline modName (Just (EverythingBut, L r _))           | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName           | otherwise = Nothing-#else-        importInline modName (Just (True, L r _))-          | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName-          | otherwise = Nothing-#endif -#if MIN_VERSION_ghc(9,5,0)         importInline modName (Just (Exactly, L r _))           | pos `isInsideSrcSpan` r = Just $ ImportListContext modName           | otherwise = Nothing-#else-        importInline modName (Just (False, L r _))-          | pos `isInsideSrcSpan` r = Just $ ImportListContext modName-          | otherwise = Nothing-#endif          importInline _ _ = Nothing @@ -227,7 +203,7 @@                   _preselect = Nothing,                   _sortText = Nothing,                   _filterText = Nothing,-                  _insertText = Just insertText,+                  _insertText = Just $ snippetToText insertText,                   _insertTextFormat = Just InsertTextFormat_Snippet,                   _insertTextMode = Nothing,                   _textEdit = Nothing,@@ -266,11 +242,10 @@     compKind = occNameToComKind origName     isTypeCompl = isTcOcc origName     typeText = Nothing-    label = stripPrefix $ printOutputable origName-    insertText = case isInfix of+    label = stripOccNamePrefix $ printOutputable origName+    insertText = snippetText $ case isInfix of             Nothing         -> label             Just LeftSide   -> label <> "`"-             Just Surrounded -> label     additionalTextEdits =       imp <&> \x ->@@ -319,7 +294,7 @@ fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem fromIdentInfo doc identInfo@IdentInfo{..} q = CI   { compKind= occNameToComKind name-  , insertText=rend+  , insertText= snippetText rend   , provenance = DefinedIn mod   , label=rend   , typeText = Nothing@@ -483,10 +458,11 @@         ]      mkLocalComp pos n ctyp ty =-        CI ctyp pn (Local pos) pn ty Nothing (ctyp `elem` [CompletionItemKind_Struct, CompletionItemKind_Interface]) Nothing (Just $ NameDetails (ms_mod $ pm_mod_summary pm) occ) True+        CI ctyp sn (Local pos) pn ty Nothing (ctyp `elem` [CompletionItemKind_Struct, CompletionItemKind_Interface]) Nothing (Just $ NameDetails (ms_mod $ pm_mod_summary pm) occ) True       where         occ = rdrNameOcc $ unLoc n         pn = showForSnippet n+        sn = snippetText pn  findRecordCompl :: Uri -> Provenance -> TyClDecl GhcPs -> [CompItem] findRecordCompl uri mn DataDecl {tcdLName, tcdDataDefn} = result@@ -514,15 +490,17 @@             --             -- is encoded as @[[arg1, arg2], [arg3], [arg4]]@             -- Hence, we must concat nested arguments into one to get all the fields.-#if MIN_VERSION_ghc(9,3,0)-        extract ConDeclField{..}-            = map (foLabel . unLoc) cd_fld_names+#if MIN_VERSION_ghc(9,13,0)+        extract HsConDeclRecField{..}+            = map (foLabel . unLoc) cdrf_names+        -- XConDeclRecField+        extract _ = [] #else         extract ConDeclField{..}-            = map (rdrNameFieldOcc . unLoc) cd_fld_names-#endif+            = map (foLabel . unLoc) cd_fld_names         -- XConDeclField         extract _ = []+#endif findRecordCompl _ _ _ = []  toggleSnippets :: ClientCapabilities -> CompletionsConfig -> CompletionItem -> CompletionItem@@ -530,7 +508,7 @@   removeSnippetsWhen (not $ enableSnippets && supported)   where     supported =-      Just True == (_textDocument >>= _completion >>= view L.completionItem >>= (\x -> x .! #snippetSupport))+      Just True == (_textDocument >>= _completion >>= view L.completionItem >>= view L.snippetSupport)  toggleAutoExtend :: CompletionsConfig -> CompItem -> CompItem toggleAutoExtend CompletionsConfig{enableAutoExtend=False} x = x {additionalTextEdits = Nothing}@@ -559,10 +537,54 @@     -> CompletionsConfig     -> ModuleNameEnv (HashSet.HashSet IdentInfo)     -> Uri-    -> IO [Scored CompletionItem]-getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules}-               maybe_parsed maybe_ast_res (localBindings, bmapping) prefixInfo caps config moduleExportsMap uri = do-  let PosPrefixInfo { fullLine, prefixScope, prefixText } = prefixInfo+    -> [Scored CompletionItem]+getCompletions+    plugins+    ideOpts+    CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules}+    maybe_parsed+    maybe_ast_res+    (localBindings, bmapping)+    prefixInfo@(PosPrefixInfo { fullLine, prefixScope, prefixText })+    caps+    config+    moduleExportsMap+    uri+    -- ------------------------------------------------------------------------+    -- IMPORT MODULENAME (NAM|)+    | Just (ImportListContext moduleName) <- maybeContext+    = moduleImportListCompletions moduleName++    | Just (ImportHidingContext moduleName) <- maybeContext+    = moduleImportListCompletions moduleName++    -- ------------------------------------------------------------------------+    -- IMPORT MODULENAM|+    | Just (ImportContext _moduleName) <- maybeContext+    = filtImportCompls++    -- ------------------------------------------------------------------------+    -- {-# LA| #-}+    -- we leave this condition here to avoid duplications and return empty list+    -- since HLS implements these completions (#haskell-language-server/pull/662)+    | "{-# " `T.isPrefixOf` fullLine+    = []++    -- ------------------------------------------------------------------------+    | otherwise =+        -- assumes that nubOrdBy is stable+        let uniqueFiltCompls = nubOrdBy (uniqueCompl `on` snd . Fuzzy.original) filtCompls+            compls = (fmap.fmap.fmap) (mkCompl pId ideOpts uri) uniqueFiltCompls+            pId = lookupCommandProvider plugins (CommandId extendImportCommandId)+        in+          (fmap.fmap) snd $+          sortBy (compare `on` lexicographicOrdering) $+          mergeListsBy (flip compare `on` score)+            [ (fmap.fmap) (notQual,) filtModNameCompls+            , (fmap.fmap) (notQual,) filtKeywordCompls+            , (fmap.fmap.fmap) (toggleSnippets caps config) compls+            ]+    where       enteredQual = if T.null prefixScope then "" else prefixScope <> "."       fullPrefix  = enteredQual <> prefixText @@ -585,11 +607,9 @@           $ Fuzzy.simpleFilter chunkSize maxC fullPrefix           $ (if T.null enteredQual then id else mapMaybe (T.stripPrefix enteredQual))             allModNamesAsNS--      filtCompls = Fuzzy.filter chunkSize maxC prefixText ctxCompls (label . snd)-        where--          mcc = case maybe_parsed of+      -- If we have a parsed module, use it to determine which completion to show.+      maybeContext :: Maybe Context+      maybeContext = case maybe_parsed of             Nothing -> Nothing             Just (pm, pmapping) ->               let PositionMapping pDelta = pmapping@@ -598,7 +618,9 @@                   hpos = upperRange position'               in getCContext lpos pm <|> getCContext hpos pm -+      filtCompls :: [Scored (Bool, CompItem)]+      filtCompls = Fuzzy.filter chunkSize maxC prefixText ctxCompls (label . snd)+        where           -- We need the hieast to be "fresh". We can't get types from "stale" hie files, so hasfield won't work,           -- since it gets the record fields from the types.           -- Perhaps this could be fixed with a refactor to GHC's IfaceTyCon, to have it also contain record fields.@@ -624,7 +646,7 @@               dotFieldSelectorToCompl :: T.Text -> T.Text -> (Bool, CompItem)               dotFieldSelectorToCompl recname label = (True, CI                 { compKind = CompletionItemKind_Field-                , insertText = label+                , insertText = snippetText label                 , provenance = DefinedIn recname                 , label = label                 , typeText = Nothing@@ -636,7 +658,7 @@                 })            -- completions specific to the current context-          ctxCompls' = case mcc of+          ctxCompls' = case maybeContext of                         Nothing           -> compls                         Just TypeContext  -> filter ( isTypeCompl . snd) compls                         Just ValueContext -> filter (not . isTypeCompl . snd) compls@@ -653,14 +675,14 @@           endLoc = upperRange oldPos           localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc           localBindsToCompItem :: Name -> Maybe Type -> CompItem-          localBindsToCompItem name typ = CI ctyp pn thisModName pn ty Nothing (not $ isValOcc occ) Nothing dets True+          localBindsToCompItem name typ = CI ctyp (snippetText pn) thisModName pn ty Nothing (not $ isValOcc occ) Nothing dets True             where               occ = nameOccName name               ctyp = occNameToComKind occ               pn = showForSnippet name               ty = showForSnippet <$> typ               thisModName = Local $ nameSrcSpan name-              dets = NameDetails <$> (nameModule_maybe name) <*> pure (nameOccName name)+              dets = NameDetails <$> nameModule_maybe name <*> pure (nameOccName name)            -- When record-dot-syntax completions are available, we return them exclusively.           -- They are only available when we write i.e. `myrecord.` with OverloadedRecordDot enabled.@@ -677,54 +699,36 @@         , enteredQual `T.isPrefixOf` original label         ] +      moduleImportListCompletions :: String -> [Scored CompletionItem]+      moduleImportListCompletions moduleNameS =+        let moduleName = T.pack moduleNameS+            funcs = lookupWithDefaultUFM moduleExportsMap HashSet.empty $ mkModuleName moduleNameS+            funs = map (show . name) $ HashSet.toList funcs+        in filterModuleExports moduleName $ map T.pack funs++      filtImportCompls :: [Scored CompletionItem]       filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules++      filterModuleExports :: T.Text -> [T.Text] -> [Scored CompletionItem]       filterModuleExports moduleName = filtListWith $ mkModuleFunctionImport moduleName++      filtKeywordCompls :: [Scored CompletionItem]       filtKeywordCompls           | T.null prefixScope = filtListWith mkExtCompl (optKeywords ideOpts)           | otherwise = [] -  if-    -- TODO: handle multiline imports-    | "import " `T.isPrefixOf` fullLine-      && (List.length (words (T.unpack fullLine)) >= 2)-      && "(" `isInfixOf` T.unpack fullLine-    -> do-      let moduleName = words (T.unpack fullLine) !! 1-          funcs = lookupWithDefaultUFM moduleExportsMap HashSet.empty $ mkModuleName moduleName-          funs = map (renderOcc . name) $ HashSet.toList funcs-      return $ filterModuleExports (T.pack moduleName) funs-    | "import " `T.isPrefixOf` fullLine-    -> return filtImportCompls-    -- we leave this condition here to avoid duplications and return empty list-    -- since HLS implements these completions (#haskell-language-server/pull/662)-    | "{-# " `T.isPrefixOf` fullLine-    -> return []-    | otherwise -> do-        -- assumes that nubOrdBy is stable-        let uniqueFiltCompls = nubOrdBy (uniqueCompl `on` snd . Fuzzy.original) filtCompls-        let compls = (fmap.fmap.fmap) (mkCompl pId ideOpts uri) uniqueFiltCompls-            pId = lookupCommandProvider plugins (CommandId extendImportCommandId)-        return $-          (fmap.fmap) snd $-          sortBy (compare `on` lexicographicOrdering) $-          mergeListsBy (flip compare `on` score)-            [ (fmap.fmap) (notQual,) filtModNameCompls-            , (fmap.fmap) (notQual,) filtKeywordCompls-            , (fmap.fmap.fmap) (toggleSnippets caps config) compls-            ]-    where-        -- We use this ordering to alphabetically sort suggestions while respecting-        -- all the previously applied ordering sources. These are:-        --  1. Qualified suggestions go first-        --  2. Fuzzy score ranks next-        --  3. In-scope completions rank next-        --  4. label alphabetical ordering next-        --  4. detail alphabetical ordering (proxy for module)-        lexicographicOrdering Fuzzy.Scored{score, original} =-          case original of-            (isQual, CompletionItem{_label,_detail}) -> do-              let isLocal = maybe False (":" `T.isPrefixOf`) _detail-              (Down isQual, Down score, Down isLocal, _label, _detail)+      -- We use this ordering to alphabetically sort suggestions while respecting+      -- all the previously applied ordering sources. These are:+      --  1. Qualified suggestions go first+      --  2. Fuzzy score ranks next+      --  3. In-scope completions rank next+      --  4. label alphabetical ordering next+      --  4. detail alphabetical ordering (proxy for module)+      lexicographicOrdering Fuzzy.Scored{score, original} =+        case original of+          (isQual, CompletionItem{_label,_detail}) -> do+            let isLocal = maybe False (":" `T.isPrefixOf`) _detail+            (Down isQual, Down score, Down isLocal, _label, _detail)   @@ -736,11 +740,12 @@     EQ ->       -- preserve completions for duplicate record fields where the only difference is in the type       -- remove redundant completions with less type info than the previous-      if (isLocalCompletion unique)+      if isLocalCompletion unique         -- filter global completions when we already have a local one         || not(isLocalCompletion candidate) && isLocalCompletion unique         then EQ-        else compare (importedFrom candidate, insertText candidate) (importedFrom unique, insertText unique)+        else compare (importedFrom candidate) (importedFrom unique) <>+             snippetLexOrd (insertText candidate) (insertText unique)     other -> other   where       importedFrom :: CompItem -> T.Text@@ -785,17 +790,6 @@  -- --------------------------------------------------------------------- --- | 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 (/=':') $ fromMaybe name $-  getFirst $ foldMap (First . (`T.stripPrefix` name)) occNamePrefixes- mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> Provenance -> Maybe (LImportDecl GhcPs) -> CompItem mkRecordSnippetCompItem uri parent ctxStr compl importedFrom imp = r   where@@ -820,9 +814,10 @@           }        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 <> "}"+      snippet_parts = placeholder_pairs <&> \(x, i) ->+        snippetText x <> "=" <> snippetVariableDefault (T.pack $ show i) (C.SText $ "_" <> x)+      snippet = mconcat $ intersperse ", " snippet_parts+      buildSnippet = snippetText ctxStr <> " {" <> snippet <> "}"  getImportQual :: LImportDecl GhcPs -> Maybe T.Text getImportQual (L _ imp)@@ -872,13 +867,16 @@  -- |From the given cursor position, gets the prefix module or record for autocompletion getCompletionPrefix :: Position -> VFS.VirtualFile -> PosPrefixInfo-getCompletionPrefix pos@(Position l c) (VFS.VirtualFile _ _ ropetext) =+getCompletionPrefix pos (VFS.VirtualFile _ _ ropetext _) = getCompletionPrefixFromRope pos ropetext++getCompletionPrefixFromRope :: Position -> Rope.Rope -> PosPrefixInfo+getCompletionPrefixFromRope pos@(Position l c) ropetext =       fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad         let headMaybe = listToMaybe             lastMaybe = headMaybe . reverse          -- grab the entire line the cursor is at-        curLine <- headMaybe $ T.lines $ Rope.toText+        curLine <- headMaybe $ Rope.lines                              $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext         let beforePos = T.take (fromIntegral c) curLine         -- the word getting typed, after previous space and before cursor@@ -893,7 +891,9 @@           [] -> Nothing           (x:xs) -> do             let modParts = reverse $ filter (not .T.null) xs-                modName = T.intercalate "." modParts+                -- Must check the prefix is a valid module name, else record dot accesses treat+                -- the record name as a qualName for search and generated imports+                modName = if all (isUpper . T.head) modParts then T.intercalate "." modParts else ""             return $ PosPrefixInfo { fullLine = curLine, prefixScope = modName, prefixText = x, cursorPos = pos }  completionPrefixPos :: PosPrefixInfo -> Position
src/Development/IDE/Plugin/Completions/Types.hs view
@@ -14,32 +14,32 @@  import           Data.Aeson import           Data.Aeson.Types+import           Data.Function                (on) import           Data.Hashable                (Hashable)+import qualified Data.List                    as L+import           Data.List.NonEmpty           (NonEmpty (..))+import           Data.String                  (IsString (..)) import           Data.Text                    (Text)-import           Data.Typeable                (Typeable) import           Development.IDE.GHC.Compat import           Development.IDE.Graph        (RuleResult) import           Development.IDE.Spans.Common () import           GHC.Generics                 (Generic)+import qualified GHC.Types.Name.Occurrence    as Occ import           Ide.Plugin.Properties import           Language.LSP.Protocol.Types  (CompletionItemKind (..), Uri) import qualified Language.LSP.Protocol.Types  as J --- See Note [Guidelines For Using CPP In GHCIDE Import Statements]--import qualified GHC.Types.Name.Occurrence    as Occ- -- | Produce completions info for a file type instance RuleResult LocalCompletions = CachedCompletions type instance RuleResult NonLocalCompletions = CachedCompletions  data LocalCompletions = LocalCompletions-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable LocalCompletions instance NFData   LocalCompletions  data NonLocalCompletions = NonLocalCompletions-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable NonLocalCompletions instance NFData   NonLocalCompletions @@ -85,9 +85,60 @@     | Local SrcSpan     deriving (Eq, Ord, Show) +newtype Snippet = Snippet [SnippetAny]+  deriving (Eq, Show)+  deriving newtype (Semigroup, Monoid)++instance IsString Snippet where+  fromString = snippetText . T.pack++-- | @SnippetAny@ can be used to construct sanitized snippets. See the LSP+-- spec for more details.+data SnippetAny+  = SText Text+  -- ^ Literal text+  | STabStop Int (Maybe SnippetAny)+  -- ^ Creates a tab stop, i.e. parts of the snippet that are meant to be+  -- filled in by the user and that can be jumped between using the tab key.+  -- The optional field can be used to provide a placeholder value.+  | SChoice Int (NonEmpty Text)+  -- ^ Presents a choice between the provided values to the user+  | SVariable Text (Maybe SnippetAny)+  -- ^ Snippet variable. See the spec for possible values. The optional field+  -- can be used to provide a default value for when the variable is not set.+  deriving (Eq, Show)++snippetText :: Text -> Snippet+snippetText = Snippet . L.singleton . SText++snippetVariable :: Text -> Snippet+snippetVariable n = Snippet . L.singleton $ SVariable n Nothing++snippetVariableDefault :: Text -> SnippetAny -> Snippet+snippetVariableDefault n d = Snippet . L.singleton . SVariable n $ Just d++snippetToText :: Snippet -> Text+snippetToText (Snippet l) = foldMap (snippetAnyToText False) l+  where+    snippetAnyToText isNested = \case+      SText t -> sanitizeText isNested t+      STabStop i ph -> "${" <> T.pack (show i) <> foldMap (\p -> ":" <> snippetAnyToText True p) ph <> "}"+      SChoice i (c :| cs) -> "${" <> T.pack (show i) <> "|" <> c <> foldMap ("," <>) cs <> "}"+      SVariable n md -> "${" <> n <> foldMap (\x -> ":" <> snippetAnyToText True x) md <> "}"+    sanitizeText isNested = T.foldl' (sanitizeChar isNested) mempty+    sanitizeChar isNested t = (t <>) . \case+      '$' -> "\\$"+      '\\' -> "\\\\"+      ',' | isNested -> "\\,"+      '|' | isNested -> "\\|"+      c -> T.singleton c++snippetLexOrd :: Snippet -> Snippet -> Ordering+snippetLexOrd = compare `on` snippetToText+ data CompItem = CI   { compKind            :: CompletionItemKind-  , insertText          :: T.Text         -- ^ Snippet for the completion+  , insertText          :: Snippet        -- ^ Snippet for the completion   , provenance          :: Provenance     -- ^ From where this item is imported from.   , label               :: T.Text         -- ^ Label to display to the user.   , typeText            :: Maybe T.Text
src/Development/IDE/Plugin/HLS.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds         #-} {-# LANGUAGE GADTs             #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds         #-}  module Development.IDE.Plugin.HLS     (@@ -10,53 +9,62 @@     , Log(..)     ) where -import           Control.Exception             (SomeException)+import           Control.Exception                (SomeException)+import           Control.Lens                     ((^.)) import           Control.Monad-import           Control.Monad.Trans.Except    (runExceptT)-import qualified Data.Aeson                    as A-import           Data.Bifunctor                (first)-import           Data.Dependent.Map            (DMap)-import qualified Data.Dependent.Map            as DMap+import qualified Control.Monad.Extra              as Extra+import           Control.Monad.IO.Class           (MonadIO)+import           Control.Monad.Trans.Except       (runExceptT)+import qualified Data.Aeson                       as A+import           Data.Bifunctor                   (first)+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.List.NonEmpty            as NE-import qualified Data.Map                      as Map+import qualified Data.List                        as List+import           Data.List.NonEmpty               (NonEmpty, nonEmpty, toList)+import qualified Data.List.NonEmpty               as NE+import qualified Data.Map                         as Map+import           Data.Maybe                       (isNothing, mapMaybe) import           Data.Some import           Data.String-import           Data.Text                     (Text)-import qualified Data.Text                     as T-import           Development.IDE.Core.Shake    hiding (Log)+import           Data.Text                        (Text)+import qualified Data.Text                        as T+import           Development.IDE.Core.PluginUtils (injectServerDiagnostics)+import           Development.IDE.Core.Shake       hiding (Log) import           Development.IDE.Core.Tracing-import           Development.IDE.Graph         (Rules)+import           Development.IDE.Graph            (Rules) import           Development.IDE.LSP.Server import           Development.IDE.Plugin-import qualified Development.IDE.Plugin        as P+import qualified Development.IDE.Plugin           as P import           Ide.Logger import           Ide.Plugin.Config import           Ide.Plugin.Error-import           Ide.PluginUtils               (getClientConfig)-import           Ide.Types                     as HLS+import           Ide.Plugin.HandleRequestTypes+import           Ide.PluginUtils                  (getClientConfig)+import           Ide.Types                        as HLS+import qualified Language.LSP.Protocol.Lens       as JL import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types-import qualified Language.LSP.Server           as LSP+import qualified Language.LSP.Server              as LSP import           Language.LSP.VFS-import           Prettyprinter.Render.String   (renderString)-import           Text.Regex.TDFA.Text          ()-import           UnliftIO                      (MonadUnliftIO, liftIO)-import           UnliftIO.Async                (forConcurrently)-import           UnliftIO.Exception            (catchAny)+import           Prettyprinter.Render.String      (renderString)+import           Text.Regex.TDFA.Text             ()+import           UnliftIO                         (MonadUnliftIO, liftIO,+                                                   readTVarIO)+import           UnliftIO.Async                   (forConcurrently)+import           UnliftIO.Exception               (catchAny)  -- --------------------------------------------------------------------- --  data Log     =  LogPluginError PluginId PluginError-    | LogResponseError PluginId ResponseError+    | forall m . A.ToJSON (ErrorData m) => LogResponseError PluginId (TResponseError m)     | LogNoPluginForMethod (Some SMethod)     | LogInvalidCommandIdentifier     | ExceptionInPlugin PluginId (Some SMethod) SomeException+    | LogResolveDefaultHandler (Some SMethod)  instance Pretty Log where   pretty = \case@@ -65,23 +73,31 @@     LogResponseError (PluginId pId) err ->       pretty pId <> ":" <+> pretty err     LogNoPluginForMethod (Some method) ->-        "No plugin enabled for " <> pretty method+        "No plugin handles this " <> pretty method <> " request."     LogInvalidCommandIdentifier-> "Invalid command identifier"     ExceptionInPlugin plId (Some method) exception ->         "Exception in plugin " <> viaShow plId <> " while processing "           <> pretty method <> ": " <> viaShow exception+    LogResolveDefaultHandler (Some method) ->+        "No plugin can handle" <+> pretty method <+> "request. Return object unchanged." instance Show Log where show = renderString . layoutCompact . pretty -noPluginEnabled :: Recorder (WithPriority Log) -> SMethod m -> [PluginId] -> IO (Either ResponseError c)-noPluginEnabled recorder m fs' = do+noPluginHandles :: Recorder (WithPriority Log) -> SMethod m -> [(PluginId, HandleRequestResult)] -> IO (Either (TResponseError m) c)+noPluginHandles recorder m fs' = do   logWith recorder Warning (LogNoPluginForMethod $ Some m)-  let err = ResponseError (InR ErrorCodes_MethodNotFound) msg Nothing-      msg = pluginNotEnabled m fs'+  let err = TResponseError (InR ErrorCodes_MethodNotFound) msg Nothing+      msg = noPluginHandlesMsg m fs'   return $ Left err-  where pluginNotEnabled :: SMethod m -> [PluginId] -> Text-        pluginNotEnabled method availPlugins =-            "No plugin enabled for " <> T.pack (show method) <> ", potentially available: "-                <> (T.intercalate ", " $ map (\(PluginId plid) -> plid) availPlugins)+  where noPluginHandlesMsg :: SMethod m -> [(PluginId, HandleRequestResult)] -> Text+        noPluginHandlesMsg method [] = "No plugins are available to handle this " <> T.pack (show method) <> " request."+        noPluginHandlesMsg method availPlugins =+            "No plugins are available to handle this " <> T.pack (show method) <> " request.\n Plugins installed for this method, but not available to handle this request are:\n"+                <> (T.intercalate "\n" $+                      map (\(PluginId plid, pluginStatus) ->+                              plid+                              <> " "+                              <> (renderStrict . layoutCompact . pretty) pluginStatus)+                          availPlugins)  pluginDoesntExist :: PluginId -> Text pluginDoesntExist (PluginId pid) = "Plugin " <> pid <> " doesn't exist"@@ -105,9 +121,9 @@     "Exception in plugin " <> T.pack (show plId) <> " while processing "<> T.pack (show method) <> ": " <> T.pack (show exception)  -- | Build a ResponseError and log it before returning to the caller-logAndReturnError :: Recorder (WithPriority Log) -> PluginId -> (LSPErrorCodes |? ErrorCodes) -> Text -> LSP.LspT Config IO (Either ResponseError a)+logAndReturnError :: A.ToJSON (ErrorData m) => Recorder (WithPriority Log) -> PluginId -> (LSPErrorCodes |? ErrorCodes) -> Text -> LSP.LspT Config IO (Either (TResponseError m) a) logAndReturnError recorder p errCode msg = do-    let err = ResponseError errCode msg Nothing+    let err = TResponseError errCode msg Nothing     logWith recorder Warning $ LogResponseError p err     pure $ Left err @@ -169,8 +185,8 @@       _                    -> Nothing      -- The parameters to the HLS command are always the first element-    execCmd :: IdeState -> ExecuteCommandParams -> LSP.LspT Config IO (Either ResponseError (A.Value |? Null))-    execCmd ide (ExecuteCommandParams _ cmdId args) = do+    execCmd :: IdeState -> ExecuteCommandParams -> LSP.LspT Config IO (Either (TResponseError Method_WorkspaceExecuteCommand) (A.Value |? Null))+    execCmd ide (ExecuteCommandParams mtoken cmdId args) = do       let cmdParams :: A.Value           cmdParams = case args of             Just ((x:_)) -> x@@ -189,20 +205,22 @@                 -- If we have a command, continue to execute it                 Just (Command _ innerCmdId innerArgs)                     -> execCmd ide (ExecuteCommandParams Nothing innerCmdId innerArgs)+                -- TODO: This should be a response error?                 Nothing -> return $ Right $ InR Null +            -- TODO: This should be a response error?             A.Error _str -> return $ Right $ InR Null          -- Just an ordinary HIE command-        Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams+        Just (plugin, cmd) -> runPluginCommand ide plugin cmd mtoken cmdParams          -- Couldn't parse the command identifier         _ -> do             logWith recorder Warning LogInvalidCommandIdentifier-            return $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Invalid command identifier" Nothing+            return $ Left $ TResponseError (InR ErrorCodes_InvalidParams) "Invalid command identifier" Nothing -    runPluginCommand :: IdeState -> PluginId -> CommandId -> A.Value -> LSP.LspT Config IO (Either ResponseError (A.Value |? Null))-    runPluginCommand ide p com arg =+    runPluginCommand :: IdeState -> PluginId -> CommandId -> Maybe ProgressToken -> A.Value -> LSP.LspT Config IO (Either (TResponseError Method_WorkspaceExecuteCommand) (A.Value |? Null))+    runPluginCommand ide p com mtoken arg =       case Map.lookup p pluginMap  of         Nothing -> logAndReturnError recorder p (InR ErrorCodes_InvalidRequest) (pluginDoesntExist p)         Just xs -> case List.find ((com ==) . commandId) xs of@@ -210,11 +228,11 @@           Just (PluginCommand _ _ f) -> case A.fromJSON arg of             A.Error err -> logAndReturnError recorder p (InR ErrorCodes_InvalidParams) (failedToParseArgs com p err arg)             A.Success a -> do-              res <- runExceptT (f ide a) `catchAny` -- See Note [Exception handling in plugins]+              res <- runHandlerM (runExceptT (f ide mtoken a)) `catchAny` -- See Note [Exception handling in plugins]                 (\e -> pure $ Left $ PluginInternalError (exceptionInPlugin p SMethod_WorkspaceExecuteCommand e))               case res of-                (Left (PluginRequestRefused _)) ->-                  liftIO $ noPluginEnabled recorder SMethod_WorkspaceExecuteCommand (fst <$> ecs)+                (Left (PluginRequestRefused r)) ->+                  liftIO $ noPluginHandles recorder SMethod_WorkspaceExecuteCommand [(p,DoesNotHandleRequest r)]                 (Left pluginErr) -> do                   liftIO $ logErrors recorder [(p, pluginErr)]                   pure $ Left $ toResponseError (p, pluginErr)@@ -234,16 +252,28 @@         PluginHandlers hs = HLS.pluginHandlers pluginDesc     handlers = mconcat $ do       (IdeMethod m :=> IdeHandler fs') <- DMap.assocs handlers'-      pure $ requestHandler m $ \ide params -> do+      pure $ requestHandler m $ \ide params' -> do+        vfs <- readTVarIO $ vfsVar $ shakeExtras ide+        params <- liftIO $ preprocessMessageParams ide m params'         config <- Ide.PluginUtils.getClientConfig-        -- Only run plugins that are allowed to run on this request-        let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs'+        -- Only run plugins that are allowed to run on this request, save the+        -- list of disabled plugins incase that's all we have+        let (fs, dfs) = List.partition (\(_, desc, _) -> handlesRequest vfs m params desc config == HandlesRequest) fs'+        let disabledPluginsReason = (\(x, desc, _) -> (x, handlesRequest vfs m params desc config)) <$> dfs         -- Clients generally don't display ResponseErrors so instead we log any that we come across+        -- However, some clients do display ResponseErrors! See for example the issues:+        -- https://github.com/haskell/haskell-language-server/issues/4467+        -- https://github.com/haskell/haskell-language-server/issues/4451         case nonEmpty fs of-          Nothing -> liftIO $ noPluginEnabled recorder m ((\(x, _, _) -> x) <$> fs')+          Nothing -> do+            liftIO (fallbackResolveHandler recorder m params) >>= \case+              Nothing ->+                liftIO $ noPluginHandles recorder m disabledPluginsReason+              Just result ->+                pure $ Right result           Just neFs -> do             let  plidsAndHandlers = fmap (\(plid,_,handler) -> (plid,handler)) neFs-            es <- runConcurrently exceptionInPlugin m plidsAndHandlers ide params+            es <- runHandlerM $ runConcurrently exceptionInPlugin m plidsAndHandlers ide params             caps <- LSP.getClientCapabilities             let (errs,succs) = partitionEithers $ toList $ join $ NE.zipWith (\(pId,_) -> fmap (first (pId,))) plidsAndHandlers es             liftIO $ unless (null errs) $ logErrors recorder errs@@ -251,14 +281,95 @@               Nothing -> do                 let noRefused (_, PluginRequestRefused _) = False                     noRefused (_, _)                      = True-                    filteredErrs = filter noRefused errs-                case nonEmpty filteredErrs of-                  Nothing -> liftIO $ noPluginEnabled recorder m ((\(x, _, _) -> x) <$> fs')+                    (asErrors, asRefused) = List.partition noRefused errs+                    convertPRR (pId, PluginRequestRefused r) = Just (pId, DoesNotHandleRequest r)+                    convertPRR _ = Nothing+                    asRefusedReason = mapMaybe convertPRR asRefused+                case nonEmpty asErrors of+                  Nothing -> liftIO $ noPluginHandles recorder m  (disabledPluginsReason <> asRefusedReason)                   Just xs -> pure $ Left $ combineErrors xs               Just xs -> do                 pure $ Right $ combineResponses m config caps params xs  +-- | Preprocess 'MessageParams' and insert custom data.+--+-- In issue https://github.com/haskell/haskell-language-server/issues/4056, we+-- established that HLS should rely on server-side 'Diagnostic's to compute 'CodeAction's+-- To ensure consistency, we intercept 'CodeAction's requests and explicitly inject+-- server-side 'Diagnostic's before delegating to the 'PluginHandler'.+preprocessMessageParams :: IdeState -> SMethod m -> MessageParams m -> IO (MessageParams m)+preprocessMessageParams ide m params = case m of+    SMethod_TextDocumentCodeAction -> injectServerDiagnostics ide params+    _                              -> pure params++-- | Fallback Handler for resolve requests.+-- For all kinds of `*/resolve` requests, if they don't have a 'data_' value,+-- produce the original item, since no other plugin has any resolve data.+--+-- This is an internal handler, so it cannot be turned off and should be opaque+-- to the end-user.+-- This function does not take the ServerCapabilities into account, and assumes+-- clients will only send these requests, if and only if the Language Server+-- advertised support for it.+--+-- See Note [Fallback Handler for LSP resolve requests] for justification and reasoning.+fallbackResolveHandler :: MonadIO m => Recorder (WithPriority Log) -> SMethod s -> MessageParams s -> m (Maybe (MessageResult s))+fallbackResolveHandler recorder m params = do+    let result = case m of+          SMethod_InlayHintResolve+              | noResolveData params -> Just params+          SMethod_CompletionItemResolve+              | noResolveData params -> Just params+          SMethod_CodeActionResolve+              | noResolveData params -> Just params+          SMethod_WorkspaceSymbolResolve+              | noResolveData params -> Just params+          SMethod_CodeLensResolve+              | noResolveData params -> Just params+          SMethod_DocumentLinkResolve+              | noResolveData params -> Just params+          _ -> Nothing+    logResolveHandling result+    pure result+    where+        noResolveData :: JL.HasData_ p (Maybe a) => p -> Bool+        noResolveData p = isNothing $ p ^. JL.data_++        -- We only log if we are handling the request.+        -- If we don't handle this request, this should be logged+        -- on call-site.+        logResolveHandling p = Extra.whenJust p $ \_ -> do+          logWith recorder Debug $ LogResolveDefaultHandler (Some m)++{- Note [Fallback Handler for LSP resolve requests]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We have a special fallback for `*/resolve` requests.++We had multiple reports, where `resolve` requests (such as+`completion/resolve` and `codeAction/resolve`) are rejected+by HLS since the `_data_` field of the respective LSP feature has not been+populated by HLS.+This makes sense, as we only support `resolve` for certain kinds of+`CodeAction`/`Completions`, when they contain particularly expensive+properties, such as documentation or non-local type signatures.++So what to do? We can see two options:++1. Be dumb and permissive: if no plugin wants to resolve a request, then+   just respond positively with the original item! Potentially this masks+   real issues, but may not be too bad. If a plugin thinks it can+   handle the request but it then fails to resolve it, we should still return a failure.+2. Try and be smart: we try to figure out requests that we're "supposed" to+   resolve (e.g. those with a data field), and fail if no plugin wants to handle those.+   This is possible since we set data.+   So as long as we maintain the invariant that only things which need resolving get+   data, then it could be okay.++In 'fallbackResolveHandler', we implement the option (2).+-}+ -- ---------------------------------------------------------------------  extensibleNotificationPlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config@@ -274,8 +385,8 @@       (IdeNotification m :=> IdeNotificationHandler fs') <- DMap.assocs handlers'       pure $ notificationHandler m $ \ide vfs params -> do         config <- Ide.PluginUtils.getClientConfig-        -- Only run plugins that are allowed to run on this request-        let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs'+        -- Only run plugins that are enabled for this request+        let fs = filter (\(_, desc, _) -> handlesRequest vfs m params desc config == HandlesRequest) fs'         case nonEmpty fs of           Nothing -> do             logWith recorder Warning (LogNoPluginForMethod $ Some m)@@ -302,13 +413,13 @@   f a b  -- See Note [Exception handling in plugins]      `catchAny` (\e -> pure $ pure $ Left $ PluginInternalError (msg pid method e)) -combineErrors :: NonEmpty (PluginId, PluginError) -> ResponseError+combineErrors :: NonEmpty (PluginId, PluginError) -> TResponseError m combineErrors (x NE.:| []) = toResponseError x combineErrors xs = toResponseError $ NE.last $ NE.sortWith (toPriority . snd) xs -toResponseError :: (PluginId, PluginError) -> ResponseError+toResponseError :: (PluginId, PluginError) -> TResponseError m toResponseError (PluginId plId, err) =-        ResponseError (toErrorCode err) (plId <> ": " <> tPretty err) Nothing+        TResponseError (toErrorCode err) (plId <> ": " <> tPretty err) Nothing     where tPretty = T.pack . show . pretty  logErrors :: Recorder (WithPriority Log) -> [(PluginId, PluginError)] -> IO ()@@ -321,7 +432,7 @@  -- | Combine the 'PluginHandler' for all plugins newtype IdeHandler (m :: Method ClientToServer Request)-  = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either PluginError (MessageResult m))))]+  = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> HandlerM Config (NonEmpty (Either PluginError (MessageResult m))))]  -- | Combine the 'PluginHandler' for all plugins newtype IdeNotificationHandler (m :: Method ClientToServer Notification)@@ -347,6 +458,7 @@   mempty = IdeNotificationHandlers mempty  {- Note [Exception handling in plugins]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Plugins run in LspM, and so have access to IO. This means they are likely to throw exceptions, even if only by accident or through calling libraries that throw exceptions. Ultimately, we're running a bunch of less-trusted IO code,
src/Development/IDE/Plugin/HLS/GhcIde.hs view
@@ -7,9 +7,9 @@     descriptors   , Log(..)   ) where-import           Control.Monad.IO.Class+ import           Development.IDE-import           Development.IDE.LSP.HoverDefinition+import qualified Development.IDE.LSP.HoverDefinition as Hover import qualified Development.IDE.LSP.Notifications   as Notifications import           Development.IDE.LSP.Outline import qualified Development.IDE.Plugin.Completions  as Completions@@ -23,6 +23,7 @@   = LogNotifications Notifications.Log   | LogCompletions Completions.Log   | LogTypeLenses TypeLenses.Log+  | LogHover Hover.Log   deriving Show  instance Pretty Log where@@ -30,10 +31,11 @@     LogNotifications msg -> pretty msg     LogCompletions msg   -> pretty msg     LogTypeLenses msg    -> pretty msg+    LogHover msg         -> pretty msg  descriptors :: Recorder (WithPriority Log) -> [PluginDescriptor IdeState] descriptors recorder =-  [ descriptor "ghcide-hover-and-symbols",+  [ descriptor (cmapWithPrio LogHover recorder) "ghcide-hover-and-symbols",     Completions.descriptor (cmapWithPrio LogCompletions recorder) "ghcide-completions",     TypeLenses.descriptor (cmapWithPrio LogTypeLenses recorder) "ghcide-type-lenses",     Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"@@ -41,25 +43,28 @@  -- --------------------------------------------------------------------- -descriptor :: PluginId -> PluginDescriptor IdeState-descriptor plId = (defaultPluginDescriptor plId)-  { pluginHandlers = mkPluginHandler SMethod_TextDocumentHover hover'+descriptor :: Recorder (WithPriority Hover.Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId = (defaultPluginDescriptor plId desc)+  { pluginHandlers = mkPluginHandler SMethod_TextDocumentHover (hover' recorder)                   <> mkPluginHandler SMethod_TextDocumentDocumentSymbol moduleOutline                   <> mkPluginHandler SMethod_TextDocumentDefinition (\ide _ DefinitionParams{..} ->-                      gotoDefinition ide TextDocumentPositionParams{..})+                      Hover.gotoDefinition recorder ide TextDocumentPositionParams{..})                   <> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} ->-                      gotoTypeDefinition ide TextDocumentPositionParams{..})+                      Hover.gotoTypeDefinition recorder ide TextDocumentPositionParams{..})+                  <> mkPluginHandler SMethod_TextDocumentImplementation (\ide _ ImplementationParams{..} ->+                      Hover.gotoImplementation recorder ide TextDocumentPositionParams{..})                   <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} ->-                      documentHighlight ide TextDocumentPositionParams{..})-                  <> mkPluginHandler SMethod_TextDocumentReferences references-                  <> mkPluginHandler SMethod_WorkspaceSymbol wsSymbols,+                      Hover.documentHighlight recorder ide TextDocumentPositionParams{..})+                  <> mkPluginHandler SMethod_TextDocumentReferences (Hover.references recorder)+                  <> mkPluginHandler SMethod_WorkspaceSymbol (Hover.wsSymbols recorder),      pluginConfigDescriptor = defaultConfigDescriptor   }+  where+    desc = "Provides core IDE features for Haskell"  -- --------------------------------------------------------------------- -hover' :: PluginMethodHandler IdeState Method_TextDocumentHover-hover' ideState _ HoverParams{..} = do-    liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ-    hover ideState TextDocumentPositionParams{..}+hover' :: Recorder (WithPriority Hover.Log) -> PluginMethodHandler IdeState Method_TextDocumentHover+hover' recorder ideState _ HoverParams{..} =+    Hover.hover recorder ideState TextDocumentPositionParams{..}
src/Development/IDE/Plugin/Test.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs              #-} {-# LANGUAGE PackageImports     #-}-{-# LANGUAGE PolyKinds          #-} -- | A plugin that adds custom messages for use in tests module Development.IDE.Plugin.Test   ( TestRequest(..)@@ -13,6 +12,7 @@   ) where  import           Control.Concurrent                   (threadDelay)+import qualified Control.Exception                    as E import           Control.Monad import           Control.Monad.Except                 (ExceptT (..), throwError) import           Control.Monad.IO.Class@@ -24,6 +24,7 @@ import           Data.Bifunctor import           Data.CaseInsensitive                 (CI, original) import qualified Data.HashMap.Strict                  as HM+import qualified Data.HashSet                         as Set import           Data.Maybe                           (isJust) import           Data.Proxy import           Data.String@@ -42,6 +43,8 @@ import           Development.IDE.Graph.Internal.Types (Result (resultBuilt, resultChanged, resultVisited),                                                        Step (Step)) import qualified Development.IDE.Graph.Internal.Types as Graph+import           Development.IDE.Session              (clearSessionLoaderPendingBarrier,+                                                       setSessionLoaderPendingBarrier) import           Development.IDE.Types.Action import           Development.IDE.Types.HscEnvEq       (HscEnvEq (hscEnv)) import           Development.IDE.Types.Location       (fromUri)@@ -50,7 +53,6 @@ import           Ide.Types import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types-import qualified Language.LSP.Server                  as LSP import qualified "list-t" ListT import qualified StmContainers.Map                    as STM import           System.Time.Extra@@ -62,6 +64,7 @@     | GetShakeSessionQueueCount      -- ^ :: Number     | WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null     | WaitForIdeRule String Uri      -- ^ :: WaitForIdeRuleResult+    | WaitForIdeRules String [Uri]   -- ^ :: [WaitForIdeRuleResult]     | GetBuildKeysVisited        -- ^ :: [(String]     | GetBuildKeysBuilt          -- ^ :: [(String]     | GetBuildKeysChanged        -- ^ :: [(String]@@ -77,7 +80,7 @@     deriving newtype (FromJSON, ToJSON)  plugin :: PluginDescriptor IdeState-plugin = (defaultPluginDescriptor "test") {+plugin = (defaultPluginDescriptor "test" "") {     pluginHandlers = mkPluginHandler (SMethod_CustomMethod (Proxy @"test")) $ \st _ ->         testRequestHandler' st     }@@ -92,9 +95,9 @@  testRequestHandler ::  IdeState                 -> TestRequest-                -> LSP.LspM c (Either PluginError Value)+                -> HandlerM config (Either PluginError Value) testRequestHandler _ (BlockSeconds secs) = do-    LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/request")) $+    pluginSendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/request")) $       toJSON secs     liftIO $ sleep secs     return (Right A.Null)@@ -116,6 +119,17 @@     success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp     let res = WaitForIdeRuleResult <$> success     return $ bimap PluginInvalidParams toJSON res+testRequestHandler s (WaitForIdeRules k files) = liftIO $ do+    let nfps = fmap (fromUri . toNormalizedUri) files+        uniqueCount = Set.size (Set.fromList nfps)+        act = runAction ("WaitForIdeRules " <> k <> " " <> show files) s $ parseActions (fromString k) nfps+    success <-+      if uniqueCount > 0+        then (setSessionLoaderPendingBarrier s uniqueCount >> act)+              `E.finally` clearSessionLoaderPendingBarrier s+        else act+    let res = fmap (fmap WaitForIdeRuleResult) success+    return $ bimap PluginInvalidParams toJSON res testRequestHandler s GetBuildKeysBuilt = liftIO $ do     keys <- getDatabaseKeys resultBuilt $ shakeDb s     return $ Right $ toJSON $ map show keys@@ -161,17 +175,29 @@ parseAction "getFileContents" fp = Right . isJust <$> use GetFileContents fp parseAction other _ = return $ Left $ "Cannot parse ide rule: " <> pack (original other) +parseActions :: CI String -> [NormalizedFilePath] -> Action (Either Text [Bool])+parseActions "typecheck" fps = Right . fmap isJust <$> uses TypeCheck fps+parseActions "getLocatedImports" fps = Right . fmap isJust <$> uses GetLocatedImports fps+parseActions "getmodsummary" fps = Right . fmap isJust <$> uses GetModSummary fps+parseActions "getmodsummarywithouttimestamps" fps = Right . fmap isJust <$> uses GetModSummaryWithoutTimestamps fps+parseActions "getparsedmodule" fps = Right . fmap isJust <$> uses GetParsedModule fps+parseActions "ghcsession" fps = Right . fmap isJust <$> uses GhcSession fps+parseActions "ghcsessiondeps" fps = Right . fmap isJust <$> uses GhcSessionDeps fps+parseActions "gethieast" fps = Right . fmap isJust <$> uses GetHieAst fps+parseActions "getFileContents" fps = Right . fmap isJust <$> uses GetFileContents fps+parseActions 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) {+blockCommandDescriptor plId = (defaultPluginDescriptor plId "") {     pluginCommands = [PluginCommand (CommandId blockCommandId) "blocks forever" blockCommandHandler] }  blockCommandHandler :: CommandFunction state ExecuteCommandParams-blockCommandHandler _ideState _params = do-  lift $ LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/command")) A.Null+blockCommandHandler _ideState _ _params = do+  lift $ pluginSendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/command")) A.Null   liftIO $ threadDelay maxBound   pure $ InR Null
src/Development/IDE/Plugin/TypeLenses.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP              #-} {-# LANGUAGE DeriveAnyClass   #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeFamilies     #-}@@ -15,7 +16,7 @@  import           Control.Concurrent.STM.Stats         (atomically) import           Control.DeepSeq                      (rwhnf)-import           Control.Lens                         ((?~))+import           Control.Lens                         ((?~), (^?)) import           Control.Monad                        (mzero) import           Control.Monad.Extra                  (whenMaybe) import           Control.Monad.IO.Class               (MonadIO (liftIO))@@ -24,12 +25,17 @@ import qualified Data.Aeson.Types                     as A import           Data.List                            (find) import qualified Data.Map                             as Map-import           Data.Maybe                           (catMaybes, maybeToList)+import           Data.Maybe                           (catMaybes, isJust,+                                                       maybeToList) import qualified Data.Text                            as T-import           Development.IDE                      (GhcSession (..),+import           Development.IDE                      (FileDiagnostic (..),+                                                       GhcSession (..),                                                        HscEnvEq (hscEnv),                                                        RuleResult, Rules, Uri,-                                                       define, srcSpanToRange,+                                                       _SomeStructuredMessage,+                                                       define,+                                                       fdStructuredMessageL,+                                                       srcSpanToRange,                                                        usePropertyAction) import           Development.IDE.Core.Compile         (TcModuleResult (..)) import           Development.IDE.Core.PluginUtils@@ -43,10 +49,14 @@                                                        use) import qualified Development.IDE.Core.Shake           as Shake import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat.Error     (_TcRnMessage,+                                                       _TcRnMissingSignature,+                                                       msgEnvelopeErrorL) import           Development.IDE.GHC.Util             (printName) import           Development.IDE.Graph.Classes import           Development.IDE.Types.Location       (Position (Position, _line),                                                        Range (Range, _end, _start))+import           GHC.Core.TyCo.Tidy                   (tidyOpenType) import           GHC.Generics                         (Generic) import           Ide.Logger                           (Pretty (pretty),                                                        Recorder, WithPriority,@@ -66,7 +76,8 @@                                                        defaultPluginDescriptor,                                                        mkCustomConfig,                                                        mkPluginHandler,-                                                       mkResolveHandler)+                                                       mkResolveHandler,+                                                       pluginSendRequest) import qualified Language.LSP.Protocol.Lens           as L import           Language.LSP.Protocol.Message        (Method (Method_CodeLensResolve, Method_TextDocumentCodeLens),                                                        SMethod (..))@@ -79,8 +90,6 @@                                                        TextEdit (TextEdit),                                                        WorkspaceEdit (WorkspaceEdit),                                                        type (|?) (..))-import qualified Language.LSP.Server                  as LSP-import           Text.Regex.TDFA                      ((=~))  data Log = LogShake Shake.Log deriving Show @@ -94,13 +103,15 @@  descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId =-  (defaultPluginDescriptor plId)+  (defaultPluginDescriptor plId desc)     { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens codeLensProvider                     <> mkResolveHandler SMethod_CodeLensResolve codeLensResolveProvider     , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler]     , pluginRules = rules recorder     , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}     }+  where+    desc = "Provides code lenses type signatures"  properties :: Properties '[ 'PropertyKey "mode" (TEnum Mode)] properties = emptyProperties@@ -124,8 +135,9 @@           -- We don't actually pass any data to resolve, however we need this           -- dummy type to make sure HLS resolves our lens           [ CodeLens _range Nothing (Just $ toJSON TypeLensesResolve)-            | (dFile, _, diag@Diagnostic{_range}) <- diags-            , dFile == nfp+            | diag <- diags+            , let Diagnostic {_range} = fdLspDiagnostic diag+            , fdFilePath diag == nfp             , isGlobalDiagnostic diag]         -- The second option is to generate lenses from the GlobalBindingTypeSig         -- rule. This is the only type that needs to have the range adjusted@@ -181,7 +193,7 @@  generateLensCommand :: PluginId -> Uri -> T.Text -> TextEdit -> Command generateLensCommand pId uri title edit =-  let wEdit = WorkspaceEdit (Just $ Map.singleton uri $ [edit]) Nothing Nothing+  let wEdit = WorkspaceEdit (Just $ Map.singleton uri [edit]) Nothing Nothing   in mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON wEdit])  -- Since the lenses are created with diagnostics, and since the globalTypeSig@@ -190,12 +202,12 @@ -- recompute the edit upon command. Hence the command here just takes a edit -- and applies it. commandHandler :: CommandFunction IdeState WorkspaceEdit-commandHandler _ideState wedit = do-  _ <- lift $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())+commandHandler _ideState _ wedit = do+  _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())   pure $ InR Null  ---------------------------------------------------------------------------------suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, TextEdit)]+suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> FileDiagnostic -> [(T.Text, TextEdit)] suggestSignature isQuickFix mGblSigs diag =   maybeToList (suggestGlobalSignature isQuickFix mGblSigs diag) @@ -203,14 +215,19 @@ -- works with a diagnostic, which then calls the secondary function with -- whatever pieces of the diagnostic it needs. This allows the resolve function, -- which no longer has the Diagnostic, to still call the secondary functions.-suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> Maybe (T.Text, TextEdit)-suggestGlobalSignature isQuickFix mGblSigs diag@Diagnostic{_range}+suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> FileDiagnostic -> Maybe (T.Text, TextEdit)+suggestGlobalSignature isQuickFix mGblSigs diag@FileDiagnostic {fdLspDiagnostic = Diagnostic {_range}}   | isGlobalDiagnostic diag =     suggestGlobalSignature' isQuickFix mGblSigs Nothing _range   | otherwise = Nothing -isGlobalDiagnostic :: Diagnostic -> Bool-isGlobalDiagnostic Diagnostic{_message} = _message =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text)+isGlobalDiagnostic :: FileDiagnostic -> Bool+isGlobalDiagnostic diag = diag ^? fdStructuredMessageL+                                  . _SomeStructuredMessage+                                  . msgEnvelopeErrorL+                                  .  _TcRnMessage+                                  . _TcRnMissingSignature+                                & isJust  -- If a PositionMapping is supplied, this function will call -- gblBindingTypeSigToEdit with it to create a TextEdit in the right location.@@ -317,7 +334,11 @@         let name = idName identifier         hasSig name $ do           env <- tcInitTidyEnv+#if MIN_VERSION_ghc(9,11,0)+          let ty = tidyOpenType env (idType identifier)+#else           let (_, ty) = tidyOpenType env (idType identifier)+#endif           pure $ GlobalBindingTypeSig name (printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports)       patToSig p = do         let name = patSynName p
src/Development/IDE/Spans/AtPoint.hs view
@@ -1,10 +1,8 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP                 #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP   #-}+{-# LANGUAGE GADTs #-}  -- | Gives information about symbols at a given point in DAML files. -- These are all pure functions that should execute quickly.@@ -12,6 +10,7 @@     atPoint   , gotoDefinition   , gotoTypeDefinition+  , gotoImplementation   , documentHighlight   , pointCommand   , referencesAtPoint@@ -25,6 +24,10 @@   , LookupModule   ) where ++import           GHC.Data.FastString                  (lengthFS)+import qualified GHC.Utils.Outputable                 as O+ import           Development.IDE.GHC.Error import           Development.IDE.GHC.Orphans          () import           Development.IDE.Types.Location@@ -33,15 +36,16 @@ import           Prelude                              hiding (mod)  -- compiler and infrastructure+import           Development.IDE.Core.Compile         (setNonHomeFCHook) import           Development.IDE.Core.PositionMapping import           Development.IDE.Core.RuleTypes import           Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat.Util      as Util-import           Development.IDE.GHC.Util             (printOutputable)+import           Development.IDE.GHC.Util             (printOutputable,+                                                       printOutputableOneLine) import           Development.IDE.Spans.Common import           Development.IDE.Types.Options -import           Control.Applicative import           Control.Monad.Extra import           Control.Monad.IO.Class import           Control.Monad.Trans.Class@@ -54,19 +58,45 @@  import qualified Data.Array                           as A import           Data.Either-import           Data.List                            (isSuffixOf) import           Data.List.Extra                      (dropEnd1, nubOrd) ++import           Control.Lens                         ((^.))+import           Data.Either.Extra                    (eitherToMaybe)+import           Data.List                            (isSuffixOf, sortOn)+import           Data.Set                             (Set)+import qualified Data.Set                             as S+import           Data.Tree+import qualified Data.Tree                            as T import           Data.Version                         (showVersion)+import           Development.IDE.Core.LookupMod       (LookupModule, lookupMod)+import           Development.IDE.Core.Shake           (ShakeExtras (..),+                                                       runIdeAction) import           Development.IDE.Types.Shake          (WithHieDb)+import           GHC.Iface.Ext.Types                  (EvVarSource (..),+                                                       HieAST (..),+                                                       HieASTs (..),+                                                       HieArgs (..),+                                                       HieType (..),+                                                       HieTypeFix (..),+                                                       Identifier,+                                                       IdentifierDetails (..),+                                                       NodeInfo (..), Scope,+                                                       Span)+import           GHC.Iface.Ext.Utils                  (EvidenceInfo (..),+                                                       RefMap, getEvidenceTree,+                                                       getScopeFromContext,+                                                       hieTypeToIface,+                                                       isEvidenceContext,+                                                       isEvidenceUse,+                                                       isOccurrence, nodeInfo,+                                                       recoverFullType,+                                                       selectSmallestContaining) import           HieDb                                hiding (pointCommand,                                                        withHieDb)+import qualified Language.LSP.Protocol.Lens           as L import           System.Directory                     (doesFileExist) --- | 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 -> Unit -> Bool -> MaybeT m Uri- -- | HieFileResult for files of interest, along with the position mappings newtype FOIReferences = FOIReferences (HM.HashMap NormalizedFilePath (HieAstResult, PositionMapping)) @@ -97,15 +127,15 @@           adjustedLocs = HM.foldr go [] asts           go (HAR _ _ rf tr _, goMapping) xs = refs ++ typerefs ++ xs             where-              refs = mapMaybe (toCurrentLocation goMapping . realSrcSpanToLocation . fst)-                   $ concat $ mapMaybe (\n -> M.lookup (Right n) rf) names-              typerefs = mapMaybe (toCurrentLocation goMapping . realSrcSpanToLocation)-                   $ concat $ mapMaybe (`M.lookup` tr) names+              refs = concatMap (mapMaybe (toCurrentLocation goMapping . realSrcSpanToLocation . fst))+                               (mapMaybe (\n -> M.lookup (Right n) rf) names)+              typerefs = concatMap (mapMaybe (toCurrentLocation goMapping . realSrcSpanToLocation))+                                   (mapMaybe (`M.lookup` tr) names)         in (names, adjustedLocs,map fromNormalizedFilePath $ HM.keys asts)  getNamesAtPoint :: HieASTs a -> Position -> PositionMapping -> [Name] getNamesAtPoint hf pos mapping =-  concat $ pointCommand hf posFile (rights . M.keys . getNodeIds)+  concat $ pointCommand hf posFile (rights . M.keys . getSourceNodeIds)     where       posFile = fromMaybe pos $ fromCurrentPosition mapping pos @@ -169,18 +199,23 @@   where     -- We don't want to show document highlights for evidence variables, which are supposed to be invisible     notEvidence = not . any isEvidenceContext . identInfo-    ns = concat $ pointCommand hf pos (rights . M.keys . M.filter notEvidence . getNodeIds)+    ns = concat $ pointCommand hf pos (rights . M.keys . M.filter notEvidence . getSourceNodeIds)     highlights = do       n <- ns       ref <- fromMaybe [] (M.lookup (Right n) rf)-      pure $ makeHighlight ref-    makeHighlight (sp,dets) =-      DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets)+      maybeToList (makeHighlight n ref)+    makeHighlight n (sp,dets)+      | isTvNameSpace (nameNameSpace n) && isBadSpan n sp = Nothing+      | otherwise = Just $ DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets)     highlightType s =       if any (isJust . getScopeFromContext) s         then DocumentHighlightKind_Write         else DocumentHighlightKind_Read +    isBadSpan :: Name -> RealSrcSpan -> Bool+    isBadSpan n sp = srcSpanStartLine sp /= srcSpanEndLine sp || (srcSpanEndCol sp - srcSpanStartCol sp > lengthFS (occNameFS $ nameOccName n))++-- | Locate the type definition of the name at a given position. gotoTypeDefinition   :: MonadIO m   => WithHieDb@@ -188,7 +223,7 @@   -> IdeOptions   -> HieAstResult   -> Position-  -> MaybeT m [Location]+  -> MaybeT m [(Location, Identifier)] gotoTypeDefinition withHieDb lookupModule ideOpts srcSpans pos   = lift $ typeLocationsAtPoint withHieDb lookupModule ideOpts pos srcSpans @@ -199,67 +234,104 @@   -> LookupModule m   -> IdeOptions   -> M.Map ModuleName NormalizedFilePath-  -> HieASTs a+  -> HieAstResult   -> Position-  -> MaybeT m [Location]+  -> MaybeT m [(Location, Identifier)] gotoDefinition withHieDb getHieFile ideOpts imports srcSpans pos   = lift $ locationsAtPoint withHieDb getHieFile ideOpts imports pos srcSpans +-- | Locate the implementation definition of the name at a given position.+-- Goto Implementation for an overloaded function.+gotoImplementation+  :: MonadIO m+  => WithHieDb+  -> LookupModule m+  -> IdeOptions+  -> HieAstResult+  -> Position+  -> MaybeT m [Location]+gotoImplementation withHieDb getHieFile ideOpts srcSpans pos+  = lift $ instanceLocationsAtPoint withHieDb getHieFile ideOpts pos srcSpans+ -- | Synopsis for the name at a given position. atPoint   :: IdeOptions+  -> ShakeExtras   -> HieAstResult-  -> DocAndKindMap+  -> DocAndTyThingMap   -> HscEnv   -> Position+  -> Util.EnumSet Extension   -> IO (Maybe (Maybe Range, [T.Text]))-atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env pos =+atPoint opts@IdeOptions{} shakeExtras@ShakeExtras{ withHieDb, hiedbWriter } har@(HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (DKMap dm km _am) env pos enabledExtensions =     listToMaybe <$> sequence (pointCommand hf pos hoverInfo)   where     -- Hover info for values/data     hoverInfo :: HieAST hietype -> IO (Maybe Range, [T.Text])     hoverInfo ast = do-        prettyNames <- mapM prettyName filteredNames-        pure (Just range, prettyNames ++ pTypes)+        locationsWithIdentifier <- runIdeAction "TypeCheck" shakeExtras $ do+          runMaybeT $ gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts har pos++        let locationsMap = M.fromList $ mapMaybe (\(loc, identifier) -> case identifier of+              Right typeName ->+                -- Filter out type variables (polymorphic names like 'a', 'b', etc.)+                if isTyVarName typeName+                  then Nothing+                  else Just (typeName, loc)+              Left _moduleName -> Nothing) $ fromMaybe [] locationsWithIdentifier++        prettyNames <- mapM (prettyName locationsMap) names+        pure (Just range, prettyNames ++ pTypes locationsMap)       where-        pTypes :: [T.Text]-        pTypes-          | Prelude.length names == 1 = dropEnd1 $ map wrapHaskell prettyTypes-          | otherwise = map wrapHaskell prettyTypes+        pTypes :: M.Map Name Location -> [T.Text]+        pTypes locationsMap =+          case names of+            [_singleName] -> dropEnd1 $ prettyTypes Nothing locationsMap+            _             -> prettyTypes Nothing locationsMap          range :: Range         range = realSrcSpanToRange $ nodeSpan ast -        wrapHaskell :: T.Text -> T.Text-        wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n"-         info :: NodeInfo hietype         info = nodeInfoH kind ast +        -- We want evidence variables to be displayed last.+        -- Evidence trees contain information of secondary relevance.         names :: [(Identifier, IdentifierDetails hietype)]-        names = M.assocs $ nodeIdentifiers info--        -- Check for evidence bindings-        isInternal :: (Identifier, IdentifierDetails a) -> Bool-        isInternal (Right _, dets) =-          any isEvidenceContext $ identInfo dets-        isInternal (Left _, _) = False+        names = sortOn (any isEvidenceUse . identInfo . snd) $ M.assocs $ nodeIdentifiers info -        filteredNames :: [(Identifier, IdentifierDetails hietype)]-        filteredNames = filter (not . isInternal) names+        prettyName :: M.Map Name Location -> (Either ModuleName Name, IdentifierDetails hietype) -> IO T.Text+        prettyName locationsMap (Right n, dets)+          -- We want to print evidence variable using a readable tree structure.+          -- Evidence variables contain information why a particular instance or+          -- type equality was chosen, paired with location information.+          | any isEvidenceUse (identInfo dets) =+            let+              -- The evidence tree may not be present for some reason, e.g., the 'Name' is not+              -- present in the tree.+              -- Thus, we need to handle it here, but in practice, this should never be 'Nothing'.+              evidenceTree = maybe "" (printOutputable . renderEvidenceTree) (getEvidenceTree rf n)+            in+              pure $ evidenceTree <> "\n"+          -- Identifier details that are not evidence variables are used to display type information and+          -- documentation of that name.+          | otherwise = do+            let+              typeSig = case identType dets of+                Just t -> prettyType (Just n) locationsMap t+                Nothing -> case safeTyThingType (Util.member LinearTypes enabledExtensions) =<< lookupNameEnv km n of+                  Just kind -> prettyTypeFromType (Just n) locationsMap kind+                  Nothing   -> wrapHaskell (printOutputable n)+              definitionLoc = maybeToList (pretty (definedAt n) (prettyPackageName n))+              docs = maybeToList (T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n) -        prettyName :: (Either ModuleName Name, IdentifierDetails hietype) -> IO T.Text-        prettyName (Right n, dets) = pure $ T.unlines $-          wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind))-          : maybeToList (pretty (definedAt n) (prettyPackageName n))-          ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n-                       ]-          where maybeKind = fmap printOutputable $ safeTyThingType =<< lookupNameEnv km n+            pure $ T.unlines $ [typeSig] ++ definitionLoc ++ docs+          where                 pretty Nothing Nothing = Nothing                 pretty (Just define) Nothing = Just $ define <> "\n"                 pretty Nothing (Just pkgName) = Just $ pkgName <> "\n"                 pretty (Just define) (Just pkgName) = Just $ define <> " " <> pkgName <> "\n"-        prettyName (Left m,_) = packageNameForImportStatement m+        prettyName _locationsMap (Left m,_) = packageNameForImportStatement m          prettyPackageName :: Name -> Maybe T.Text         prettyPackageName n = do@@ -271,7 +343,7 @@         -- the package(with version) this `ModuleName` belongs to.         packageNameForImportStatement :: ModuleName -> IO T.Text         packageNameForImportStatement mod = do-          mpkg <- findImportedModule env mod :: IO (Maybe Module)+          mpkg <- findImportedModule (setNonHomeFCHook env) mod :: IO (Maybe Module)           let moduleName = printOutputable mod           case mpkg >>= packageNameWithVersion of             Nothing             -> pure moduleName@@ -287,19 +359,77 @@               version = T.pack $ showVersion (unitPackageVersion conf)           pure $ pkgName <> "-" <> version -        -- Type info for the current node, it may contains several symbols+        -- Type info for the current node, it may contain several symbols         -- for one range, like wildcard         types :: [hietype]-        types = nodeType info+        types = take maxHoverTypes $ nodeType info -        prettyTypes :: [T.Text]-        prettyTypes = map (("_ :: "<>) . prettyType) types+        maxHoverTypes :: Int+        maxHoverTypes = 10 -        prettyType :: hietype -> T.Text-        prettyType t = case kind of-          HieFresh -> printOutputable t-          HieFromDisk full_file -> printOutputable $ hieTypeToIface $ recoverFullType t (hie_types full_file)+        prettyTypes :: Maybe Name -> M.Map Name Location -> [T.Text]+        prettyTypes boundNameMay locationsMap =+          map (prettyType boundNameMay locationsMap) types +        prettyTypeFromType :: Maybe Name -> M.Map Name Location -> Type -> T.Text+        prettyTypeFromType boundNameMay locationsMap ty =+          prettyTypeCommon boundNameMay locationsMap (S.fromList $ namesInType ty) (printOutputableOneLine ty)++        prettyType :: Maybe Name -> M.Map Name Location -> hietype -> T.Text+        prettyType boundNameMay locationsMap t =+          prettyTypeCommon boundNameMay locationsMap (typeNames t) (printOutputableOneLine . expandType $ t)++        prettyTypeCommon :: Maybe Name -> M.Map Name Location -> Set Name -> T.Text -> T.Text+        prettyTypeCommon boundNameMay locationsMap names expandedType =+          let nameToUse = case boundNameMay of+                Just n  -> printOutputable n+                Nothing -> "_"+              expandedWithName = nameToUse <> " :: " <> expandedType+              codeBlock = wrapHaskell expandedWithName+              links = case boundNameMay of+                Just _  -> generateLinksList locationsMap names+                -- This is so we don't get flooded with links, e.g:+                -- foo :: forall a. MyType a -> a+                -- Go to MyType+                -- _ :: forall a. MyType a -> a+                -- Go to MyType -- <- we don't want this as it's already present+                Nothing -> ""+          in codeBlock <> links++        generateLinksList :: M.Map Name Location -> Set Name -> T.Text+        generateLinksList locationsMap (S.toList -> names) =+          if null generated+            then ""+            else "\n" <> "Go to " <> T.intercalate " | " generated <> "\n"+          where+            generated = mapMaybe generateLink names++            generateLink name = do+              case M.lookup name locationsMap of+                Just (Location uri range) ->+                  let nameText = printOutputable name+                      link = "[" <> nameText <> "](" <> getUriText uri <> "#L" <>+                             T.pack (show (range ^. L.start . L.line + 1)) <> ")"+                  in Just link+                Nothing -> Nothing++        wrapHaskell :: T.Text -> T.Text+        wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n"++        getUriText :: Uri -> T.Text+        getUriText (Uri t) = t++        typeNames :: a -> Set Name+        typeNames t = S.fromList $ case kind of+          HieFresh -> namesInType t+          HieFromDisk full_file -> do+            namesInHieTypeFix $ recoverFullType t (hie_types full_file)++        expandType :: a -> SDoc+        expandType t = case kind of+          HieFresh -> ppr t+          HieFromDisk full_file -> ppr $ hieTypeToIface $ recoverFullType t (hie_types full_file)+         definedAt :: Name -> Maybe T.Text         definedAt name =           -- do not show "at <no location info>" and similar messages@@ -308,6 +438,67 @@             UnhelpfulLoc {} | isInternalName name || isSystemName name -> Nothing             _ -> Just $ "*Defined " <> printOutputable (pprNameDefnLoc name) <> "*" +        -- We want to render the root constraint even if it is a let,+        -- but we don't want to render any subsequent lets+        renderEvidenceTree :: Tree (EvidenceInfo a) -> SDoc+        -- However, if the root constraint is simply a<n indirection (via let) to a single other constraint,+        -- we can still skip rendering it+        -- The evidence ghc generates is made up of a few primitives, like @WpLet@ (let bindings),+        -- @WpEvLam@ (lambda abstractions) and so on.+        -- The let binding refers to these lets.+        --+        -- For example, evidence for @Show ([Int], Bool)@ might look like:+        --+        -- @+        --   $dShow,[]IntBool = $fShow,[]IntBool+        --   -- indirection, we don't gain anything by printing this+        --   $fShow,[]IntBool = $dShow, $fShow[]Int $fShowBool+        --   -- This is the root "let" we render as a tree+        --   $fShow[]Int = $dShow[] $fShowInt+        --   -- second level let, collapse it into its parent $fShow,[]IntBool+        --   $fShowInt = base:Data.Int.$dShowInt+        --   -- indirection, remove it+        --   $fShowBool = base:Data.Bool.$dShowBool+        --   -- indirection, remove it+        --+        --   in $dShow,[]IntBool+        -- @+        --+        -- On doing this we end up with the tree @Show ([Int], Bool) -> (Show (,), Show [], Show Int, Show Bool)@+        --+        -- It is also quite helpful to look at the @.hie@ file directly to see how the+        -- evidence information is presented on disk. @hiedb dump <mod.hie>@+        renderEvidenceTree (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_)}) [x])+          = renderEvidenceTree x+        renderEvidenceTree (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_), ..}) xs)+          = hang (text "Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $+                 vcat $ text "constructed using:" : map renderEvidenceTree' xs+        renderEvidenceTree (T.Node (EvidenceInfo{..}) _)+          = hang (text "Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $+                 vcat $ printDets evidenceSpan evidenceDetails : map (text . T.unpack) (maybeToList $ definedAt evidenceVar)++        -- renderEvidenceTree' skips let bound evidence variables and prints the children directly+        renderEvidenceTree' (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_)}) xs)+          = vcat (map renderEvidenceTree' xs)+        renderEvidenceTree' (T.Node (EvidenceInfo{..}) _)+          = hang (text "- `" O.<> expandType evidenceType O.<> "`") 2 $+              vcat $+                printDets evidenceSpan evidenceDetails : map (text . T.unpack) (maybeToList $ definedAt evidenceVar)++        printDets :: RealSrcSpan -> Maybe (EvVarSource, Scope, Maybe Span) -> SDoc+        printDets _    Nothing = text "using an external instance"+        printDets ospn (Just (src,_,mspn)) = pprSrc+                                      $$ text "at" <+> text (T.unpack $ srcSpanToMdLink location)+          where+            location = realSrcSpanToLocation spn+            -- Use the bind span if we have one, else use the occurrence span+            spn = fromMaybe ospn mspn+            pprSrc = case src of+              -- Users don't know what HsWrappers are+              EvWrapperBind -> "bound by type signature or pattern"+              _             -> ppr src++-- | Find 'Location's of type definition at a specific point and return them along with their 'Identifier's. typeLocationsAtPoint   :: forall m    . MonadIO m@@ -316,14 +507,14 @@   -> IdeOptions   -> Position   -> HieAstResult-  -> m [Location]+  -> m [(Location, Identifier)] typeLocationsAtPoint withHieDb 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)+          getts x = nodeType ni  ++ mapMaybe identType (M.elems $ nodeIdentifiers ni)             where ni = nodeInfo' x           getTypes' ts' = flip concatMap (unfold ts') $ \case             HTyVarTy n -> [n]@@ -334,43 +525,80 @@             HQualTy a b -> getTypes' [a,b]             HCastTy a -> getTypes' [a]             _ -> []-        in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes' ts)+        in fmap nubOrd $ concatMapM (\n -> fmap (maybe [] (fmap (,Right n))) (nameToLocation withHieDb lookupModule n)) (getTypes' ts)     HieFresh ->       let ts = concat $ pointCommand ast pos getts-          getts x = nodeType ni  ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni)+          getts x = nodeType ni  ++ mapMaybe identType (M.elems $ nodeIdentifiers ni)             where ni = nodeInfo x-        in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts)+        in fmap nubOrd $ concatMapM (\n -> fmap (maybe [] (fmap (,Right n))) (nameToLocation withHieDb lookupModule n)) (getTypes ts)  namesInType :: Type -> [Name] namesInType (TyVarTy n)      = [varName n] namesInType (AppTy a b)      = getTypes [a,b] namesInType (TyConApp tc ts) = tyConName tc : getTypes ts namesInType (ForAllTy b t)   = varName (binderVar b) : namesInType t-namesInType (FunTy a b)      = getTypes [a,b]+namesInType (FunTy _ a b)    = getTypes [a,b] namesInType (CastTy t _)     = namesInType t namesInType (LitTy _)        = [] namesInType _                = [] + getTypes :: [Type] -> [Name]-getTypes ts = concatMap namesInType ts+getTypes = concatMap namesInType +namesInHieTypeFix :: HieTypeFix -> [Name]+namesInHieTypeFix (Roll hieType) = namesInHieType hieType++namesInHieType :: HieType HieTypeFix -> [Name]+namesInHieType (HTyVarTy n)         = [n]+namesInHieType (HAppTy a (HieArgs args)) = namesInHieTypeFix a ++ concatMap (namesInHieTypeFix . snd) args+namesInHieType (HTyConApp tc (HieArgs args)) = ifaceTyConName tc : concatMap (namesInHieTypeFix . snd) args+namesInHieType (HForAllTy ((binder, constraint), _) body) = binder : namesInHieTypeFix constraint ++ namesInHieTypeFix body+namesInHieType (HFunTy mult arg res) = namesInHieTypeFix mult ++ namesInHieTypeFix arg ++ namesInHieTypeFix res+namesInHieType (HQualTy constraint body) = namesInHieTypeFix constraint ++ namesInHieTypeFix body+namesInHieType (HLitTy _)           = []+namesInHieType (HCastTy a)          = namesInHieTypeFix a+namesInHieType HCoercionTy          = []++-- | Find 'Location's of definition at a specific point and return them along with their 'Identifier's. locationsAtPoint-  :: forall m a+  :: forall m    . MonadIO m   => WithHieDb   -> LookupModule m   -> IdeOptions   -> M.Map ModuleName NormalizedFilePath   -> Position-  -> HieASTs a-  -> m [Location]-locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast =+  -> HieAstResult+  -> m [(Location, Identifier)]+locationsAtPoint withHieDb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _) =   let ns = concat $ pointCommand ast pos (M.keys . getNodeIds)       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 withHieDb lookupModule) ns+      modToLocation m = fmap (\fs -> pure (Location (fromNormalizedUri $ filePathToUri' fs) zeroRange)) $ M.lookup m imports+   in fmap (nubOrd . concat) $ mapMaybeM+        (either (\m -> pure ((fmap $ fmap (,Left m)) (modToLocation m)))+                (\n -> fmap (fmap $ fmap (,Right n)) (nameToLocation withHieDb lookupModule n)))+        ns +-- | Find 'Location's of a implementation definition at a specific point.+instanceLocationsAtPoint+  :: forall m+   . MonadIO m+  => WithHieDb+  -> LookupModule m+  -> IdeOptions+  -> Position+  -> HieAstResult+  -> m [Location]+instanceLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _rm _ _) =+  let ns = concat $ pointCommand ast pos (M.keys . getNodeIds)+      evTrees = mapMaybe (eitherToMaybe >=> getEvidenceTree _rm) ns+      evNs = concatMap (map evidenceVar . T.flatten) evTrees+   in fmap (nubOrd . concat) $ mapMaybeM+        (nameToLocation withHieDb lookupModule)+        evNs+ -- | Given a 'Name' attempt to find the location where it is defined. nameToLocation :: MonadIO m => WithHieDb -> LookupModule m -> Name -> m (Maybe [Location]) nameToLocation withHieDb lookupModule name = runMaybeT $@@ -441,10 +669,10 @@  pointCommand :: HieASTs t -> Position -> (HieAST t -> a) -> [a] pointCommand hf pos k =-    catMaybes $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast ->+    M.elems $ flip M.mapMaybeWithKey (getAsts hf) $ \fs ast ->       -- Since GHC 9.2:       -- getAsts :: Map HiePath (HieAst a)-      -- type HiePath = LexialFastString+      -- type HiePath = LexicalFastString       --       -- but before:       -- getAsts :: Map HiePath (HieAst a)
src/Development/IDE/Spans/Common.hs view
@@ -4,7 +4,6 @@  module Development.IDE.Spans.Common (   unqualIEWrapName-, safeTyThingId , safeTyThingType , SpanDoc(..) , SpanDocUris(..)@@ -12,55 +11,48 @@ , spanDocToMarkdown , spanDocToMarkdownForTest , DocMap-, KindMap+, TyThingMap+, ArgDocMap+, srcSpanToMdLink ) where  import           Control.DeepSeq+import           Data.Bifunctor               (second) import           Data.List.Extra import           Data.Maybe import qualified Data.Text                    as T-import           GHC.Generics-+import           Development.IDE.GHC.Util+import qualified Documentation.Haddock.Parser as H+import qualified Documentation.Haddock.Types  as H import           GHC+import           GHC.Generics+import           System.FilePath -import           Data.Bifunctor               (second)+import           Control.Lens+import           Data.IntMap                  (IntMap) import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Orphans  ()-import           Development.IDE.GHC.Util-import qualified Documentation.Haddock.Parser as H-import qualified Documentation.Haddock.Types  as H+import qualified Language.LSP.Protocol.Lens   as JL+import           Language.LSP.Protocol.Types  type DocMap = NameEnv SpanDoc-type KindMap = NameEnv TyThing+type TyThingMap = NameEnv TyThing+type ArgDocMap = NameEnv (IntMap SpanDoc)  -- | Shows IEWrappedName, without any modifier, qualifier or unique identifier.-#if MIN_VERSION_ghc(9,5,0) unqualIEWrapName :: IEWrappedName GhcPs -> T.Text-#else-unqualIEWrapName :: IEWrappedName RdrName -> T.Text-#endif unqualIEWrapName = printOutputable . 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 dataCon)) = Just (dataConWrapId dataCon)-safeTyThingId _                                = Nothing+safeTyThingType :: Bool -> TyThing -> Maybe Type+safeTyThingType showLinearType (AConLike (RealDataCon dataCon))+                                    = Just (dataConDisplayType showLinearType dataCon)+safeTyThingType _ (AnId i)          = Just (varType i)+safeTyThingType _ (ATyCon tycon)    = Just (tyConKind tycon)+safeTyThingType _ _                 = Nothing  -- Possible documentation for an element in the code-#if MIN_VERSION_ghc(9,3,0) data SpanDoc   = SpanDocString [HsDocString] SpanDocUris-#else-data SpanDoc-  = SpanDocString HsDocString SpanDocUris-#endif   | SpanDocText   [T.Text] SpanDocUris   deriving stock (Eq, Show, Generic)   deriving anyclass NFData@@ -97,11 +89,7 @@ spanDocToMarkdown = \case     (SpanDocString docs uris) ->         let doc = T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $-#if MIN_VERSION_ghc(9,3,0)                       renderHsDocStrings docs-#else-                      unpackHDS docs-#endif         in  go [doc] uris     (SpanDocText txt uris) -> go txt uris   where@@ -118,8 +106,14 @@   [ linkify "Documentation" <$> mdoc   , linkify "Source" <$> msrc   ]-  where linkify title uri = "[" <> title <> "](" <> uri <> ")" +-- | Generate a markdown link.+--+-- >>> linkify "Title" "uri"+-- "[Title](Uri)"+linkify :: T.Text -> T.Text -> T.Text+linkify title uri = "[" <> title <> "](" <> uri <> ")"+ spanDocToMarkdownForTest :: String -> String spanDocToMarkdownForTest   = haddockToMarkdown . H.toRegular . H._doc . H.parseParas Nothing@@ -193,11 +187,10 @@ 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"+haddockToMarkdown (H.DocMathInline s)+  = "`" ++ s ++ "`"+haddockToMarkdown (H.DocMathDisplay s)+  = "\n```latex\n" ++ s ++ "\n```\n"  -- TODO: render tables haddockToMarkdown (H.DocTable _t)@@ -224,3 +217,35 @@   = case lines s of       []           -> ""       (first:rest) -> unlines $ first : map (("  " ++) . trimStart) rest++-- | Generate a source link for the 'Location' according to VSCode's supported form:+-- https://github.com/microsoft/vscode/blob/b3ec8181fc49f5462b5128f38e0723ae85e295c2/src/vs/platform/opener/common/opener.ts#L151-L160+--+srcSpanToMdLink :: Location -> T.Text+srcSpanToMdLink location =+  let+    uri = location ^. JL.uri+    range = location ^. JL.range+    -- LSP 'Range' starts at '0', but link locations start at '1'.+    intText n = T.pack $ show (n + 1)+    srcRangeText =+      T.concat+        [ "L"+        , intText (range ^. JL.start . JL.line)+        , ","+        , intText (range ^. JL.start . JL.character)+        , "-L"+        , intText (range ^. JL.end . JL.line)+        , ","+        , intText (range ^. JL.end . JL.character)+        ]++    -- If the 'Location' is a 'FilePath', display it in shortened form.+    -- This avoids some redundancy and better readability for the user.+    title = case uriToFilePath uri of+      Just fp -> T.pack (takeFileName fp) <> ":" <> intText (range ^. JL.start . JL.line)+      Nothing -> getUri uri++    srcLink = getUri uri <> "#" <> srcRangeText+  in+   linkify title srcLink
src/Development/IDE/Spans/Documentation.hs view
@@ -1,8 +1,7 @@-{-# LANGUAGE RankNTypes #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP        #-}+{-# LANGUAGE CPP #-}  module Development.IDE.Spans.Documentation (     getDocumentation@@ -17,6 +16,7 @@ import           Control.Monad.IO.Class import           Data.Either import           Data.Foldable+import           Data.IntMap                     (IntMap) import           Data.List.Extra import qualified Data.Map                        as M import           Data.Maybe@@ -29,6 +29,7 @@ import           Development.IDE.GHC.Error import           Development.IDE.GHC.Util        (printOutputable) import           Development.IDE.Spans.Common+import           GHC.Iface.Ext.Utils             (RefMap) import           Language.LSP.Protocol.Types     (filePathToUri, getUri) import           Prelude                         hiding (mod) import           System.Directory@@ -39,33 +40,30 @@   :: HscEnv   -> RefMap a   -> TcGblEnv-  -> IO DocAndKindMap+  -> IO DocAndTyThingMap mkDocMap env rm this_mod =   do-#if MIN_VERSION_ghc(9,3,0)-     (Just Docs{docs_decls = UniqMap this_docs}) <- extractDocs (hsc_dflags env) this_mod-#else-     (_ , DeclDocMap this_docs, _) <- extractDocs this_mod-#endif-#if MIN_VERSION_ghc(9,3,0)+     (Just Docs{docs_decls = UniqMap this_docs, docs_args = UniqMap this_arg_docs}) <- extractDocs (hsc_dflags env) this_mod      d <- foldrM getDocs (fmap (\(_, x) -> (map hsDocString x) `SpanDocString` SpanDocUris Nothing Nothing) this_docs) names-#else-     d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names-#endif      k <- foldrM getType (tcg_type_env this_mod) names-     pure $ DKMap d k+     a <- foldrM getArgDocs (fmap (\(_, m) -> fmap (\x -> [hsDocString x] `SpanDocString` SpanDocUris Nothing Nothing) m) this_arg_docs) names+     pure $ DKMap d k a   where     getDocs n nameMap       | maybe True (mod ==) $ nameModule_maybe n = pure nameMap -- we already have the docs in this_docs, or they do not exist       | otherwise = do-      doc <- getDocumentationTryGhc env n+      (doc, _argDoc) <- getDocumentationTryGhc env n       pure $ extendNameEnv nameMap n doc     getType n nameMap-      | isTcOcc $ occName n-      , Nothing <- lookupNameEnv nameMap n+      | Nothing <- lookupNameEnv nameMap n       = do kind <- lookupKind env n            pure $ maybe nameMap (extendNameEnv nameMap n) kind       | otherwise = pure nameMap+    getArgDocs n nameMap+      | maybe True (mod ==) $ nameModule_maybe n = pure nameMap+      | otherwise = do+      (_doc, argDoc) <- getDocumentationTryGhc env n+      pure $ extendNameEnv nameMap n argDoc     names = rights $ S.toList idents     idents = M.keysSet rm     mod = tcg_mod this_mod@@ -74,27 +72,23 @@ lookupKind env =     fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env -getDocumentationTryGhc :: HscEnv -> Name -> IO SpanDoc+getDocumentationTryGhc :: HscEnv -> Name -> IO (SpanDoc, IntMap SpanDoc) getDocumentationTryGhc env n =-  (fromMaybe emptySpanDoc . listToMaybe <$> getDocumentationsTryGhc env [n])-    `catch` (\(_ :: IOEnvFailure) -> pure emptySpanDoc)+  (fromMaybe (emptySpanDoc, mempty) . listToMaybe <$> getDocumentationsTryGhc env [n])+    `catch` (\(_ :: IOEnvFailure) -> pure (emptySpanDoc, mempty)) -getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [SpanDoc]+getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [(SpanDoc, IntMap SpanDoc)] getDocumentationsTryGhc env names = do   resOr <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env names   case resOr of       Left _    -> return []       Right res -> zipWithM unwrap res names   where-#if MIN_VERSION_ghc(9,3,0)-    unwrap (Right (Just docs, _)) n = SpanDocString (map hsDocString docs) <$> getUris n-#else-    unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n-#endif+    unwrap (Right (Just docs, argDocs)) n = (\uris -> (SpanDocString (map hsDocString docs) uris, fmap (\x -> SpanDocString [hsDocString x] uris) argDocs)) <$> getUris n     unwrap _ n                      = mkSpanDocText n      mkSpanDocText name =-      SpanDocText [] <$> getUris name+      (\uris -> (SpanDocText [] uris, mempty)) <$> getUris name      -- Get the uris to the documentation and source html pages if they exist     getUris name = do
src/Development/IDE/Spans/LocalBindings.hs view
@@ -17,14 +17,16 @@ import qualified Data.List                      as L import qualified Data.Map                       as M import qualified Data.Set                       as S+import           GHC.Iface.Ext.Types            (IdentifierDetails (..),+                                                 Scope (..))+import           GHC.Iface.Ext.Utils            (RefMap, getBindSiteFromContext,+                                                 getScopeFromContext)+ import           Development.IDE.GHC.Compat     (Name, NameEnv, RealSrcSpan,-                                                 RefMap, Scope (..), Type,-                                                 getBindSiteFromContext,-                                                 getScopeFromContext, identInfo,-                                                 identType, isSystemName,-                                                 nameEnvElts, realSrcSpanEnd,+                                                 Type, isSystemName,+                                                 nonDetNameEnvElts,+                                                 realSrcSpanEnd,                                                  realSrcSpanStart, unitNameEnv)- import           Development.IDE.GHC.Error import           Development.IDE.Types.Location @@ -99,7 +101,7 @@ -- 'RealSrcSpan', getLocalScope :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] getLocalScope bs rss-  = nameEnvElts+  = nonDetNameEnvElts   $ foldMap snd   $ IM.dominators (realSrcSpanToInterval rss)   $ getLocalBindings bs@@ -109,7 +111,7 @@ -- 'RealSrcSpan', getDefiningBindings :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] getDefiningBindings bs rss-  = nameEnvElts+  = nonDetNameEnvElts   $ foldMap snd   $ IM.dominators (realSrcSpanToInterval rss)   $ getBindingSites bs@@ -121,7 +123,7 @@ getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)] getFuzzyScope bs a b   = filter (not . isSystemName . fst)-  $ nameEnvElts+  $ nonDetNameEnvElts   $ foldMap snd   $ IM.intersections (Interval a b)   $ getLocalBindings bs@@ -133,7 +135,7 @@ -- `PositionMapping` getFuzzyDefiningBindings :: Bindings -> Position -> Position -> [(Name, Maybe Type)] getFuzzyDefiningBindings bs a b-  = nameEnvElts+  = nonDetNameEnvElts   $ foldMap snd   $ IM.intersections (Interval a b)   $ getBindingSites bs
src/Development/IDE/Spans/Pragmas.hs view
@@ -15,6 +15,8 @@ import qualified Data.Maybe                      as Maybe import           Data.Text                       (Text, pack) import qualified Data.Text                       as Text+import           Data.Text.Utf16.Rope.Mixed      (Rope)+import qualified Data.Text.Utf16.Rope.Mixed      as Rope import           Development.IDE                 (srcSpanToRange, IdeState, NormalizedFilePath, GhcSession (..), getFileContents, hscEnv, runAction) import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Compat.Util@@ -27,10 +29,10 @@ import           Development.IDE.Core.PluginUtils import qualified Language.LSP.Protocol.Lens     as L -getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo-getNextPragmaInfo dynFlags mbSourceText =-  if | Just sourceText <- mbSourceText-     , let sourceStringBuffer = stringToStringBuffer (Text.unpack sourceText)+getNextPragmaInfo :: DynFlags -> Maybe Rope -> NextPragmaInfo+getNextPragmaInfo dynFlags mbSource =+  if | Just source <- mbSource+     , let sourceStringBuffer = stringToStringBuffer (Text.unpack (Rope.toText source))      , POk _ parserState <- parsePreDecl dynFlags sourceStringBuffer      -> case parserState of          ParserStateNotDone{ nextPragma } -> nextPragma@@ -38,12 +40,7 @@      | otherwise      -> NextPragmaInfo 0 Nothing --- NOTE(ozkutuk): `RecordPuns` extension is renamed to `NamedFieldPuns`--- in GHC 9.4, but we still want to insert `NamedFieldPuns` in pre-9.4--- GHC as well, hence the replacement.--- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6156 showExtension :: Extension -> Text-showExtension NamedFieldPuns = "NamedFieldPuns" showExtension ext = pack (show ext)  insertNewPragma :: NextPragmaInfo -> Extension -> LSP.TextEdit@@ -56,7 +53,7 @@ getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m NextPragmaInfo getFirstPragma (PluginId pId) state nfp = do   (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- runActionE (T.unpack pId <> ".GhcSession") state $ useWithStaleE GhcSession nfp-  (_, fileContents) <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents nfp+  fileContents <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents nfp   pure $ getNextPragmaInfo sessionDynFlags fileContents  -- Pre-declaration comments parser -----------------------------------------------------
src/Development/IDE/Types/Diagnostics.hs view
@@ -1,32 +1,60 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP             #-}+{-# LANGUAGE DeriveGeneric   #-}+{-# LANGUAGE TemplateHaskell #-}  module Development.IDE.Types.Diagnostics (   LSP.Diagnostic(..),   ShowDiagnostic(..),-  FileDiagnostic,+  FileDiagnostic(..),+  fdFilePathL,+  fdLspDiagnosticL,+  fdShouldShowDiagnosticL,+  fdStructuredMessageL,+  StructuredMessage(..),+  _NoStructuredMessage,+  _SomeStructuredMessage,   IdeResult,   LSP.DiagnosticSeverity(..),   DiagnosticStore,   ideErrorText,   ideErrorWithSource,+  ideErrorFromLspDiag,   showDiagnostics,   showDiagnosticsColored,-  IdeResultNoDiagnosticsEarlyCutoff) where+  showGhcCode,+  IdeResultNoDiagnosticsEarlyCutoff,+  attachReason,+  attachedReason) where  import           Control.DeepSeq+import           Control.Lens+import qualified Data.Aeson                     as JSON+import qualified Data.Aeson.Lens                as JSON import           Data.ByteString                (ByteString)+import           Data.Foldable import           Data.Maybe                     as Maybe import qualified Data.Text                      as T+import           Development.IDE.GHC.Compat     (GhcMessage, MsgEnvelope,+                                                 WarningFlag, flagSpecFlag,+                                                 flagSpecName, wWarningFlags) import           Development.IDE.Types.Location+import           GHC.Generics+import           GHC.Types.Error                (DiagnosticCode (..),+                                                 DiagnosticReason (..),+                                                 diagnosticCode,+                                                 diagnosticReason,+                                                 errMsgDiagnostic) import           Language.LSP.Diagnostics-import           Language.LSP.Protocol.Types    as LSP (Diagnostic (..),-                                                        DiagnosticSeverity (..))+import           Language.LSP.Protocol.Lens     (data_)+import           Language.LSP.Protocol.Types    as LSP import           Prettyprinter import           Prettyprinter.Render.Terminal  (Color (..), color) import qualified Prettyprinter.Render.Terminal  as Terminal import           Prettyprinter.Render.Text+import           Text.Printf                    (printf)   -- | The result of an IDE operation. Warnings and errors are in the Diagnostic,@@ -44,26 +72,97 @@ -- | an IdeResult with a fingerprint type IdeResultNoDiagnosticsEarlyCutoff  v = (Maybe ByteString, Maybe v) +-- | Produce a 'FileDiagnostic' for the given 'NormalizedFilePath'+-- with an error message. ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic-ideErrorText = ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error)+ideErrorText nfp msg =+  ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error) nfp msg Nothing +-- | Create a 'FileDiagnostic' from an existing 'LSP.Diagnostic' for a+-- specific 'NormalizedFilePath'.+-- The optional 'MsgEnvelope GhcMessage' is the original error message+-- that was used for creating the 'LSP.Diagnostic'.+-- It is included here, to allow downstream consumers, such as HLS plugins,+-- to provide LSP features based on the structured error messages.+-- Additionally, if available, we insert the ghc error code into the+-- 'LSP.Diagnostic'. These error codes are used in https://errors.haskell.org/+-- to provide documentation and explanations for error messages.+ideErrorFromLspDiag+  :: LSP.Diagnostic+  -> NormalizedFilePath+  -> Maybe (MsgEnvelope GhcMessage)+  -> FileDiagnostic+ideErrorFromLspDiag lspDiag fdFilePath mbOrigMsg =+  let fdShouldShowDiagnostic = ShowDiag+      fdStructuredMessage =+        case mbOrigMsg of+          Nothing  -> NoStructuredMessage+          Just msg -> SomeStructuredMessage msg+      fdLspDiagnostic =+        lspDiag+          & attachReason (fmap (diagnosticReason . errMsgDiagnostic) mbOrigMsg)+          & attachDiagnosticCode ((diagnosticCode . errMsgDiagnostic) =<< mbOrigMsg)+  in+  FileDiagnostic {..}++-- | Set the code of the 'LSP.Diagnostic' to the GHC diagnostic code, and include the link+-- to https://errors.haskell.org/.+attachDiagnosticCode :: Maybe DiagnosticCode -> LSP.Diagnostic -> LSP.Diagnostic+attachDiagnosticCode Nothing diag = diag+attachDiagnosticCode (Just code) diag =+    let+        textualCode = showGhcCode code+        codeDesc = LSP.CodeDescription{ _href = Uri $ "https://errors.haskell.org/messages/" <> textualCode }+    in diag { _code = Just (InR textualCode), _codeDescription = Just codeDesc}++#if MIN_VERSION_ghc(9,9,0)+-- DiagnosticCode only got a show instance in 9.10.1+showGhcCode :: DiagnosticCode -> T.Text+showGhcCode = T.pack . show+#else+showGhcCode :: DiagnosticCode -> T.Text+showGhcCode (DiagnosticCode prefix c) = T.pack $ prefix ++ "-" ++ printf "%05d" c+#endif++attachedReason :: Traversal' Diagnostic (Maybe JSON.Value)+attachedReason = data_ . non (JSON.object []) . JSON.atKey "attachedReason"++attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic+attachReason Nothing = id+attachReason (Just wr) = attachedReason .~ fmap JSON.toJSON (showReason wr)+ where+  showReason = \case+    WarningWithFlag flag -> Just $ catMaybes [showFlag flag]+#if MIN_VERSION_ghc(9,7,0)+    WarningWithFlags flags -> Just $ catMaybes (fmap showFlag $ toList flags)+#endif+    _                    -> Nothing++showFlag :: WarningFlag -> Maybe T.Text+showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags+ ideErrorWithSource   :: Maybe T.Text   -> Maybe DiagnosticSeverity-  -> a+  -> NormalizedFilePath   -> 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,-    _codeDescription = Nothing,-    _data_ = Nothing-    })+  -> Maybe (MsgEnvelope GhcMessage)+  -> FileDiagnostic+ideErrorWithSource source sev fdFilePath msg origMsg =+  let lspDiagnostic =+        LSP.Diagnostic {+          _range = noRange,+          _severity = sev,+          _code = Nothing,+          _source = source,+          _message = msg,+          _relatedInformation = Nothing,+          _tags = Nothing,+          _codeDescription = Nothing,+          _data_ = Nothing+        }+  in+  ideErrorFromLspDiag lspDiagnostic fdFilePath origMsg  -- | Defines whether a particular diagnostic should be reported --   back to the user.@@ -80,14 +179,79 @@ instance NFData ShowDiagnostic where     rnf = rwhnf +-- | A Maybe-like wrapper for a GhcMessage that doesn't try to compare, show, or+-- force the GhcMessage inside, so that we can derive Show, Eq, Ord, NFData on+-- FileDiagnostic. FileDiagnostic only uses this as metadata so we can safely+-- ignore it in fields.+--+-- Instead of pattern matching on these constructors directly, consider 'Prism' from+-- the 'lens' package. This allows to conveniently pattern match deeply into the 'MsgEnvelope GhcMessage'+-- constructor.+-- The module 'Development.IDE.GHC.Compat.Error' implements additional 'Lens's and 'Prism's,+-- allowing you to avoid importing GHC modules directly.+--+-- For example, to pattern match on a 'TcRnMessage' you can use the lens:+--+-- @+--   message ^? _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage+-- @+--+-- This produces a value of type `Maybe TcRnMessage`.+--+-- Further, consider utility functions such as 'stripTcRnMessageContext', which strip+-- context from error messages which may be more convenient in certain situations.+data StructuredMessage+  = NoStructuredMessage+  | SomeStructuredMessage (MsgEnvelope GhcMessage)+  deriving (Generic)++instance Show StructuredMessage where+  show NoStructuredMessage      = "NoStructuredMessage"+  show SomeStructuredMessage {} = "SomeStructuredMessage"++instance Eq StructuredMessage where+  (==) NoStructuredMessage NoStructuredMessage           = True+  (==) SomeStructuredMessage {} SomeStructuredMessage {} = True+  (==) _ _                                               = False++instance Ord StructuredMessage where+  compare NoStructuredMessage NoStructuredMessage           = EQ+  compare SomeStructuredMessage {} SomeStructuredMessage {} = EQ+  compare NoStructuredMessage SomeStructuredMessage {}      = GT+  compare SomeStructuredMessage {} NoStructuredMessage      = LT++instance NFData StructuredMessage where+  rnf NoStructuredMessage      = ()+  rnf SomeStructuredMessage {} = ()+ -- | 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)+--   It also optionally keeps a structured diagnostic message GhcMessage in+--   StructuredMessage.+--+data FileDiagnostic = FileDiagnostic+  { fdFilePath             :: NormalizedFilePath+  , fdShouldShowDiagnostic :: ShowDiagnostic+  , fdLspDiagnostic        :: Diagnostic+    -- | The original diagnostic that was used to produce 'fdLspDiagnostic'.+    -- We keep it here, so downstream consumers, e.g. HLS plugins, can use the+    -- the structured error messages and don't have to resort to parsing+    -- error messages via regexes or similar.+    --+    -- The optional GhcMessage inside of this StructuredMessage is ignored for+    -- Eq, Ord, Show, and NFData instances. This is fine because this field+    -- should only ever be metadata and should never be used to distinguish+    -- between FileDiagnostics.+  , fdStructuredMessage    :: StructuredMessage+  }+  deriving (Eq, Ord, Show, Generic) +instance NFData FileDiagnostic+ prettyRange :: Range -> Doc Terminal.AnsiStyle prettyRange Range{..} = f _start <> "-" <> f _end     where f Position{..} = pretty (show $ _line+1) <> colon <> pretty (show $ _character+1)@@ -106,13 +270,17 @@ prettyDiagnostics = vcat . map prettyDiagnostic  prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle-prettyDiagnostic (fp, sh, LSP.Diagnostic{..}) =+prettyDiagnostic FileDiagnostic { fdFilePath, fdShouldShowDiagnostic, fdLspDiagnostic = LSP.Diagnostic{..} } =     vcat-        [ slabel_ "File:    " $ pretty (fromNormalizedFilePath fp)-        , slabel_ "Hidden:  " $ if sh == ShowDiag then "no" else "yes"+        [ slabel_ "File:    " $ pretty (fromNormalizedFilePath fdFilePath)+        , slabel_ "Hidden:  " $ if fdShouldShowDiagnostic == ShowDiag then "no" else "yes"         , slabel_ "Range:   " $ prettyRange _range         , slabel_ "Source:  " $ pretty _source         , slabel_ "Severity:" $ pretty $ show sev+        , slabel_ "Code:    " $ case _code of+                                  Just (InR text) -> pretty text+                                  Just (InL i)    -> pretty i+                                  Nothing         -> "<none>"         , slabel_ "Message: "             $ case sev of               LSP.DiagnosticSeverity_Error       -> annotate $ color Red@@ -150,3 +318,9 @@  defaultTermWidth :: Int defaultTermWidth = 80++makePrisms ''StructuredMessage++makeLensesWith+    (lensRules & lensField .~ mappingNamer (pure . (++ "L")))+    ''FileDiagnostic
src/Development/IDE/Types/Exports.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE DeriveAnyClass     #-} {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE RankNTypes         #-} module Development.IDE.Types.Exports (     IdentInfo(..),@@ -208,7 +207,7 @@  buildModuleExportMap:: [(ModuleName, HashSet IdentInfo)] -> ModuleNameEnv (HashSet IdentInfo) buildModuleExportMap exportsMap = do-  let lst = concatMap (Set.toList. snd) exportsMap+  let lst = concatMap (Set.toList . snd) exportsMap   let lstThree = map identInfoToKeyVal lst   sortAndGroup lstThree @@ -224,4 +223,4 @@   (modName, functionSet)  sortAndGroup :: [(ModuleName, IdentInfo)] -> ModuleNameEnv (HashSet IdentInfo)-sortAndGroup assocs = listToUFM_C (<>) [(k, Set.fromList [v]) | (k, v) <- assocs]+sortAndGroup assocs = listToUFM_C (<>) [(k, Set.singleton v) | (k, v) <- assocs]
src/Development/IDE/Types/HscEnvEq.hs view
@@ -1,25 +1,20 @@+{-# LANGUAGE CPP #-} module Development.IDE.Types.HscEnvEq (   HscEnvEq,     hscEnv, newHscEnvEq,-    hscEnvWithImportPaths,-    newHscEnvEqPreserveImportPaths,-    newHscEnvEqWithImportPaths,     updateHscEnvEq,-    envImportPaths,     envPackageExports,     envVisibleModuleNames,-    deps ) where   import           Control.Concurrent.Async        (Async, async, waitCatch) import           Control.Concurrent.Strict       (modifyVar, newVar)-import           Control.DeepSeq                 (force)+import           Control.DeepSeq                 (force, rwhnf) import           Control.Exception               (evaluate, mask, throwIO) import           Control.Monad.Extra             (eitherM, join, mapMaybeM) import           Data.Either                     (fromRight)-import           Data.Set                        (Set)-import qualified Data.Set                        as Set+import           Data.IORef import           Data.Unique                     (Unique) import qualified Data.Unique                     as Unique import           Development.IDE.GHC.Compat      hiding (newUnique)@@ -28,23 +23,16 @@ import           Development.IDE.GHC.Util        (lookupPackageConfig) import           Development.IDE.Graph.Classes import           Development.IDE.Types.Exports   (ExportsMap, createExportsMap)+import           GHC.Driver.Env                  (hsc_all_home_unit_ids) import           OpenTelemetry.Eventlog          (withSpan)-import           System.Directory                (makeAbsolute)-import           System.FilePath + -- | An 'HscEnv' with equality. Two values are considered equal --   if they are created with the same call to 'newHscEnvEq' or --   'updateHscEnvEq'. data HscEnvEq = HscEnvEq     { envUnique             :: !Unique     , hscEnv                :: !HscEnv-    , deps                  :: [(UnitId, DynFlags)]-               -- ^ In memory components for this HscEnv-               -- This is only used at the moment for the import dirs in-               -- the DynFlags-    , envImportPaths        :: Maybe (Set FilePath)-        -- ^ 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,@@ -59,19 +47,39 @@   update <$> Unique.newUnique  -- | Wrap an 'HscEnv' into an 'HscEnvEq'.-newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq-newHscEnvEq cradlePath hscEnv0 deps = do-    let relativeToCradle = (takeDirectory cradlePath </>)-        hscEnv = removeImportPaths hscEnv0--    -- Make Absolute since targets are also absolute-    importPathsCanon <--      mapM makeAbsolute $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0)+newHscEnvEq :: HscEnv -> IO HscEnvEq+newHscEnvEq hscEnv' = do -    newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps+    mod_cache <- newIORef emptyInstalledModuleEnv+    -- This finder cache is for things which are outside of things which are tracked+    -- by HLS. For example, non-home modules, dependent object files etc+#if MIN_VERSION_ghc(9,11,0)+    let hscEnv = hscEnv'+               { hsc_FC = FinderCache+                        { flushFinderCaches = \_ -> error "GHC should never call flushFinderCaches outside the driver"+#if MIN_VERSION_ghc(9,13,0)+                        , addToFinderCache  = \im val -> do+#else+                        , addToFinderCache  = \(GWIB im _) val -> do+#endif+                            if moduleUnit im `elem` hsc_all_home_unit_ids hscEnv'+                            then error "tried to add home module to FC"+                            else atomicModifyIORef' mod_cache $ \c -> (extendInstalledModuleEnv c im val, ())+#if MIN_VERSION_ghc(9,13,0)+                        , lookupFinderCache = \im -> do+#else+                        , lookupFinderCache = \(GWIB im _) -> do+#endif+                            if moduleUnit im `elem` hsc_all_home_unit_ids hscEnv'+                            then error ("tried to lookup home module from FC" ++ showSDocUnsafe (ppr (im, hsc_all_home_unit_ids hscEnv')))+                            else lookupInstalledModuleEnv <$> readIORef mod_cache <*> pure im+                        , lookupFileCache = \fp -> error ("not used by HLS" ++ fp)+                        }+                } -newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq-newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do+#else+    let hscEnv = hscEnv'+#endif      let dflags = hsc_dflags hscEnv @@ -113,23 +121,6 @@      return HscEnvEq{..} --- | Wrap an 'HscEnv' into an 'HscEnvEq'.-newHscEnvEqPreserveImportPaths-    :: HscEnv -> [(UnitId, 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-    = hscSetFlags (setImportPaths (Set.toList imps) (hsc_dflags hscEnv)) hscEnv-    | otherwise-    = hscEnv--removeImportPaths :: HscEnv -> HscEnv-removeImportPaths hsc = hscSetFlags (setImportPaths [] (hsc_dflags hsc)) hsc- instance Show HscEnvEq where   show HscEnvEq{envUnique} = "HscEnvEq " ++ show (Unique.hashUnique envUnique) @@ -137,9 +128,9 @@   a == b = envUnique a == envUnique b  instance NFData HscEnvEq where-  rnf (HscEnvEq a b c d _ _) =+  rnf (HscEnvEq a b _ _) =       -- deliberately skip the package exports map and visible module names-      rnf (Unique.hashUnique a) `seq` b `seq` c `seq` rnf d+      rnf (Unique.hashUnique a) `seq` rwhnf b  instance Hashable HscEnvEq where   hashWithSalt s = hashWithSalt s . envUnique
src/Development/IDE/Types/KnownTargets.hs view
@@ -1,6 +1,11 @@ {-# LANGUAGE DeriveAnyClass     #-} {-# LANGUAGE DerivingStrategies #-}-module Development.IDE.Types.KnownTargets (KnownTargets, Target(..), toKnownFiles) where+module Development.IDE.Types.KnownTargets ( KnownTargets(..)+                                          , emptyKnownTargets+                                          , mkKnownTargets+                                          , unionKnownTargets+                                          , Target(..)+                                          , toKnownFiles) where  import           Control.DeepSeq import           Data.Hashable@@ -14,11 +19,33 @@ import           GHC.Generics  -- | A mapping of module name to known files-type KnownTargets = HashMap Target (HashSet NormalizedFilePath)+newtype KnownTargets = KnownTargets+  { targetMap :: (HashMap Target (HashSet NormalizedFilePath)) }+  deriving Show ++unionKnownTargets :: KnownTargets -> KnownTargets -> KnownTargets+unionKnownTargets (KnownTargets tm) (KnownTargets tm') =+  KnownTargets (HMap.unionWith (<>) tm tm')++mkKnownTargets :: [(Target, HashSet NormalizedFilePath)] -> KnownTargets+mkKnownTargets vs = KnownTargets (HMap.fromList vs)++instance NFData KnownTargets where+  rnf (KnownTargets tm) = rnf tm `seq` ()++instance Eq KnownTargets where+  k1 == k2 = targetMap k1 == targetMap k2++instance Hashable KnownTargets where+  hashWithSalt s (KnownTargets hm) = hashWithSalt s hm++emptyKnownTargets :: KnownTargets+emptyKnownTargets = KnownTargets HMap.empty+ data Target = TargetModule ModuleName | TargetFile NormalizedFilePath-  deriving ( Eq, Generic, Show )+  deriving ( Eq, Ord, Generic, Show )   deriving anyclass (Hashable, NFData)  toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath-toKnownFiles = HSet.unions . HMap.elems+toKnownFiles = HSet.unions . HMap.elems . targetMap
src/Development/IDE/Types/Location.hs view
@@ -2,7 +2,6 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE CPP #-} - -- | Types and functions for working with source code locations. module Development.IDE.Types.Location     ( Location(..)@@ -35,8 +34,6 @@                                                Range (..)) import qualified Language.LSP.Protocol.Types  as LSP import           Text.ParserCombinators.ReadP as ReadP---- See Note [Guidelines For Using CPP In GHCIDE Import Statements]  import           GHC.Data.FastString import           GHC.Types.SrcLoc             as GHC
src/Development/IDE/Types/Options.hs view
@@ -2,7 +2,6 @@ -- SPDX-License-Identifier: Apache-2.0  -- | Options-{-# LANGUAGE RankNTypes #-} module Development.IDE.Types.Options   ( IdeOptions(..)   , IdePreprocessedSource(..)@@ -69,10 +68,12 @@   , 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.+    -- ^ Whether to parse modules with '-haddock' by default.+    -- If 'HaddockParse' is given, we parse local haskell modules with the+    -- '-haddock' flag enables.+    -- If a plugin requires the parsed sources *without* '-haddock', it needs+    -- to use rules that explicitly disable the '-haddock' flag.+    -- See call sites of 'withoutOptHaddock' for rules that parse without '-haddock'.   , optModifyDynFlags     :: Config -> DynFlagsModifications     -- ^ Will be called right after setting up a new cradle,     --   allowing to customize the Ghc options used@@ -90,9 +91,9 @@   deriving (Eq,Ord,Show,Enum)  data IdePreprocessedSource = IdePreprocessedSource-  { preprocWarnings :: [(GHC.SrcSpan, String)]+  { preprocWarnings :: [(GHC.SrcSpan, String)] -- TODO: Future work could we make these warnings structured as well?     -- ^ Warnings emitted by the preprocessor.-  , preprocErrors   :: [(GHC.SrcSpan, String)]+  , preprocErrors   :: [(GHC.SrcSpan, String)] -- TODO: Future work could we make these errors structured as well?     -- ^ Errors emitted by the preprocessor.   , preprocSource   :: GHC.ParsedSource     -- ^ New parse tree emitted by the preprocessor.
src/Development/IDE/Types/Shake.hs view
@@ -1,20 +1,18 @@-{-# LANGUAGE DerivingStrategies        #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE PatternSynonyms           #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE PatternSynonyms    #-}+{-# LANGUAGE TypeFamilies       #-} module Development.IDE.Types.Shake   ( Q (..),     A (..),     Value (..),     ValueWithDiagnostics (..),     Values,-    Key (..),+    Key,     BadDependency (..),     ShakeValue(..),     currentValue,     isBadDependency,-  toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey,fromKey,fromKeyType,WithHieDb)+  toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey,fromKey,fromKeyType,WithHieDb,WithHieDbShield(..)) where  import           Control.DeepSeq@@ -26,7 +24,8 @@ import           Data.Vector                          (Vector) import           Development.IDE.Core.PositionMapping import           Development.IDE.Core.RuleTypes       (FileVersion)-import           Development.IDE.Graph                (Key (..), RuleResult, newKey)+import           Development.IDE.Graph                (Key, RuleResult, newKey,+                                                       pattern Key) import qualified Development.IDE.Graph                as Shake import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Location@@ -34,15 +33,17 @@ import           HieDb.Types                          (HieDb) import qualified StmContainers.Map                    as STM import           Type.Reflection                      (SomeTypeRep (SomeTypeRep),-                                                       pattern App, pattern Con,-                                                       typeOf, typeRep,-                                                       typeRepTyCon)-import           Unsafe.Coerce                        (unsafeCoerce)+                                                       eqTypeRep, pattern App,+                                                       type (:~~:) (HRefl),+                                                       typeOf, typeRep)  -- | Intended to represent HieDb calls wrapped with (currently) retry -- functionality type WithHieDb = forall a. (HieDb -> IO a) -> IO a +-- used to smuggle RankNType WithHieDb through dbMVar+newtype WithHieDbShield = WithHieDbShield WithHieDb+ data Value v     = Succeeded (Maybe FileVersion) v     | Stale (Maybe PositionDelta) (Maybe FileVersion) v@@ -84,11 +85,12 @@  -- | fromKeyType (Q (k,f)) = (typeOf k, f) fromKeyType :: Key -> Maybe (SomeTypeRep, NormalizedFilePath)-fromKeyType (Key k) = case typeOf k of-    App (Con tc) a | tc == typeRepTyCon (typeRep @Q)-        -> case unsafeCoerce k of-         Q (_ :: (), f) -> Just (SomeTypeRep a, f)-    _ -> Nothing+fromKeyType (Key k)+  | App tc a <- typeOf k+  , Just HRefl <- tc `eqTypeRep` (typeRep @Q)+  , Q (_, f) <- k+  = Just (SomeTypeRep a, f)+  | otherwise = Nothing  toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k) => k -> Key toNoFileKey k = newKey $ Q (k, emptyFilePath)@@ -99,12 +101,10 @@ 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).+-- | 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).
src/Generics/SYB/GHC.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE DerivingVia #-}-{-# LANGUAGE RankNTypes  #-}  -- | Custom SYB traversals explicitly designed for operating over the GHC AST. module Generics.SYB.GHC
+ src/Text/Fuzzy/Levenshtein.hs view
@@ -0,0 +1,16 @@+module Text.Fuzzy.Levenshtein where++import           Data.List           (sortOn)+import           Data.Text           (Text)+import qualified Data.Text           as T+import           Text.EditDistance+import           Text.Fuzzy.Parallel++-- | Sort the given list according to it's levenshtein distance relative to the+-- given string.+levenshteinScored :: Int -> Text -> [Text] -> [Scored Text]+levenshteinScored chunkSize needle haystack = do+  let levenshtein = levenshteinDistance $ defaultEditCosts {substitutionCosts=ConstantCost 2}+  sortOn score $+    matchPar chunkSize needle haystack id $+      \a b -> Just $ levenshtein (T.unpack a) (T.unpack b)
src/Text/Fuzzy/Parallel.hs view
@@ -1,7 +1,7 @@ -- | Parallel versions of 'filter' and 'simpleFilter'  module Text.Fuzzy.Parallel-(   filter, filter',+(   filter, filter', matchPar,     simpleFilter, simpleFilter',     match, defChunkSize, defMaxResults,     Scored(..)@@ -89,8 +89,7 @@              -> T.Text   -- ^ Pattern to look for.              -> [T.Text] -- ^ List of texts to check.              -> [Scored T.Text] -- ^ The ones that match.-simpleFilter chunk maxRes pattern xs =-  filter chunk maxRes pattern xs id+simpleFilter chunk maxRes pat xs = filter chunk maxRes pat xs id   -- | The function to filter a list of values by fuzzy search on the text extracted from them,@@ -104,15 +103,29 @@        -- ^ Custom scoring function to use for calculating how close words are        -- When the function returns Nothing, this means the values are incomparable.        -> [Scored t]    -- ^ The list of results, sorted, highest score first.-filter' chunkSize maxRes pattern ts extract match' = partialSortByAscScore maxRes perfectScore (concat vss)+filter' chunkSize maxRes pat ts extract match' = partialSortByAscScore maxRes perfectScore $+    matchPar chunkSize pat' ts extract match'   where-      -- Preserve case for the first character, make all others lowercase-      pattern' = case T.uncons pattern of+    perfectScore = fromMaybe (error $ T.unpack pat) $ match' pat pat+    -- Preserve case for the first character, make all others lowercase+    pat' = case T.uncons pat of         Just (c, rest) -> T.cons c (T.toLower rest)-        _              -> pattern-      vss = map (mapMaybe (\t -> flip Scored t <$> match' pattern' (extract t))) (chunkList chunkSize ts)+        _              -> pat++matchPar+    :: Int           -- ^ Chunk size. 1000 works well.+    -> T.Text        -- ^ Pattern.+    -> [t]           -- ^ The list of values containing the text to search in.+    -> (t -> T.Text) -- ^ The function to extract the text from the container.+    -> (T.Text -> T.Text -> Maybe Int)+    -- ^ Custom scoring function to use for calculating how close words are+    -- When the function returns Nothing, this means the values are incomparable.+    -> [Scored t]    -- ^ The list of results, sorted, highest score first.+{-# INLINABLE matchPar #-}+matchPar chunkSize pat ts extract match' = concat vss+  where+    vss = map (mapMaybe (\t -> flip Scored t <$> match' pat (extract t))) (chunkList chunkSize ts)         `using` parList (evalList rseq)-      perfectScore = fromMaybe (error $ T.unpack pattern) $ match' pattern' pattern'  -- | The function to filter a list of values by fuzzy search on the text extracted from them, -- using a custom matching function which determines how close words are.@@ -122,8 +135,8 @@        -> [t]           -- ^ The list of values containing the text to search in.        -> (t -> T.Text) -- ^ The function to extract the text from the container.        -> [Scored t]    -- ^ The list of results, sorted, highest score first.-filter chunkSize maxRes pattern ts extract =-  filter' chunkSize maxRes pattern ts extract match+filter chunkSize maxRes pat ts extract =+  filter' chunkSize maxRes pat ts extract match  -- | Return all elements of the list that have a fuzzy match against the pattern, -- the closeness of the match is determined using the custom scoring match function that is passed.@@ -136,8 +149,8 @@              -> (T.Text -> T.Text -> Maybe Int)              -- ^ Custom scoring function to use for calculating how close words are              -> [Scored T.Text] -- ^ The ones that match.-simpleFilter' chunk maxRes pattern xs match' =-  filter' chunk maxRes pattern xs id match'+simpleFilter' chunk maxRes pat xs match' =+  filter' chunk maxRes pat xs id match' --------------------------------------------------------------------------------  chunkList :: Int -> [a] -> [[a]]
− test/cabal/Development/IDE/Test/Runfiles.hs 
@@ -1,9 +0,0 @@--- 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/TH/THA.hs 
@@ -1,6 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module THA where-import Language.Haskell.TH--th_a :: DecsQ-th_a = [d| a = () |]
− test/data/TH/THB.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module THB where-import THA--$th_a
− test/data/TH/THC.hs 
@@ -1,5 +0,0 @@-module THC where-import THB--c ::()-c = a
− test/data/TH/hie.yaml 
@@ -1,1 +0,0 @@-cradle: {direct: {arguments: ["-Wmissing-signatures", "-package template-haskell", "THA", "THB", "THC"]}}
− test/data/THCoreFile/THA.hs 
@@ -1,23 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module THA where-import Language.Haskell.TH-import Control.Monad (when)--th_a :: DecsQ-th_a = do-  when (show (StrictConstructor1 123 True 4567) /= "StrictConstructor1 123 True 4567") $ error "TH validation error"-  when (show (StrictConstructor2 123 True 4567) /= "StrictConstructor2 123 True 4567") $ error "TH validation error"-  when (show (StrictConstructor3 123 True 4567) /= "StrictConstructor3 123 True 4567") $ error "TH validation error"-  when (show (classMethod 'z') /= "True") $ error "TH validation error"-  when (show (classMethod 'a') /= "False") $ error "TH validation error"-  [d| a = () |]--data StrictType1 = StrictConstructor1 !Int !Bool Int deriving Show-data StrictType2 = StrictConstructor2 !Int !Bool !Int deriving Show-data StrictType3 = StrictConstructor3 !Int !Bool !Int deriving Show--class SingleMethodClass a where-  classMethod :: a -> Bool--instance SingleMethodClass Char where-  classMethod = (== 'z')
− test/data/THCoreFile/THB.hs 
@@ -1,13 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module THB where-import THA-import Control.Monad (when)--$(do-  -- Need to verify in both defining module and usage module"-  when (show (StrictConstructor1 123 True 4567) /= "StrictConstructor1 123 True 4567") $ error "TH validation error"-  when (show (StrictConstructor2 123 True 4567) /= "StrictConstructor2 123 True 4567") $ error "TH validation error"-  when (show (StrictConstructor3 123 True 4567) /= "StrictConstructor3 123 True 4567") $ error "TH validation error"-  when (show (classMethod 'z') /= "True") $ error "TH validation error"-  when (show (classMethod 'a') /= "False") $ error "TH validation error"-  th_a)
− test/data/THCoreFile/THC.hs 
@@ -1,5 +0,0 @@-module THC where-import THB--c ::()-c = a
− test/data/THCoreFile/hie.yaml 
@@ -1,1 +0,0 @@-cradle: {direct: {arguments: ["-package template-haskell", "THA", "THB", "THC"]}}
− test/data/THLoading/A.hs 
@@ -1,5 +0,0 @@-module A where-import B (bar)--foo :: ()-foo = bar
− test/data/THLoading/B.hs 
@@ -1,4 +0,0 @@-module B where--bar :: ()-bar = ()
− test/data/THLoading/THA.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module THA where-import Language.Haskell.TH-import A (foo)--th_a :: DecsQ-th_a = [d| a = foo |]
− test/data/THLoading/THB.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module THB where-import THA--$th_a
− test/data/THLoading/hie.yaml 
@@ -1,1 +0,0 @@-cradle: {direct: {arguments: ["-package template-haskell", "THA", "THB", "A", "B"]}}
− test/data/THNewName/A.hs 
@@ -1,6 +0,0 @@-module A (template) where--import Language.Haskell.TH--template :: DecsQ-template = (\consA -> [DataD [] (mkName "A") [] Nothing [NormalC consA []] []]) <$> newName "A"
− test/data/THNewName/B.hs 
@@ -1,5 +0,0 @@-module B(A(A)) where--import A--template
− test/data/THNewName/C.hs 
@@ -1,4 +0,0 @@-module C where-import B--a = A
− test/data/THNewName/hie.yaml 
@@ -1,1 +0,0 @@-cradle: {direct: {arguments: ["-XTemplateHaskell","-Wmissing-signatures","A", "B", "C"]}}
− test/data/THUnboxed/THA.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE TemplateHaskell, UnboxedTuples, BangPatterns #-}-module THA where-import Language.Haskell.TH--data Foo = Foo !Int !Char !String-  deriving Show--newtype Bar = Bar Int-  deriving Show---f :: Int -> (# Int, Int, Foo, Bar#)-f x = (# x , x+1 , Foo x 'a' "test", Bar 1 #)--th_a :: DecsQ-th_a = case f 1 of (# a , b, Foo _ _ _, Bar !_ #) -> [d| a = () |]
− test/data/THUnboxed/THB.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module THB where-import THA--$th_a
− test/data/THUnboxed/THC.hs 
@@ -1,5 +0,0 @@-module THC where-import THB--c ::()-c = a
− test/data/THUnboxed/hie.yaml 
@@ -1,1 +0,0 @@-cradle: {direct: {arguments: ["-Wmissing-signatures", "-package template-haskell", "THA", "THB", "THC"]}}
− test/data/boot/A.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module A where--import B( TB(..) )--newtype TA = MkTA Int-    deriving Eq--f :: TB -> TA-f (MkTB x) = MkTA x
− test/data/boot/A.hs-boot 
@@ -1,3 +0,0 @@-module A where-newtype TA = MkTA Int-instance Eq TA
− test/data/boot/B.hs 
@@ -1,7 +0,0 @@-module B(TA(..), TB(..)) where-import {-# SOURCE #-} A( TA(..) )--data TB = MkTB !Int--g :: TA -> TB-g (MkTA x) = MkTB x
− test/data/boot/C.hs 
@@ -1,8 +0,0 @@-module C where--import B-import A hiding (MkTA(..))--x = MkTA-y = MkTB-z = f
− test/data/boot/hie.yaml 
@@ -1,1 +0,0 @@-cradle: {direct: {arguments: ["A.hs", "A.hs-boot", "B.hs", "C.hs"]}}
− test/data/boot2/A.hs 
@@ -1,12 +0,0 @@-module A where---- E source imports B--- In interface file see source module dependencies: B {-# SOURCE #-}-import E--- C imports B--- In interface file see source module dependencies: B-import C---- Instance for B only available from B.hi not B.hi-boot, so tests we load--- that.-main = print B
− test/data/boot2/B.hs 
@@ -1,8 +0,0 @@-module B where--import D--data B = B--instance Show B where-  show B = "B"
− test/data/boot2/B.hs-boot 
@@ -1,3 +0,0 @@-module B where--data B = B
− test/data/boot2/C.hs 
@@ -1,3 +0,0 @@-module C where--import B
− test/data/boot2/D.hs 
@@ -1,3 +0,0 @@-module D where--import {-# SOURCE #-} B
− test/data/boot2/E.hs 
@@ -1,3 +0,0 @@-module E(B(B)) where--import {-# SOURCE #-} B
− test/data/boot2/hie.yaml 
@@ -1,1 +0,0 @@-cradle: {direct: {arguments: ["A.hs", "B.hs-boot", "B.hs", "C.hs", "D.hs", "E.hs"]}}
− test/data/cabal-exe/a/a.cabal 
@@ -1,14 +0,0 @@-cabal-version:       2.2--name:                a-version:             0.1.0.0-author:              Fendor-maintainer:          power.walross@gmail.com-build-type:          Simple--executable a-  main-is:             Main.hs-  hs-source-dirs:      src-  ghc-options:         -Wall-  build-depends:       base-  default-language:    Haskell2010
− test/data/cabal-exe/a/src/Main.hs 
@@ -1,3 +0,0 @@-module Main where--main = putStrLn "Hello, Haskell!"
− test/data/cabal-exe/cabal.project 
@@ -1,1 +0,0 @@-packages: ./a
− test/data/cabal-exe/hie.yaml 
@@ -1,3 +0,0 @@-cradle:-  cabal:-    component: "exe:a"
− test/data/hover/Bar.hs 
@@ -1,4 +0,0 @@-module Bar (Bar(..)) where---- | Bar Haddock-data Bar = Bar
− test/data/hover/Foo.hs 
@@ -1,6 +0,0 @@-module Foo (Bar, foo) where--import Bar---- | foo Haddock-foo = Bar
− test/data/hover/GotoHover.hs 
@@ -1,70 +0,0 @@-{-# 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 = _--hole2 :: a -> Maybe a-hole2 = _---- A comment above a type defnition with a deriving clause-data Example = Example-  deriving (Eq)
− test/data/hover/RecordDotSyntax.hs 
@@ -1,18 +0,0 @@-{-# LANGUAGE OverloadedRecordDot, DuplicateRecordFields, NoFieldSelectors #-}--module RecordDotSyntax ( module RecordDotSyntax) where--import qualified Data.Maybe as M--data MyRecord = MyRecord-  { a :: String-  , b :: Integer-  , c :: MyChild-  } deriving (Eq, Show)--newtype MyChild = MyChild-  { z :: String-  } deriving (Eq, Show)--x = MyRecord { a = "Hello", b = 12, c = MyChild { z = "there" } }-y = x.a ++ show x.b ++ x.c.z
− test/data/hover/hie.yaml 
@@ -1,1 +0,0 @@-cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax"]}}
− test/data/ignore-fatal/IgnoreFatal.hs 
@@ -1,8 +0,0 @@--- "missing signature" is declared a fatal warning in the cabal file,--- but is ignored in this module.--{-# OPTIONS_GHC -fno-warn-missing-signatures #-}--module IgnoreFatal where--a = 'a'
− test/data/ignore-fatal/cabal.project 
@@ -1,1 +0,0 @@-packages: ignore-fatal.cabal
− test/data/ignore-fatal/hie.yaml 
@@ -1,4 +0,0 @@-cradle:-  cabal:-    - path: "."-      component: "lib:ignore-fatal"
− test/data/ignore-fatal/ignore-fatal.cabal 
@@ -1,10 +0,0 @@-name: ignore-fatal-version: 1.0.0-build-type: Simple-cabal-version: >= 1.2--library-  build-depends: base-  exposed-modules: IgnoreFatal-  hs-source-dirs: .-  ghc-options: -Werror=missing-signatures
− test/data/multi/a/A.hs 
@@ -1,3 +0,0 @@-module A(foo) where-import Control.Concurrent.Async-foo = ()
− test/data/multi/a/a.cabal 
@@ -1,9 +0,0 @@-name: a-version: 1.0.0-build-type: Simple-cabal-version: >= 1.2--library-  build-depends: base, async >= 2.0-  exposed-modules: A-  hs-source-dirs: .
− test/data/multi/b/B.hs 
@@ -1,3 +0,0 @@-module B(module B) where-import A-qux = foo
− test/data/multi/b/b.cabal 
@@ -1,9 +0,0 @@-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/c/C.hs 
@@ -1,3 +0,0 @@-module C(module C) where-import A-cux = foo
− test/data/multi/c/c.cabal 
@@ -1,9 +0,0 @@-name: c-version: 1.0.0-build-type: Simple-cabal-version: >= 1.2--library-  build-depends: base, a-  exposed-modules: C-  hs-source-dirs: .
− test/data/multi/cabal.project 
@@ -1,3 +0,0 @@-packages: a b c--allow-newer: base
− test/data/multi/hie.yaml 
@@ -1,8 +0,0 @@-cradle:-  cabal:-    - path: "./a"-      component: "lib:a"-    - path: "./b"-      component: "lib:b"-    - path: "./c"-      component: "lib:c"
− test/data/plugin-knownnat/KnownNat.hs 
@@ -1,10 +0,0 @@-{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}-{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-}-module KnownNat where-import Data.Proxy-import GHC.TypeLits--f :: forall n. KnownNat n => Proxy n -> Integer-f _ = natVal (Proxy :: Proxy n) + natVal (Proxy :: Proxy (n+2))-foo :: Int -> Int -> Int-foo a _b = a + c
− test/data/plugin-knownnat/cabal.project 
@@ -1,4 +0,0 @@-packages: .---- Needed for ghc >= 9.0.2 and ghc-typelits-natnormalise == 0.7.6-allow-newer: ghc-typelits-natnormalise:ghc-bignum
− test/data/plugin-knownnat/plugin.cabal 
@@ -1,9 +0,0 @@-cabal-version:  1.18-name: plugin-version: 1.0.0-build-type: Simple--library-  build-depends: base, ghc-typelits-knownnat-  exposed-modules: KnownNat-  hs-source-dirs: .
− test/data/plugin-recorddot/RecordDot.hs 
@@ -1,6 +0,0 @@-{-# LANGUAGE DuplicateRecordFields, TypeApplications, TypeFamilies, UndecidableInstances, FlexibleContexts, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}-{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}-module RecordDot (Company(..), display) where-data Company = Company {name :: String}-display :: Company -> String-display c = c.name
− test/data/plugin-recorddot/cabal.project 
@@ -1,1 +0,0 @@-packages: .
− test/data/plugin-recorddot/plugin.cabal 
@@ -1,9 +0,0 @@-cabal-version:  1.18-name: plugin-version: 1.0.0-build-type: Simple--library-  build-depends: base, record-dot-preprocessor, record-hasfield-  exposed-modules: RecordDot-  hs-source-dirs: .
− test/data/recomp/A.hs 
@@ -1,6 +0,0 @@-module A(x) where--import B--x :: Int-x = y
− test/data/recomp/B.hs 
@@ -1,4 +0,0 @@-module B(y) where--y :: Int-y = undefined
− test/data/recomp/P.hs 
@@ -1,5 +0,0 @@-module P() where-import A-import B--bar = x :: Int
− test/data/recomp/hie.yaml 
@@ -1,1 +0,0 @@-cradle: {direct: {arguments: ["-Wmissing-signatures","B", "A", "P"]}}
− test/data/references/Main.hs 
@@ -1,14 +0,0 @@-module Main where--import References--main :: IO ()-main = return ()----a = 2 :: Int-b = a + 1--acc :: Account-acc = Savings
− test/data/references/OtherModule.hs 
@@ -1,9 +0,0 @@-module OtherModule (symbolDefinedInOtherModule, symbolDefinedInOtherOtherModule) where--import OtherOtherModule--symbolDefinedInOtherModule = 1--symbolLocalToOtherModule = 2--someFxn x = x + symbolLocalToOtherModule
− test/data/references/OtherOtherModule.hs 
@@ -1,3 +0,0 @@-module OtherOtherModule where--symbolDefinedInOtherOtherModule = "asdf"
− test/data/references/References.hs 
@@ -1,25 +0,0 @@-module References where--import OtherModule--foo = bar--bar = let x = bar 42 in const "hello"--baz = do-  x <- bar 23-  return $ bar 14--data Account =-  Checking-  | Savings--bobsAccount = Checking--bobHasChecking = case bobsAccount of-                     Checking -> True-                     Savings -> False--x = symbolDefinedInOtherModule--y = symbolDefinedInOtherOtherModule
− test/data/references/hie.yaml 
@@ -1,1 +0,0 @@-cradle: {direct: {arguments: ["Main","OtherModule","OtherOtherModule","References"]}}
− test/data/rootUri/dirA/Foo.hs 
@@ -1,3 +0,0 @@-module Foo () where--foo = ()
− test/data/rootUri/dirA/foo.cabal 
@@ -1,9 +0,0 @@-name: foo-version: 1.0.0-build-type: Simple-cabal-version: >= 1.2--library-  build-depends: base-  exposed-modules: Foo-  hs-source-dirs: .
− test/data/rootUri/dirB/Foo.hs 
@@ -1,3 +0,0 @@-module Foo () where--foo = ()
− test/data/rootUri/dirB/foo.cabal 
@@ -1,9 +0,0 @@-name: foo-version: 1.0.0-build-type: Simple-cabal-version: >= 1.2--library-  build-depends: base-  exposed-modules: Foo-  hs-source-dirs: .
− test/data/symlink/hie.yaml 
@@ -1,10 +0,0 @@--cradle:-  direct:-    arguments:-      - -i-      - -isrc-      - -iother_loc/-      - other_loc/Sym.hs-      - src/Foo.hs-      - -Wall
− test/data/symlink/some_loc/Sym.hs 
@@ -1,4 +0,0 @@-module Sym where--foo :: String-foo = ""
− test/data/symlink/src/Foo.hs 
@@ -1,4 +0,0 @@-module Foo where--import Sym-
− test/exe/AsyncTests.hs 
@@ -1,53 +0,0 @@-{-# LANGUAGE DataKinds #-}--module AsyncTests (tests) where--import           Control.Monad-import           Control.Monad.IO.Class        (liftIO)-import           Data.Aeson                    (toJSON)-import           Data.Proxy-import qualified Data.Text                     as T-import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Types   hiding-                                               (SemanticTokenAbsolute (..),-                                                SemanticTokenRelative (..),-                                                SemanticTokensEdit (..),-                                                mkRange)-import           Language.LSP.Test--- import Test.QuickCheck.Instances ()-import           Development.IDE.Plugin.Test   (TestRequest (BlockSeconds),-                                                blockCommandId)-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils---- | Test if ghcide asynchronously handles Commands and user Requests-tests :: TestTree-tests = testGroup "async"-    [-      testSession "command" $ do-            -- Execute a command that will block forever-            let req = ExecuteCommandParams Nothing blockCommandId Nothing-            void $ sendRequest SMethod_WorkspaceExecuteCommand 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-            codeLenses <- getAndResolveCodeLenses doc-            liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=?-              [ "foo :: a -> a" ]-    , testSession "request" $ do-            -- Execute a custom request that will block for 1000 seconds-            void $ sendRequest (SMethod_CustomMethod (Proxy @"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-            codeLenses <- getAndResolveCodeLenses doc-            liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=?-              [ "foo :: a -> a" ]-    ]
− test/exe/BootTests.hs 
@@ -1,55 +0,0 @@-module BootTests (tests) where--import           Control.Applicative.Combinators-import           Control.Monad-import           Control.Monad.IO.Class          (liftIO)-import           Development.IDE.GHC.Util-import           Development.IDE.Test            (expectNoMoreDiagnostics,-                                                  isReferenceReady)-import           Development.IDE.Types.Location-import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Types     hiding-                                                 (SemanticTokenAbsolute (..),-                                                  SemanticTokenRelative (..),-                                                  SemanticTokensEdit (..),-                                                  mkRange)-import           Language.LSP.Test-import           System.FilePath-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils---tests :: TestTree-tests = testGroup "boot"-  [ 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-            -- We send a hover request then wait for either the hover response or-            -- `ghcide/reference/ready` notification.-            -- Once we receive one of the above, we wait for the other that we-            -- haven't received yet.-            -- If we don't wait for the `ready` notification it is possible-            -- that the `getDefinitions` request/response in the outer ghcide-            -- session will find no definitions.-            let hoverParams = HoverParams cDoc (Position 4 3) Nothing-            hoverRequestId <- sendRequest SMethod_TextDocumentHover hoverParams-            let parseReadyMessage = isReferenceReady cPath-            let parseHoverResponse = responseForId SMethod_TextDocumentHover hoverRequestId-            hoverResponseOrReadyMessage <- skipManyTill anyMessage ((Left <$> parseHoverResponse) <|> (Right <$> parseReadyMessage))-            _ <- skipManyTill anyMessage $-              case hoverResponseOrReadyMessage of-                Left _  -> void parseReadyMessage-                Right _ -> void parseHoverResponse-            closeDoc cDoc-        cdoc <- createDoc cPath "haskell" cSource-        locs <- getDefinitions cdoc (Position 7 4)-        let floc = mkR 9 0 9 1-        checkDefs locs (pure [floc])-  , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do-      _ <- openDoc (dir </> "A.hs") "haskell"-      expectNoMoreDiagnostics 2-  ]
− test/exe/CPPTests.hs 
@@ -1,56 +0,0 @@-module CPPTests (tests) where--import           Control.Exception           (catch)-import qualified Data.Text                   as T-import           Development.IDE.Test        (Cursor, expectDiagnostics,-                                              expectNoMoreDiagnostics)-import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),-                                              SemanticTokenRelative (..),-                                              SemanticTokensEdit (..), mkRange)-import           Language.LSP.Test--- import Test.QuickCheck.Instances ()-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils--tests :: TestTree-tests =-  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 maxBound == -1 unsigned). Assert either-        -- of them.-        (run $ expectError content (2, maxBound))-          `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", [(DiagnosticSeverity_Error, (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",-            [(DiagnosticSeverity_Error, cursor, "error: unterminated")]-          )-        ]-      expectNoMoreDiagnostics 0.5
− test/exe/ClientSettingsTests.hs 
@@ -1,35 +0,0 @@-{-# LANGUAGE GADTs #-}-module ClientSettingsTests (tests) where--import           Control.Applicative.Combinators-import           Control.Monad-import           Data.Aeson                      (toJSON)-import           Data.Default-import qualified Data.Text                       as T-import           Ide.Types-import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Types     hiding-                                                 (SemanticTokenAbsolute (..),-                                                  SemanticTokenRelative (..),-                                                  SemanticTokensEdit (..),-                                                  mkRange)-import           Language.LSP.Test-import           Test.Tasty-import           TestUtils--tests :: TestTree-tests = testGroup "client settings handling"-    [ testSession "ghcide restarts shake session on config changes" $ do-            setIgnoringLogNotifications False-            void $ skipManyTill anyMessage $ message SMethod_ClientRegisterCapability-            void $ createDoc "A.hs" "haskell" "module A where"-            waitForProgressDone-            setConfigSection "haskell" $ toJSON (def :: Config)-            skipManyTill anyMessage restartingBuildSession--    ]-  where-    restartingBuildSession :: Session ()-    restartingBuildSession = do-        FromServerMess SMethod_WindowLogMessage TNotificationMessage{_params = LogMessageParams{..}} <- loggingNotification-        guard $ "Restarting build session" `T.isInfixOf` _message
− test/exe/CodeLensTests.hs 
@@ -1,122 +0,0 @@-{-# LANGUAGE GADTs #-}--module CodeLensTests (tests) where--import           Control.Applicative.Combinators-import           Control.Lens                    ((^.))-import           Control.Monad                   (void)-import           Control.Monad.IO.Class          (liftIO)-import qualified Data.Aeson                      as A-import           Data.Maybe-import qualified Data.Text                       as T-import           Data.Tuple.Extra-import           Development.IDE.GHC.Compat      (GhcVersion (..), ghcVersion)-import qualified Language.LSP.Protocol.Lens      as L-import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Types     hiding-                                                 (SemanticTokenAbsolute (..),-                                                  SemanticTokenRelative (..),-                                                  SemanticTokensEdit (..),-                                                  mkRange)-import           Language.LSP.Test-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils--tests :: TestTree-tests = testGroup "code lenses"-  [ addSigLensesTests-  ]---addSigLensesTests :: TestTree-addSigLensesTests =-  let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"-      moduleH exported =-        T.unlines-          [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators,GADTs,BangPatterns #-}"-          , "module Sigs(" <> exported <> ") where"-          , "import qualified Data.Complex as C"-          , "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)"-          , "data T1 a where"-          , "  MkT1 :: (Show b) => a -> b -> T1 a"-          ]-      before enableGHCWarnings exported (def, _) others =-        T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others-      after' enableGHCWarnings exported (def, sig) others =-        T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others-      createConfig mode = A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]-      sigSession testName enableGHCWarnings waitForDiags mode exported def others = testSession testName $ do-        let originalCode = before enableGHCWarnings exported def others-        let expectedCode = after' enableGHCWarnings exported def others-        setConfigSection "haskell" (createConfig mode)-        doc <- createDoc "Sigs.hs" "haskell" originalCode-        -- Because the diagnostics mode is really relying only on diagnostics now-        -- to generate the code lens we need to make sure we wait till the file-        -- is parsed before asking for codelenses, otherwise we will get nothing.-        if waitForDiags-          then void waitForDiagnostics-          else waitForProgressDone-        codeLenses <- getAndResolveCodeLenses doc-        if not $ null $ snd def-          then do-            liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses-            executeCommand $ fromJust $ head codeLenses ^. L.command-            modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc)-            liftIO $ expectedCode @=? modifiedCode-          else liftIO $ null codeLenses @? "Expected no code lens, but got: " <> show codeLenses-      cases =-        [ ("abc = True", "abc :: Bool")-        , ("foo a b = a + b", "foo :: Num a => a -> a -> a")-        , ("bar a b = show $ a + b", "bar :: (Show a, Num a) => a -> a -> String")-        , ("(!!!) a b = a > b", "(!!!) :: Ord a => a -> a -> Bool")-        , ("a >>>> b = a + b", "(>>>>) :: Num a => a -> a -> a")-        , ("a `haha` b = a b", "haha :: (t1 -> t2) -> t1 -> t2")-        , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a")-        , ("pattern Some a <- Just a", "pattern Some :: a -> Maybe a")-        , ("pattern Some a <- Just a\n  where Some a = Just a", "pattern Some :: a -> Maybe a")-        , ("pattern Some a <- Just !a\n  where Some !a = Just a", "pattern Some :: a -> Maybe a")-        , ("pattern Point{x, y} = (x, y)", "pattern Point :: a -> b -> (a, b)")-        , ("pattern Point{x, y} <- (x, y)", "pattern Point :: a -> b -> (a, b)")-        , ("pattern Point{x, y} <- (x, y)\n  where Point x y = (x, y)", "pattern Point :: a -> b -> (a, b)")-        , ("pattern MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a")-        , ("pattern MkT1' b <- MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a")-        , ("pattern MkT1' b <- MkT1 42 b\n  where MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a")-        , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a")-        , ("head = 233", "head :: Integer")-        , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, " <> listOfChar <> ")")-        , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"")-        , ("promotedKindTest = Proxy @Nothing", if ghcVersion >= GHC96 then "promotedKindTest :: Proxy Nothing" else "promotedKindTest :: Proxy 'Nothing")-        , ("typeOperatorTest = Refl", if ghcVersion >= GHC92 then "typeOperatorTest :: forall {k} {a :: k}. a :~: a" else "typeOperatorTest :: a :~: a")-        , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType")-        , ("aVeryLongSignature a b c d e f g h i j k l m n = a && b && c && d && e && f && g && h && i && j && k && l && m && n", "aVeryLongSignature :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool")-        ]-   in testGroup-        "add signature"-        [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False False "always" "" (def, Just sig) [] | (def, sig) <- cases]-        , sigSession "exported mode works" False False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases)-        , testGroup-            "diagnostics mode works"-            [ sigSession "with GHC warnings" True True "diagnostics" "" (second Just $ head cases) []-            , sigSession "without GHC warnings" False False "diagnostics" "" (second (const Nothing) $ head cases) []-            ]-        , testSession "keep stale lens" $ do-            let content = T.unlines-                    [ "module Stale where"-                    , "f = _"-                    ]-            doc <- createDoc "Stale.hs" "haskell" content-            oldLens <- getCodeLenses doc-            liftIO $ length oldLens @?= 1-            let edit = TextEdit (mkRange 0 4 0 5) "" -- Remove the `_`-            _ <- applyEdit doc edit-            newLens <- getCodeLenses doc-            liftIO $ newLens @?= oldLens-        ]---- | Before ghc9, lists of Char is displayed as [Char], but with ghc9 and up, it's displayed as String-listOfChar :: T.Text-listOfChar | ghcVersion >= GHC90 = "String"-           | otherwise = "[Char]"--
− test/exe/CompletionTests.hs 
@@ -1,576 +0,0 @@--{-# LANGUAGE GADTs            #-}-{-# LANGUAGE OverloadedLabels #-}--module CompletionTests (tests) where--import           Control.Lens                   ((^.))-import qualified Control.Lens                   as Lens-import           Control.Monad-import           Control.Monad.IO.Class         (liftIO)-import           Data.Default-import           Data.List.Extra-import           Data.Maybe-import           Data.Row-import qualified Data.Text                      as T-import           Development.IDE.GHC.Compat     (GhcVersion (..), ghcVersion)-import           Development.IDE.Test           (waitForTypecheck)-import           Development.IDE.Types.Location-import           Ide.Plugin.Config-import qualified Language.LSP.Protocol.Lens     as L-import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Types    hiding-                                                (SemanticTokenAbsolute (..),-                                                 SemanticTokenRelative (..),-                                                 SemanticTokensEdit (..),-                                                 mkRange)-import           Language.LSP.Test-import           System.FilePath-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils---tests :: TestTree-tests-  = testGroup "completion"-    [-    testGroup "non local" nonLocalCompletionTests-    , testGroup "topLevel" topLevelCompletionTests-    , testGroup "local" localCompletionTests-    , testGroup "package" packageCompletionTests-    , testGroup "project" projectCompletionTests-    , testGroup "other" otherCompletionTests-    , testGroup "doc" completionDocTests-    ]--completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe [TextEdit])] -> TestTree-completionTest name src pos expected = testSessionWait name $ do-    docId <- createDoc "A.hs" "haskell" (T.unlines src)-    _ <- waitForDiagnostics-    compls <- getAndResolveCompletions docId pos-    let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls]-    let emptyToMaybe x = if T.null x then Nothing else Just x-    liftIO $ sortOn (Lens.view Lens._1) (take (length expected) 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 $-            liftIO $ assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail)-        when expectedDocs $-            liftIO $ assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation)---topLevelCompletionTests :: [TestTree]-topLevelCompletionTests = [-    completionTest-        "variable"-        ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]-        (Position 0 8)-        [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing)-        ],-    completionTest-        "constructor"-        ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]-        (Position 0 8)-        [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing)-        ],-    completionTest-        "class method"-        ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"]-        (Position 0 8)-        [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing)],-    completionTest-        "type"-        ["bar :: Xz", "zzz = ()", "-- | haddock", "data Xzz = XzzCon"]-        (Position 0 9)-        [("Xzz", CompletionItemKind_Struct, "Xzz", False, True, Nothing)],-    completionTest-        "class"-        ["bar :: Xz", "zzz = ()", "-- | haddock", "class Xzz a"]-        (Position 0 9)-        [("Xzz", CompletionItemKind_Interface, "Xzz", False, True, Nothing)],-    completionTest-        "records"-        ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ]-        (Position 1 19)-        [("_personName", CompletionItemKind_Function, "_personName", False, True, Nothing),-         ("_personAge", CompletionItemKind_Function, "_personAge", False, True, Nothing)],-    completionTest-        "recordsConstructor"-        ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ]-        (Position 1 19)-        [("XyRecord", CompletionItemKind_Constructor, "XyRecord", False, True, Nothing),-         ("XyRecord", CompletionItemKind_Snippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)]-    ]--localCompletionTests :: [TestTree]-localCompletionTests = [-    completionTest-        "argument"-        ["bar (Just abcdef) abcdefg = abcd"]-        (Position 0 32)-        [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing),-         ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing)-        ],-    completionTest-        "let"-        ["bar = let (Just abcdef) = undefined"-        ,"          abcdefg = let abcd = undefined in undefined"-        ,"        in abcd"-        ]-        (Position 2 15)-        [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing),-         ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing)-        ],-    completionTest-        "where"-        ["bar = abcd"-        ,"  where (Just abcdef) = undefined"-        ,"        abcdefg = let abcd = undefined in undefined"-        ]-        (Position 0 10)-        [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing),-         ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing)-        ],-    completionTest-        "do/1"-        ["bar = do"-        ,"  Just abcdef <- undefined"-        ,"  abcd"-        ,"  abcdefg <- undefined"-        ,"  pure ()"-        ]-        (Position 2 6)-        [("abcdef", CompletionItemKind_Function, "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", CompletionItemKind_Function, "abcde", True, False, Nothing)-        ,("abcdefghij", CompletionItemKind_Function, "abcdefghij", True, False, Nothing)-        ,("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing)-        ,("abcdefg", CompletionItemKind_Function, "abcdefg", True, False, Nothing)-        ,("abcdefgh", CompletionItemKind_Function, "abcdefgh", True, False, Nothing)-        ,("abcdefghi", CompletionItemKind_Function, "abcdefghi", True, False, Nothing)-        ],-    completionTest-        "type family"-        ["{-# LANGUAGE DataKinds, TypeFamilies #-}"-        ,"type family Bar a"-        ,"a :: Ba"-        ]-        (Position 2 7)-        [("Bar", CompletionItemKind_Struct, "Bar", True, False, Nothing)-        ],-    completionTest-        "class method"-        [-          "class Test a where"-        , "    abcd :: a -> ()"-        , "    abcde :: a -> Int"-        , "instance Test Int where"-        , "    abcd = abc"-        ]-        (Position 4 14)-        [("abcd", CompletionItemKind_Function, "abcd", True, False, Nothing)-        ,("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing)-        ],-    testSessionWait "incomplete entries" $ do-        let src a = "data Data = " <> a-        doc <- createDoc "A.hs" "haskell" $ src "AAA"-        void $ waitForTypecheck doc-        let editA rhs =-                changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ src rhs]-        editA "AAAA"-        void $ waitForTypecheck doc-        editA "AAAAA"-        void $ waitForTypecheck doc--        compls <- getCompletions doc (Position 0 15)-        liftIO $ filter ("AAA" `T.isPrefixOf`) (mapMaybe _insertText compls) @?= ["AAAAA"]-        pure ()-    ]--nonLocalCompletionTests :: [TestTree]-nonLocalCompletionTests =-  [ brokenForWinGhc $ completionTest-      "variable"-      ["module A where", "f = hea"]-      (Position 1 7)-      [("head", CompletionItemKind_Function, "head", True, True, Nothing)],-    completionTest-      "constructor"-      ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"]-      (Position 2 8)-      [ ("True", CompletionItemKind_Constructor, "True", True, True, Nothing)-      ],-    brokenForWinGhc $ completionTest-      "type"-      ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"]-      (Position 2 8)-      [ ("Bool", CompletionItemKind_Struct, "Bool", True, True, Nothing)-      ],-    completionTest-      "qualified"-      ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]-      (Position 2 15)-      [ ("head", CompletionItemKind_Function, "head", True, True, Nothing)-      ],-    completionTest-      "duplicate import"-      ["module A where", "import Data.List", "import Data.List", "f = permu"]-      (Position 3 9)-      [ ("permutations", CompletionItemKind_Function, "permutations", False, False, Nothing)-      ],-    completionTest-       "dont show hidden items"-       [ "{-# LANGUAGE NoImplicitPrelude #-}",-         "module A where",-         "import Control.Monad hiding (join)",-         "f = joi"-       ]-       (Position 3 6)-       [],-    testGroup "ordering"-      [completionTest "qualified has priority"-        ["module A where"-        ,"import qualified Data.ByteString as BS"-        ,"f = BS.read"-        ]-        (Position 2 10)-        [("readFile", CompletionItemKind_Function, "readFile", True, True, Nothing)]-        ],-      -- 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)-      []-  ]-  where-    brokenForWinGhc = knownBrokenFor (BrokenSpecific Windows [GHC90, GHC92, GHC94, GHC96, GHC98]) "Windows has strange things in scope for some reason"--otherCompletionTests :: [TestTree]-otherCompletionTests = [-    completionTest-      "keyword"-      ["module A where", "f = newty"]-      (Position 1 9)-      [("newtype", CompletionItemKind_Keyword, "", 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", CompletionItemKind_Struct, "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 $ take 1 compls' @?= ["member"],--    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-  ]--packageCompletionTests :: [TestTree]-packageCompletionTests =-  [ testSession' "fromList" $ \dir -> do-        liftIO $ writeFile (dir </> "hie.yaml")-            "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}"-        doc <- createDoc "A.hs" "haskell" $ T.unlines-            [ "{-# OPTIONS_GHC -Wunused-binds #-}",-                "module A () where",-                "a = fromList"-            ]-        _ <- waitForDiagnostics-        compls <- getCompletions doc (Position 2 12)-        let compls' =-              [T.drop 1 $ T.dropEnd 3 d-              | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label}-                <- compls-              , _label == "fromList"-              ]-        liftIO $ take 3 (sort compls') @?=-          map ("Defined in "<>) (-              [ "'Data.List.NonEmpty"-              , "'GHC.Exts"-              ] ++ if ghcVersion >= GHC94 then [ "'GHC.IsList" ] else [])--  , testSessionWait "Map" $ do-        doc <- createDoc "A.hs" "haskell" $ T.unlines-            [ "{-# OPTIONS_GHC -Wunused-binds #-}",-                "module A () where",-                "a :: Map"-            ]-        _ <- waitForDiagnostics-        compls <- getCompletions doc (Position 2 7)-        let compls' =-              [T.drop 1 $ T.dropEnd 3 d-              | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label}-                <- compls-              , _label == "Map"-              ]-        liftIO $ take 3 (sort compls') @?=-          map ("Defined in "<>)-              [ "'Data.Map"-              , "'Data.Map.Lazy"-              , "'Data.Map.Strict"-              ]-  , testSessionWait "no duplicates" $ do-        doc <- createDoc "A.hs" "haskell" $ T.unlines-            [ "{-# OPTIONS_GHC -Wunused-binds #-}",-                "module A () where",-                "import GHC.Exts(fromList)",-                "a = fromList"-            ]-        _ <- waitForDiagnostics-        compls <- getCompletions doc (Position 3 13)-        let duplicate =-              filter-                (\case-                  CompletionItem-                    { _insertText = Just "fromList"-                    , _documentation =-                      Just (InR (MarkupContent MarkupKind_Markdown d))-                    } ->-                    "GHC.Exts" `T.isInfixOf` d-                  _ -> False-                ) compls-        liftIO $ length duplicate @?= 1--  , testSessionWait "non-local before global" $ do-    -- non local completions are more specific-        doc <- createDoc "A.hs" "haskell" $ T.unlines-            [ "{-# OPTIONS_GHC -Wunused-binds #-}",-                "module A () where",-                "import GHC.Exts(fromList)",-                "a = fromList"-            ]-        _ <- waitForDiagnostics-        compls <- getCompletions doc (Position 3 13)-        let compls' =-              [_insertText-              | CompletionItem {_label, _insertText} <- compls-              , _label == "fromList"-              ]-        liftIO $ take 3 compls' @?=-          map Just ["fromList"]-  ]--projectCompletionTests :: [TestTree]-projectCompletionTests =-    [ testSession' "from hiedb" $ \dir-> do-        liftIO $ writeFile (dir </> "hie.yaml")-            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}"-        _ <- createDoc "A.hs" "haskell" $ T.unlines-            [  "module A (anidentifier) where",-               "anidentifier = ()"-            ]-        _ <- waitForDiagnostics-        -- Note that B does not import A-        doc <- createDoc "B.hs" "haskell" $ T.unlines-            [ "module B where",-              "b = anidenti"-            ]-        compls <- getCompletions doc (Position 1 10)-        let compls' =-              [T.drop 1 $ T.dropEnd 3 d-              | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label}-                <- compls-              , _label == "anidentifier"-              ]-        liftIO $ compls' @?= ["Defined in 'A"],-      testSession' "auto complete project imports" $ \dir-> do-        liftIO $ writeFile (dir </> "hie.yaml")-            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}"-        _ <- createDoc "ALocalModule.hs" "haskell" $ T.unlines-            [  "module ALocalModule (anidentifier) where",-               "anidentifier = ()"-            ]-        _ <- waitForDiagnostics-        -- Note that B does not import A-        doc <- createDoc "B.hs" "haskell" $ T.unlines-            [ "module B where",-              "import ALocal"-            ]-        compls <- getCompletions doc (Position 1 13)-        let item = head $ filter ((== "ALocalModule") . (^. L.label)) compls-        liftIO $ do-          item ^. L.label @?= "ALocalModule",-      testSession' "auto complete functions from qualified imports without alias" $ \dir-> do-        liftIO $ writeFile (dir </> "hie.yaml")-            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}"-        _ <- createDoc "A.hs" "haskell" $ T.unlines-            [  "module A (anidentifier) where",-               "anidentifier = ()"-            ]-        _ <- waitForDiagnostics-        doc <- createDoc "B.hs" "haskell" $ T.unlines-            [ "module B where",-              "import qualified A",-              "A."-            ]-        compls <- getCompletions doc (Position 2 2)-        let item = head compls-        liftIO $ do-          item ^. L.label @?= "anidentifier",-      testSession' "auto complete functions from qualified imports with alias" $ \dir-> do-        liftIO $ writeFile (dir </> "hie.yaml")-            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}"-        _ <- createDoc "A.hs" "haskell" $ T.unlines-            [  "module A (anidentifier) where",-               "anidentifier = ()"-            ]-        _ <- waitForDiagnostics-        doc <- createDoc "B.hs" "haskell" $ T.unlines-            [ "module B where",-              "import qualified A as Alias",-              "foo = Alias."-            ]-        compls <- getCompletions doc (Position 2 12)-        let item = head compls-        liftIO $ do-          item ^. L.label @?= "anidentifier"-    ]--completionDocTests :: [TestTree]-completionDocTests =-  [ testSession "local define" $ do-      doc <- createDoc "A.hs" "haskell" $ T.unlines-        [ "module A where"-        , "foo = ()"-        , "bar = fo"-        ]-      let expected = "*Defined at line 2, column 1 in this module*\n"-      test doc (Position 2 8) "foo" Nothing [expected]-  , testSession "local empty doc" $ do-      doc <- createDoc "A.hs" "haskell" $ T.unlines-        [ "module A where"-        , "foo = ()"-        , "bar = fo"-        ]-      test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"]-  , testSession "local single line doc without newline" $ do-      doc <- createDoc "A.hs" "haskell" $ T.unlines-        [ "module A where"-        , "-- |docdoc"-        , "foo = ()"-        , "bar = fo"-        ]-      test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\n\n\ndocdoc\n"]-  , testSession "local multi line doc with newline" $ do-      doc <- createDoc "A.hs" "haskell" $ T.unlines-        [ "module A where"-        , "-- | abcabc"-        , "--"-        , "foo = ()"-        , "bar = fo"-        ]-      test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n\n\nabcabc\n"]-  , testSession "local multi line doc without newline" $ do-      doc <- createDoc "A.hs" "haskell" $ T.unlines-        [ "module A where"-        , "-- |     abcabc"-        , "--"-        , "--def"-        , "foo = ()"-        , "bar = fo"-        ]-      test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n\n\nabcabc \n\ndef\n"]-  , testSession "extern empty doc" $ do-      doc <- createDoc "A.hs" "haskell" $ T.unlines-        [ "module A where"-        , "foo = od"-        ]-      let expected = "*Imported from 'Prelude'*\n"-      test doc (Position 1 8) "odd" (Just $ T.length expected) [expected]-  , brokenForMacGhc9 $ brokenForWinGhc90 $ testSession "extern single line doc without '\\n'" $ do-      doc <- createDoc "A.hs" "haskell" $ T.unlines-        [ "module A where"-        , "foo = no"-        ]-      let expected = "*Imported from 'Prelude'*\n* * *\n\n\nBoolean \"not\"\n"-      test doc (Position 1 8) "not" (Just $ T.length expected) [expected]-  , brokenForMacGhc9 $ brokenForWinGhc90 $ testSession "extern mulit line doc" $ do-      doc <- createDoc "A.hs" "haskell" $ T.unlines-        [ "module A where"-        , "foo = i"-        ]-      let expected = "*Imported from 'Prelude'*\n* * *\n\n\nIdentity function. \n```haskell\nid x = x\n```\n"-      test doc (Position 1 7) "id" (Just $ T.length expected) [expected]-  , testSession "extern defined doc" $ do-      doc <- createDoc "A.hs" "haskell" $ T.unlines-        [ "module A where"-        , "foo = i"-        ]-      let expected = "*Imported from 'Prelude'*\n"-      test doc (Position 1 7) "id" (Just $ T.length expected) [expected]-  ]-  where-    brokenForGhc9 = knownBrokenFor (BrokenForGHC [GHC90, GHC92, GHC94, GHC96]) "Completion doc doesn't support ghc9"-    brokenForWinGhc90 = knownBrokenFor (BrokenSpecific Windows [GHC90]) "Extern doc doesn't support Windows for ghc9.2"-    -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903-    brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC90, GHC92, GHC94, GHC96]) "Extern doc doesn't support MacOS for ghc9"-    test doc pos label mn expected = do-      _ <- waitForDiagnostics-      compls <- getCompletions doc pos-      rcompls <- forM compls $ \item -> do-            if isJust (item ^. L.data_)-            then do-                rsp <- request SMethod_CompletionItemResolve item-                case rsp ^. L.result of-                    Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err)-                    Right x -> pure x-            else pure item-      let compls' = [-            -- We ignore doc uris since it points to the local path which determined by specific machines-            case mn of-                Nothing -> txt-                Just n  -> T.take n txt-            | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown txt)), ..} <- rcompls-            , _label == label-            ]-      liftIO $ compls' @?= expected
− test/exe/CradleTests.hs 
@@ -1,219 +0,0 @@--{-# LANGUAGE GADTs            #-}-{-# LANGUAGE OverloadedLabels #-}--module CradleTests (tests) where--import           Control.Applicative.Combinators-import           Control.Monad.IO.Class          (liftIO)-import           Data.Row-import qualified Data.Text                       as T-import           Development.IDE.GHC.Compat      (GhcVersion (..), ghcVersion)-import           Development.IDE.GHC.Util-import           Development.IDE.Test            (expectDiagnostics,-                                                  expectDiagnosticsWithTags,-                                                  expectNoMoreDiagnostics,-                                                  isReferenceReady,-                                                  waitForAction)-import           Development.IDE.Types.Location-import qualified Language.LSP.Protocol.Lens      as L-import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Types     hiding-                                                 (SemanticTokenAbsolute (..),-                                                  SemanticTokenRelative (..),-                                                  SemanticTokensEdit (..),-                                                  mkRange)-import           Language.LSP.Test-import           System.FilePath-import           System.IO.Extra                 hiding (withTempDir)--- import Test.QuickCheck.Instances ()-import           Control.Lens                    ((^.))-import           Development.IDE.Plugin.Test     (WaitForIdeRuleResult (..))-import           GHC.TypeLits                    (symbolVal)-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils---tests :: TestTree-tests = testGroup "cradle"-    [testGroup "dependencies" [sessionDepsArePickedUp]-    ,testGroup "ignore-fatal" [ignoreFatalWarning]-    ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle]-    ,testGroup "multi"   [simpleMultiTest, simpleMultiTest2, simpleMultiTest3, 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 SMethod_TextDocumentPublishDiagnostics))-            liftIO $ length msgs @?= 1-            changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ "module B where\nimport Data.Maybe"]-            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics))-            liftIO $ length msgs @?= 0-            _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"-            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics))-            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-  let aPath = dir </> "A.hs"-  doc <- createDoc aPath "haskell" "main = return ()"-  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-  sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $-         [FileEvent (filePathToUri $ dir </> "hie.yaml") FileChangeType_Changed ]--  WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc-  liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess---cradleLoadedMessage :: Session FromServerMessage-cradleLoadedMessage = satisfy $ \case-        FromServerMess (SMethod_CustomMethod p) (NotMess _) -> symbolVal p == cradleLoadedMethod-        _                                            -> False--cradleLoadedMethod :: String-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", [(DiagnosticSeverity_Warning,(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"-    adoc <- openDoc aPath "haskell"-    bdoc <- openDoc bPath "haskell"-    WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc-    liftIO $ assertBool "A should typecheck" ideResultSuccess-    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"-    bdoc <- openDoc bPath "haskell"-    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc-    TextDocumentIdentifier auri <- openDoc aPath "haskell"-    skipManyTill anyMessage $ isReferenceReady aPath-    locs <- getDefinitions bdoc (Position 2 7)-    let fooL = mkL auri 2 0 2 3-    checkDefs locs (pure [fooL])-    expectNoMoreDiagnostics 0.5---- Now with 3 components-simpleMultiTest3 :: TestTree-simpleMultiTest3 =-  testCase "simple-multi-test3" $ runWithExtraFiles "multi" $ \dir -> do-    let aPath = dir </> "a/A.hs"-        bPath = dir </> "b/B.hs"-        cPath = dir </> "c/C.hs"-    bdoc <- openDoc bPath "haskell"-    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc-    TextDocumentIdentifier auri <- openDoc aPath "haskell"-    skipManyTill anyMessage $ isReferenceReady aPath-    cdoc <- openDoc cPath "haskell"-    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc-    locs <- getDefinitions cdoc (Position 2 7)-    let fooL = mkL auri 2 0 2 3-    checkDefs locs (pure [fooL])-    expectNoMoreDiagnostics 0.5---- Like simpleMultiTest but open the files in component 'a' in a separate 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 $ isReferenceReady aPath-      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---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 $-        if ghcVersion >= GHC90-            -- String vs [Char] causes this change in error message-            then [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type")])]-            else [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match expected type")])]-    -- Update hie.yaml to enable OverloadedStrings.-    liftIO $-      writeFileUTF8-        (dir </> "hie.yaml")-        "cradle: {direct: {arguments: [-XOverloadedStrings]}}"-    sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $-        [FileEvent (filePathToUri $ dir </> "hie.yaml") FileChangeType_Changed ]-    -- Send change event.-    let change =-          TextDocumentContentChangeEvent $ InL $ #range .== 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\""-        ]
− test/exe/DependentFileTest.hs 
@@ -1,62 +0,0 @@--{-# LANGUAGE GADTs            #-}-{-# LANGUAGE OverloadedLabels #-}--module DependentFileTest (tests) where--import           Control.Monad.IO.Class         (liftIO)-import           Data.Row-import qualified Data.Text                      as T-import           Development.IDE.GHC.Compat     (GhcVersion (..), ghcVersion)-import           Development.IDE.Test           (expectDiagnostics)-import           Development.IDE.Types.Location-import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Types    hiding-                                                (SemanticTokenAbsolute (..),-                                                 SemanticTokenRelative (..),-                                                 SemanticTokensEdit (..),-                                                 mkRange)-import           Language.LSP.Test-import           System.FilePath-import           Test.Tasty-import           TestUtils--tests :: TestTree-tests = testGroup "addDependentFile"-    [testGroup "file-changed" [testSession' "test" test]-    ]-    where-      test dir = do-        -- If the file contains B then no type error-        -- otherwise type error-        let depFilePath = dir </> "dep-file.txt"-        liftIO $ writeFile depFilePath "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 $-            if ghcVersion >= GHC90-                -- String vs [Char] causes this change in error message-                then [("Foo.hs", [(DiagnosticSeverity_Error, if ghcVersion >= GHC92 then (4,11) else (4, 6), "Couldn't match type")])]-                else [("Foo.hs", [(DiagnosticSeverity_Error, (4, 6), "Couldn't match expected type")])]-        -- Now modify the dependent file-        liftIO $ writeFile depFilePath "B"-        sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $-            [FileEvent (filePathToUri "dep-file.txt") FileChangeType_Changed ]--        -- Modifying Baz will now trigger Foo to be rebuilt as well-        let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 2 0) (Position 2 6)-                                                         .+ #rangeLength .== Nothing-                                                         .+ #text .== "f = ()"-        changeDoc doc [change]-        expectDiagnostics [("Foo.hs", [])]
− test/exe/DiagnosticTests.hs 
@@ -1,565 +0,0 @@--{-# LANGUAGE GADTs            #-}-{-# LANGUAGE OverloadedLabels #-}--module DiagnosticTests (tests) where--import           Control.Applicative.Combinators-import qualified Control.Lens                    as Lens-import           Control.Monad-import           Control.Monad.IO.Class          (liftIO)-import           Data.List.Extra-import           Data.Row-import qualified Data.Text                       as T-import           Development.IDE.GHC.Compat      (GhcVersion (..), ghcVersion)-import           Development.IDE.GHC.Util-import           Development.IDE.Test            (diagnostic,-                                                  expectCurrentDiagnostics,-                                                  expectDiagnostics,-                                                  expectDiagnosticsWithTags,-                                                  expectNoMoreDiagnostics,-                                                  flushMessages, waitForAction)-import           Development.IDE.Types.Location-import qualified Language.LSP.Protocol.Lens      as L-import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Types     hiding-                                                 (SemanticTokenAbsolute (..),-                                                  SemanticTokenRelative (..),-                                                  SemanticTokensEdit (..),-                                                  mkRange)-import           Language.LSP.Test-import           System.Directory-import           System.FilePath-import           System.IO.Extra                 hiding (withTempDir)--- import Test.QuickCheck.Instances ()-import           Control.Lens                    ((^.))-import           Control.Monad.Extra             (whenJust)-import           Development.IDE.Plugin.Test     (WaitForIdeRuleResult (..))-import           System.Time.Extra-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils--tests :: TestTree-tests = testGroup "diagnostics"-  [ testSessionWait "fix syntax error" $ do-      let content = T.unlines [ "module Testing wher" ]-      doc <- createDoc "Testing.hs" "haskell" content-      expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error")])]-      let change = TextDocumentContentChangeEvent $ InL $ #range .== 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 SMethod_WindowWorkDoneProgressCreate)-      waitForProgressBegin-      let change = TextDocumentContentChangeEvent$ InL $ #range .== Range (Position 0 15) (Position 0 18)-                                                      .+ #rangeLength .== Nothing-                                                      .+ #text .== "wher"-      changeDoc doc [change]-      expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (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", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'missing'")])]-      let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 15) (Position 0 16)-                                                       .+ #rangeLength .== Nothing-                                                       .+ #text .== "l"-      changeDoc doc [change]-      expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (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"-          , [ (DiagnosticSeverity_Error, (2, 15), "Variable not in scope: ab")-            , (DiagnosticSeverity_Error, (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"-          , [(DiagnosticSeverity_Error, (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"-          , [(DiagnosticSeverity_Error, (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", [(DiagnosticSeverity_Error, (2,4), aMessage)])-          , ("B.hs", [(DiagnosticSeverity_Error, (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 $ InL $ #range .== Range (Position 0 0) (Position 0 20)-                                                       .+ #rangeLength .== Nothing-                                                       .+ #text .== ""-      changeDoc docA [change]-      expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Error, (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", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])]-      let contentA = T.unlines [ "module ModuleA where" ]-      _ <- createDoc "ModuleA.hs" "haskell" contentA-      expectDiagnostics [("ModuleB.hs", [])]-  , testCase "add missing module (non workspace)" $-    -- By default lsp-test sends FileWatched notifications for all files, which we don't want-    -- as non workspace modules will not be watched by the LSP server.-    -- To work around this, we tell lsp-test that our client doesn't have the-    -- FileWatched capability, which is enough to disable the notifications-    withTempDir $ \tmpDir -> runInDir'' lspTestCapsNoFileWatches tmpDir "." "." [] $ do-      let contentB = T.unlines-            [ "module ModuleB where"-            , "import ModuleA ()"-            ]-      _ <- createDoc (tmpDir </> "ModuleB.hs") "haskell" contentB-      expectDiagnostics [(tmpDir </> "ModuleB.hs", [(DiagnosticSeverity_Error, (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"-          , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]-          )-        , ( "ModuleB.hs"-          , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]-          )-        ]-  , testSession' "deeply nested cyclic module dependency" $ \path -> do-      let contentA = unlines-            [ "module ModuleA where" , "import ModuleB" ]-      let contentB = unlines-            [ "module ModuleB where" , "import ModuleA" ]-      let contentC = unlines-            [ "module ModuleC where" , "import ModuleB" ]-      let contentD = T.unlines-            [ "module ModuleD where" , "import ModuleC" ]-          cradle =-            "cradle: {direct: {arguments: [ModuleA, ModuleB, ModuleC, ModuleD]}}"-      liftIO $ writeFile (path </> "ModuleA.hs") contentA-      liftIO $ writeFile (path </> "ModuleB.hs") contentB-      liftIO $ writeFile (path </> "ModuleC.hs") contentC-      liftIO $ writeFile (path </> "hie.yaml") cradle-      _ <- createDoc "ModuleD.hs" "haskell" contentD-      expectDiagnostics-        [ ( "ModuleB.hs"-          , [(DiagnosticSeverity_Error, (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", [(DiagnosticSeverity_Warning, (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", [(DiagnosticSeverity_Warning, (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"-          , [(DiagnosticSeverity_Warning, (2, 0), "The import of 'ModuleA' is redundant", Just DiagnosticTag_Unnecessary)]-          )-        ]-  , 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", [(DiagnosticSeverity_Warning, (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"-            , "main = pure ()"-            ]-      _ <- createDoc "Data/List.hs" "haskell" thisDataListContent-      _ <- createDoc "Main.hs" "haskell" mainContent-      expectDiagnostics-        [ ( "Main.hs"-          , [(DiagnosticSeverity_Error, (6, 9),-                if ghcVersion >= GHC96 then-                  "Variable not in scope: ThisList.map"-                else if ghcVersion >= GHC94 then-                  "Variable not in scope: map" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130-                else-                  "Not in scope: \8216ThisList.map\8217")-            ,(DiagnosticSeverity_Error, (7, 9),-                if ghcVersion >= GHC96 then-                  "Variable not in scope: BaseList.x"-                else if ghcVersion >= GHC94 then-                  "Variable not in scope: x" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130-                else-                  "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-      -- something like 'GHC.Classes.Ord'. The choice of redundant-constraints to-      -- test this is fairly arbitrary.-          , [(DiagnosticSeverity_Warning, (2, if ghcVersion >= GHC94 then 7 else 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 SMethod_TextDocumentDidOpen (DidOpenTextDocumentParams itemA)-          TNotificationMessage{_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 :: T.Text = (head diags) ^. L.message-          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-      if ghcVersion >= GHC90 then-          -- Haddock parse errors are ignored on ghc-9.0-            pure ()-      else-        expectDiagnostics-            [ ( "Foo.hs"-              , [(DiagnosticSeverity_Warning, (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 =-            L.params .-            L.diagnostics .-            Lens.folded .-            L.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"-          , [(DiagnosticSeverity_Warning, (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"-          , [(DiagnosticSeverity_Warning, (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", [(DiagnosticSeverity_Warning,(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 . InR . (.==) #text $-                    T.unlines ["module B where", "y :: Bool", "y = undefined"]]-    expectDiagnostics-      [("A.hs", [(DiagnosticSeverity_Error, (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 . InR . (.==) #text $-                    T.unlines ["module A where", "import B", "x :: Bool", "x = y"]]--    expectDiagnostics-      [ ( "P.hs",-          [ (DiagnosticSeverity_Error, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"),-            (DiagnosticSeverity_Warning, (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", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'")])]--      changeDoc doc [TextDocumentContentChangeEvent  . InR . (.==) #text $ "module Foo() where" ]-      expectDiagnostics []--      changeDoc doc [TextDocumentContentChangeEvent  . InR . (.==) #text $ T.unlines-            [ "module Foo() where" , "import MissingModule" ] ]-      expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'")])]--  , testGroup "Cancellation"-    [ cancellationTestGroup "edit header" editHeader yesSession noParse  noTc-    , cancellationTestGroup "edit import" editImport noSession  yesParse noTc-    , cancellationTestGroup "edit body"   editBody   yesSession yesParse yesTc-    ]-  ]-  where-      editPair x y = let p = Position x y ; p' = Position x (y+2) in-        (TextDocumentContentChangeEvent $ InL $ #range .== Range p p-                                             .+ #rangeLength .== Nothing-                                             .+ #text .== "fd"-        ,TextDocumentContentChangeEvent $ InL $ #range .== Range p p'-                                             .+ #rangeLength .== Nothing-                                             .+ #text .== "")-      editHeader = editPair 0 0-      editImport = editPair 2 10-      editBody   = editPair 3 10--      noParse = False-      yesParse = True--      noSession = False-      yesSession = True--      noTc = False-      yesTc = True--cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> TestTree-cancellationTestGroup name edits 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 ("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 = [(DiagnosticSeverity_Warning, (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-        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-            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
− test/exe/ExceptionTests.hs 
@@ -1,155 +0,0 @@--module ExceptionTests (tests) where--import           Control.Exception                 (ArithException (DivideByZero),-                                                    throwIO)-import           Control.Lens-import           Control.Monad.Error.Class         (MonadError (throwError))-import           Control.Monad.IO.Class            (liftIO)-import qualified Data.Aeson                        as A-import           Data.Text                         as T-import           Development.IDE.Core.Shake        (IdeState (..))-import qualified Development.IDE.LSP.Notifications as Notifications-import qualified Development.IDE.Main              as IDE-import           Development.IDE.Plugin.HLS        (toResponseError)-import           Development.IDE.Plugin.Test       as Test-import           Development.IDE.Types.Options-import           GHC.Base                          (coerce)-import           Ide.Logger                        (Logger, Recorder,-                                                    WithPriority, cmapWithPrio)-import           Ide.Plugin.Error-import           Ide.PluginUtils                   (idePluginsToPluginDesc,-                                                    pluginDescToIdePlugins)-import           Ide.Types-import qualified Language.LSP.Protocol.Lens        as L-import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Types       hiding-                                                   (SemanticTokenAbsolute (..),-                                                    SemanticTokenRelative (..),-                                                    SemanticTokensEdit (..),-                                                    mkRange)-import           Language.LSP.Test-import           LogType                           (Log (..))-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils--tests :: Recorder (WithPriority Log) -> Logger -> TestTree-tests recorder logger = do-  testGroup "Exceptions and PluginError" [-    testGroup "Testing that IO Exceptions are caught in..."-      [ testCase "PluginHandlers" $ do-          let pluginId = "plugin-handler-exception"-              plugins = pluginDescToIdePlugins $-                  [ (defaultPluginDescriptor pluginId)-                      { pluginHandlers = mconcat-                          [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do-                              _ <- liftIO $ throwIO DivideByZero-                              pure (InL [])-                          ]-                      }]-          testIde recorder (testingLite recorder logger plugins) $ do-              doc <- createDoc "A.hs" "haskell" "module A where"-              waitForProgressDone-              (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)-              case lens of-                Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) ->-                  liftIO $ assertBool "We caught an error, but it wasn't ours!"-                          (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message)-                _ -> liftIO $ assertFailure $ show lens--        , testCase "Commands" $ do-          let pluginId = "command-exception"-              commandId = CommandId "exception"-              plugins = pluginDescToIdePlugins $-                  [ (defaultPluginDescriptor pluginId)-                      { pluginCommands =-                          [ PluginCommand commandId "Causes an exception" $ \_ (_::Int) -> do-                              _ <- liftIO $ throwIO DivideByZero-                              pure (InR Null)-                          ]-                      }]-          testIde recorder (testingLite recorder logger plugins) $ do-              _ <- createDoc "A.hs" "haskell" "module A where"-              waitForProgressDone-              let cmd = mkLspCommand (coerce pluginId) commandId "" (Just [A.toJSON (1::Int)])-                  execParams = ExecuteCommandParams Nothing (cmd ^. L.command) (cmd ^. L.arguments)-              (view L.result -> res) <- request SMethod_WorkspaceExecuteCommand execParams-              case res of-                Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) ->-                  liftIO $ assertBool "We caught an error, but it wasn't ours!"-                          (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message)-                _ -> liftIO $ assertFailure $ show res--        , testCase "Notification Handlers" $ do-          let pluginId = "notification-exception"-              plugins = pluginDescToIdePlugins $-                  [ (defaultPluginDescriptor pluginId)-                      { pluginNotificationHandlers = mconcat-                          [  mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ ->-                              liftIO $ throwIO DivideByZero-                          ]-                        , pluginHandlers = mconcat-                          [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do-                              pure (InL [])-                          ]-                      }]-          testIde recorder (testingLite recorder logger plugins) $ do-              doc <- createDoc "A.hs" "haskell" "module A where"-              waitForProgressDone-              (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)-              case lens of-                Right (InL []) ->-                  -- We don't get error responses from notification handlers, so-                  -- we can only make sure that the server is still responding-                  pure ()-                _ -> liftIO $ assertFailure $ "We should have had an empty list" <> show lens]--   , testGroup "Testing PluginError order..."-      [ pluginOrderTestCase recorder logger  "InternalError over InvalidParams" PluginInternalError PluginInvalidParams-      , pluginOrderTestCase recorder logger  "InvalidParams over InvalidUserState" PluginInvalidParams PluginInvalidUserState-      , pluginOrderTestCase recorder logger  "InvalidUserState over RequestRefused" PluginInvalidUserState PluginRequestRefused-      ]-   ]--testingLite :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> IDE.Arguments-testingLite recorder logger plugins =-  let-    arguments@IDE.Arguments{ argsIdeOptions } =-        IDE.defaultArguments (cmapWithPrio LogIDEMain recorder) logger plugins-    hlsPlugins = pluginDescToIdePlugins $-      idePluginsToPluginDesc plugins-      ++ [Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"]-      ++ [Test.blockCommandDescriptor "block-command", Test.plugin]-    ideOptions config sessionLoader =-      let-        defOptions = argsIdeOptions config sessionLoader-      in-        defOptions{ optTesting = IdeTesting True }-  in-    arguments-      { IDE.argsHlsPlugins = hlsPlugins-      , IDE.argsIdeOptions = ideOptions-      }--pluginOrderTestCase :: Recorder (WithPriority Log) -> Logger -> TestName -> (T.Text -> PluginError) -> (T.Text -> PluginError) -> TestTree-pluginOrderTestCase recorder logger msg err1 err2 =-  testCase msg $ do-      let pluginId = "error-order-test"-          plugins = pluginDescToIdePlugins $-              [ (defaultPluginDescriptor pluginId)-                  { pluginHandlers = mconcat-                      [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do-                          throwError $ err1 "error test"-                        ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do-                          throwError $ err2 "error test"-                      ]-                  }]-      testIde recorder (testingLite recorder logger plugins) $ do-          doc <- createDoc "A.hs" "haskell" "module A where"-          waitForProgressDone-          (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)-          case lens of-            Left re | toResponseError (pluginId, err1 "error test") == re -> pure ()-                    | otherwise -> liftIO $ assertFailure "We caught an error, but it wasn't ours!"-            _ -> liftIO $ assertFailure $ show lens
− test/exe/FindDefinitionAndHoverTests.hs 
@@ -1,249 +0,0 @@--{-# LANGUAGE MultiWayIf #-}--module FindDefinitionAndHoverTests (tests) where--import           Control.Monad-import           Control.Monad.IO.Class         (liftIO)-import           Data.Foldable-import           Data.Maybe-import qualified Data.Text                      as T-import           Development.IDE.GHC.Compat     (GhcVersion (..), ghcVersion)-import           Development.IDE.GHC.Util-import           Development.IDE.Test           (expectDiagnostics,-                                                 standardizeQuotes)-import           Development.IDE.Types.Location-import qualified Language.LSP.Protocol.Lens     as L-import           Language.LSP.Protocol.Types    hiding-                                                (SemanticTokenAbsolute (..),-                                                 SemanticTokenRelative (..),-                                                 SemanticTokensEdit (..),-                                                 mkRange)-import           Language.LSP.Test-import           System.FilePath-import           System.Info.Extra              (isWindows)--- import Test.QuickCheck.Instances ()-import           Control.Lens                   ((^.))-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils-import           Text.Regex.TDFA                ((=~))--tests :: TestTree-tests = let--  tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree-  tst (get, check) pos sfp 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 </> sfp)-    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 = (InL 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-            ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets-            ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool)-            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 (expectedRange ^. L.start) @=? 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)--  assertNotFoundIn :: T.Text -> T.Text -> Assertion-  assertNotFoundIn part whole = assertBool-    (T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole)-    (not . T.isInfixOf part $ 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", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _")])-          , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _")])-          ]-    , testGroup "type-definition" typeDefinitionTests-    , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ]--  typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 sourceFilePath (pure tcData) "Saturated data con"-                        , tst (getTypeDefinitions, checkDefs) aL20 sourceFilePath (pure [ExpectNoDefinitions]) "Polymorphic variable"]--  recordDotSyntaxTests-    | ghcVersion >= GHC92 =-        [ tst (getHover, checkHover) (Position 17 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent"-        , tst (getHover, checkHover) (Position 17 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child"-        , tst (getHover, checkHover) (Position 17 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child"-        ]-    | otherwise = []--  test runDef runHover look expect = testM runDef runHover look (return expect)--  testM runDef runHover look expect title =-    ( runDef   $ tst def   look sourceFilePath expect title-    , runHover $ tst hover look sourceFilePath expect title ) where-      def   = (getDefinitions, checkDefs)-      hover = (getHover      , checkHover)--  -- search locations            expectations on results-  fffL4  = fffR  ^. L.start;  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", "ghc-prim"]]-  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", "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", "base"]]-  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 [if ghcVersion >= GHC92 then ":: Type -> Type -> Type\n" else ":: * -> * -> *\n"]]-  intL40 = Position 44 34  ;  kindI  = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type\n" else ":: *\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 50 0 50 5]-  innL48 = Position 52  5  ;  innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]-  holeL60 = Position 62 7  ;  hleInfo = [ExpectHoverText ["_ ::"]]-  holeL65 = Position 65 8  ;  hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]]-  cccL17 = Position 17 16  ;  docLink = [ExpectHoverTextRegex "\\*Defined in 'GHC.Types'\\* \\*\\(ghc-prim-[0-9.]+\\)\\*\n\n"]-  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 (if ghcVersion >= GHC94 then 5 else 0) 3 (if ghcVersion >= GHC94 then 8 else 14)]-  thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]]-  cmtL68 = Position 67  0  ;  lackOfdEq = [ExpectHoverExcludeText ["$dEq"]]-  import310 = Position 3 10; pkgTxt = [ExpectHoverText ["Data.Text\n\ntext-"]]-  in-  mkFindTests-  --      def    hover  look       expect-  [-    if ghcVersion >= GHC90 then-        -- It suggests either going to the constructor or to the field-        test  broken yes    fffL4      fff           "field in record definition"-    else-        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"-  , test  yes    yes    spaceL37   space         "top-level fn on space           #1002"-  , 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  yes    yes    cmtL68     lackOfdEq     "no Core symbols                 #3280"-  , if ghcVersion >= GHC90 then-        test  no     yes    docL41     constr        "type constraint in hover info   #1012"-    else-        test  no     broken docL41     constr        "type constraint in hover info   #1012"-  , test  no     yes    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     yes    holeL65    hleInfo2      "hole with variable"-  , test  no     yes    cccL17     docLink       "Haddock html links"-  , testM yes    yes    imported   importedSig   "Imported symbol"-  , if | isWindows ->-        -- Flaky on Windows: https://github.com/haskell/haskell-language-server/issues/2997-        testM no     yes    reexported reexportedSig "Imported symbol (reexported)"-       | otherwise ->-        testM yes    yes    reexported reexportedSig "Imported symbol (reexported)"-  , if | ghcVersion == GHC90 && isWindows ->-        test  no     broken    thLocL57   thLoc         "TH Splice Hover"-       | otherwise ->-        test  no     yes       thLocL57   thLoc         "TH Splice Hover"-  , test yes yes import310 pkgTxt "show package name and its version"-  ]-  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
− test/exe/FuzzySearch.hs 
@@ -1,129 +0,0 @@-module FuzzySearch (tests) where--import           Data.Char                  (toLower)-import           Data.Maybe                 (catMaybes)-import qualified Data.Monoid.Textual        as T-import           Data.Text                  (Text, inits, pack)-import qualified Data.Text                  as Text-import           Prelude                    hiding (filter)-import           System.Directory           (doesFileExist)-import           System.IO.Unsafe           (unsafePerformIO)-import           Test.QuickCheck-import           Test.Tasty-import           Test.Tasty.ExpectedFailure-import           Test.Tasty.QuickCheck      (testProperty)-import qualified Text.Fuzzy                 as Fuzzy-import           Text.Fuzzy                 (Fuzzy (..))-import           Text.Fuzzy.Parallel--tests :: TestTree-tests =-  testGroup-    "Fuzzy search"-    [ needDictionary $-        testGroup-          "match works as expected on the english dictionary"-          [ testProperty "for legit words" propLegit,-            testProperty "for prefixes" propPrefix,-            testProperty "for typos" propTypo-          ]-    ]--test :: Text -> Bool-test candidate = do-  let previous =-        catMaybes-          [ (d,) . Fuzzy.score-              <$> referenceImplementation candidate d "" "" id-            | d <- dictionary-          ]-      new = catMaybes [(d,) <$> match candidate d | d <- dictionary]-  previous == new--propLegit :: Property-propLegit = forAll (elements dictionary) test--propPrefix :: Property-propPrefix = forAll (elements dictionary >>= elements . inits) test--propTypo :: Property-propTypo = forAll typoGen test--typoGen :: Gen Text-typoGen = do-  w <- elements dictionary-  l <- elements [0 .. Text.length w -1]-  let wl = Text.index w l-  c <- elements [ c | c <- ['a' .. 'z'], c /= wl]-  return $ replaceAt w l c--replaceAt :: Text -> Int -> Char -> Text-replaceAt t i c =-  let (l, r) = Text.splitAt i t-   in l <> Text.singleton c <> r--dictionaryPath :: FilePath-dictionaryPath = "/usr/share/dict/words"--{-# NOINLINE dictionary #-}-dictionary :: [Text]-dictionary = unsafePerformIO $ do-  existsDictionary <- doesFileExist dictionaryPath-  if existsDictionary-    then map pack . words <$> readFile dictionaryPath-    else pure []--referenceImplementation ::-  (T.TextualMonoid s) =>-  -- | Pattern in lowercase except for first character-  s ->-  -- | The value containing the text to search in.-  t ->-  -- | The text to add before each match.-  s ->-  -- | The text to add after each match.-  s ->-  -- | The function to extract the text from the container.-  (t -> s) ->-  -- | The original value, rendered string and score.-  Maybe (Fuzzy t s)-referenceImplementation pattern t pre post extract =-  if null pat then Just (Fuzzy t result totalScore) else Nothing-  where-    null :: (T.TextualMonoid s) => s -> Bool-    null = not . T.any (const True)--    s = extract t-    (totalScore, _currScore, result, pat, _) =-      T.foldl'-        undefined-        ( \(tot, cur, res, pat, isFirst) c ->-            case T.splitCharacterPrefix pat of-              Nothing -> (tot, 0, res <> T.singleton c, pat, isFirst)-              Just (x, xs) ->-                -- the case of the first character has to match-                -- otherwise use lower case since the pattern is assumed lower-                let !c' = if isFirst then c else toLower c-                 in if x == c'-                      then-                        let cur' = cur * 2 + 1-                         in ( tot + cur',-                              cur',-                              res <> pre <> T.singleton c <> post,-                              xs,-                              False-                            )-                      else (tot, 0, res <> T.singleton c, pat, isFirst)-        )-        ( 0,-          1, -- matching at the start gives a bonus (cur = 1)-          mempty,-          pattern,-          True-        )-        s--needDictionary :: TestTree -> TestTree-needDictionary-  | null dictionary = ignoreTestBecause ("not found: " <> dictionaryPath)-  | otherwise = id
− test/exe/GarbageCollectionTests.hs 
@@ -1,94 +0,0 @@--{-# LANGUAGE OverloadedLabels #-}--module GarbageCollectionTests (tests) where--import           Control.Monad.IO.Class      (liftIO)-import           Data.Row-import qualified Data.Set                    as Set-import qualified Data.Text                   as T-import           Development.IDE.Test        (expectCurrentDiagnostics,-                                              getStoredKeys, waitForGC,-                                              waitForTypecheck)-import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),-                                              SemanticTokenRelative (..),-                                              SemanticTokensEdit (..), mkRange)-import           Language.LSP.Test-import           System.FilePath--- import Test.QuickCheck.Instances ()-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils-import           Text.Printf                 (printf)--tests :: TestTree-tests = testGroup "garbage collection"-  [ testGroup "dirty keys"-        [ testSession' "are collected" $ \dir -> do-            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"-            doc <- generateGarbage "A" dir-            closeDoc doc-            garbage <- waitForGC-            liftIO $ assertBool "no garbage was found" $ not $ null garbage--        , testSession' "are deleted from the state" $ \dir -> do-            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"-            docA <- generateGarbage "A" dir-            keys0 <- getStoredKeys-            closeDoc docA-            garbage <- waitForGC-            liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage-            keys1 <- getStoredKeys-            liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0)--        , testSession' "are not regenerated unless needed" $ \dir -> do-            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}"-            docA <- generateGarbage "A" dir-            _docB <- generateGarbage "B" dir--            -- garbage collect A keys-            keysBeforeGC <- getStoredKeys-            closeDoc docA-            garbage <- waitForGC-            liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage-            keysAfterGC <- getStoredKeys-            liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state"-                (length keysAfterGC < length keysBeforeGC)--            -- re-typecheck B and check that the keys for A have not materialized back-            _docB <- generateGarbage "B" dir-            keysB <- getStoredKeys-            let regeneratedKeys = Set.filter (not . isExpected) $-                    Set.intersection (Set.fromList garbage) (Set.fromList keysB)-            liftIO $ regeneratedKeys @?= mempty--        , testSession' "regenerate successfully" $ \dir -> do-            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"-            docA <- generateGarbage "A" dir-            closeDoc docA-            garbage <- waitForGC-            liftIO $ assertBool "no garbage was found" $ not $ null garbage-            let edit = T.unlines-                        [ "module A where"-                        , "a :: Bool"-                        , "a = ()"-                        ]-            doc <- generateGarbage "A" dir-            changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ edit]-            builds <- waitForTypecheck doc-            liftIO $ assertBool "it still builds" builds-            expectCurrentDiagnostics doc [(DiagnosticSeverity_Error, (2,4), "Couldn't match expected type")]-        ]-  ]-  where-    isExpected k = any (`T.isPrefixOf` k) ["GhcSessionIO"]--    generateGarbage :: String -> FilePath -> Session TextDocumentIdentifier-    generateGarbage modName dir = do-        let fp = modName <> ".hs"-            body = printf "module %s where" modName-        doc <- createDoc fp "haskell" (T.pack body)-        liftIO $ writeFile (dir </> fp) body-        builds <- waitForTypecheck doc-        liftIO $ assertBool "something is wrong with this test" builds-        return doc
− test/exe/HaddockTests.hs 
@@ -1,90 +0,0 @@--module HaddockTests (tests) where--import           Development.IDE.Spans.Common--- import Test.QuickCheck.Instances ()-import           Test.Tasty-import           Test.Tasty.HUnit--tests :: TestTree-tests-  = 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."-             , ""-             ]-          )-      , testCase "ordered list" $ checkHaddock-          (unlines-             [ "may require"-             , "different precautions:"-             , ""-             , "  1. 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."-             , ""-             , "  2. Use the compiler flag @-fno-cse@ to prevent common sub-expression"-             , "        elimination being performed on the module."-             , ""-             ]-          )-          (unlines-             [ ""-             , ""-             , "may require"-             , "different precautions: "-             , "1. 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."-             , ""-             , "2. Use the compiler flag  `-fno-cse`  to prevent common sub-expression"-             , "  elimination being performed on the module."-             , ""-             ]-          )-      ]-  where-    checkHaddock s txt = spanDocToMarkdownForTest s @?= txt
− test/exe/HieDbRetry.hs 
@@ -1,137 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-module HieDbRetry (tests) where--import           Control.Concurrent.Extra (Var, modifyVar, newVar, readVar,-                                           withVar)-import           Control.Exception        (ErrorCall (ErrorCall), evaluate,-                                           throwIO, tryJust)-import           Control.Monad.IO.Class   (MonadIO (liftIO))-import           Data.Tuple.Extra         (dupe)-import qualified Database.SQLite.Simple   as SQLite-import           Development.IDE.Session  (retryOnException, retryOnSqliteBusy)-import qualified Development.IDE.Session  as Session-import           Ide.Logger               (Recorder (Recorder, logger_),-                                           WithPriority (WithPriority, payload),-                                           cmapWithPrio)-import qualified System.Random            as Random-import           Test.Tasty               (TestTree, testGroup)-import           Test.Tasty.HUnit         (assertFailure, testCase, (@?=))--data Log-  = LogSession Session.Log-  deriving Show--makeLogger :: Var [Log] -> Recorder (WithPriority Log)-makeLogger msgsVar =-  Recorder {-    logger_ = \WithPriority{ payload = msg } -> liftIO $ modifyVar msgsVar (\msgs -> pure (msg : msgs, ()))-  }--rng :: Random.StdGen-rng = Random.mkStdGen 0--retryOnSqliteBusyForTest :: Recorder (WithPriority Log) -> Int -> IO a -> IO a-retryOnSqliteBusyForTest recorder maxRetryCount = retryOnException isErrorBusy (cmapWithPrio LogSession recorder) 1 1 maxRetryCount rng--isErrorBusy :: SQLite.SQLError -> Maybe SQLite.SQLError-isErrorBusy e-  | SQLite.SQLError { sqlError = SQLite.ErrorBusy } <- e = Just e-  | otherwise = Nothing--errorBusy :: SQLite.SQLError-errorBusy = SQLite.SQLError{ sqlError = SQLite.ErrorBusy, sqlErrorDetails = "", sqlErrorContext = "" }--isErrorCall :: ErrorCall -> Maybe ErrorCall-isErrorCall e-  | ErrorCall _ <- e = Just e-  | otherwise = Nothing--tests :: TestTree-tests = testGroup "RetryHieDb"-  [ testCase "retryOnException throws exception after max retries" $ do-      logMsgsVar <- newVar []-      let logger = makeLogger logMsgsVar-      let maxRetryCount = 1--      result <- tryJust isErrorBusy (retryOnSqliteBusyForTest logger maxRetryCount (throwIO errorBusy))--      case result of-        Left exception -> do-          exception @?= errorBusy-          withVar logMsgsVar $ \logMsgs ->-            length logMsgs @?= 2-            -- uncomment if want to compare log msgs-            -- logMsgs @?= []-        Right _ -> assertFailure "Expected ErrorBusy exception"--   , testCase "retryOnException doesn't throw if given function doesn't throw" $ do-      let expected = 1 :: Int-      let maxRetryCount = 0--      actual <- retryOnSqliteBusyForTest mempty maxRetryCount (pure expected)--      actual @?= expected--   , testCase "retryOnException retries the number of times it should" $ do-      countVar <- newVar 0-      let maxRetryCount = 3-      let incrementThenThrow = modifyVar countVar (\count -> pure (dupe (count + 1))) >> throwIO errorBusy--      _ <- tryJust isErrorBusy (retryOnSqliteBusyForTest mempty maxRetryCount incrementThenThrow)--      withVar countVar $ \count ->-        count @?= maxRetryCount + 1--   , testCase "retryOnException doesn't retry if exception is not ErrorBusy" $ do-      countVar <- newVar (0 :: Int)-      let maxRetryCount = 1--      let throwThenIncrement = do-            count <- readVar countVar-            if count == 0 then-              evaluate (error "dummy exception")-            else-              modifyVar countVar (\count -> pure (dupe (count + 1)))---      _ <- tryJust isErrorCall (retryOnSqliteBusyForTest mempty maxRetryCount throwThenIncrement)--      withVar countVar $ \count ->-        count @?= 0--   , testCase "retryOnSqliteBusy retries on ErrorBusy" $ do-      countVar <- newVar (0 :: Int)--      let incrementThenThrowThenIncrement = do-            count <- readVar countVar-            if count == 0 then-              modifyVar countVar (\count -> pure (dupe (count + 1))) >> throwIO errorBusy-            else-              modifyVar countVar (\count -> pure (dupe (count + 1)))--      _ <- retryOnSqliteBusy mempty rng incrementThenThrowThenIncrement--      withVar countVar $ \count ->-        count @?= 2--    , testCase "retryOnException exponentially backs off" $ do-       logMsgsVar <- newVar ([] :: [Log])--       let maxDelay = 100-       let baseDelay = 1-       let maxRetryCount = 6-       let logger = makeLogger logMsgsVar--       result <- tryJust isErrorBusy (retryOnException isErrorBusy (cmapWithPrio LogSession logger) maxDelay baseDelay maxRetryCount rng (throwIO errorBusy))--       case result of-         Left _ -> do-           withVar logMsgsVar $ \logMsgs ->-             -- uses log messages to check backoff...-             if | (LogSession (Session.LogHieDbRetriesExhausted baseDelay maximumDelay maxRetryCount _) : _) <- logMsgs -> do-                  baseDelay @?= 64-                  maximumDelay @?= 100-                  maxRetryCount @?= 0-                | otherwise -> assertFailure "Expected more than 0 log messages"-         Right _ -> assertFailure "Expected ErrorBusy exception"-  ]
− test/exe/HighlightTests.hs 
@@ -1,79 +0,0 @@--module HighlightTests (tests) where--import           Control.Monad.IO.Class         (liftIO)-import qualified Data.Text                      as T-import           Development.IDE.GHC.Compat     (GhcVersion (..), ghcVersion)-import           Development.IDE.Types.Location-import           Language.LSP.Protocol.Types    hiding-                                                (SemanticTokenAbsolute (..),-                                                 SemanticTokenRelative (..),-                                                 SemanticTokensEdit (..),-                                                 mkRange)-import           Language.LSP.Test-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils--tests :: TestTree-tests = testGroup "highlight"-  [ testSessionWait "value" $ do-    doc <- createDoc "A.hs" "haskell" source-    _ <- waitForDiagnostics-    highlights <- getHighlights doc (Position 3 2)-    liftIO $ highlights @?=-            [ DocumentHighlight (R 2 0 2 3) (Just DocumentHighlightKind_Read)-            , DocumentHighlight (R 3 0 3 3) (Just DocumentHighlightKind_Write)-            , DocumentHighlight (R 4 6 4 9) (Just DocumentHighlightKind_Read)-            , DocumentHighlight (R 5 22 5 25) (Just DocumentHighlightKind_Read)-            ]-  , testSessionWait "type" $ do-    doc <- createDoc "A.hs" "haskell" source-    _ <- waitForDiagnostics-    highlights <- getHighlights doc (Position 2 8)-    liftIO $ highlights @?=-            [ DocumentHighlight (R 2 7 2 10) (Just DocumentHighlightKind_Read)-            , DocumentHighlight (R 3 11 3 14) (Just DocumentHighlightKind_Read)-            ]-  , testSessionWait "local" $ do-    doc <- createDoc "A.hs" "haskell" source-    _ <- waitForDiagnostics-    highlights <- getHighlights doc (Position 6 5)-    liftIO $ highlights @?=-            [ DocumentHighlight (R 6 4 6 7) (Just DocumentHighlightKind_Write)-            , DocumentHighlight (R 6 10 6 13) (Just DocumentHighlightKind_Read)-            , DocumentHighlight (R 7 12 7 15) (Just DocumentHighlightKind_Read)-            ]-  , knownBrokenForGhcVersions [GHC90, GHC92, GHC94, GHC96, GHC98] "Ghc9 highlights the constructor and not just this field" $-        testSessionWait "record" $ do-        doc <- createDoc "A.hs" "haskell" recsource-        _ <- waitForDiagnostics-        highlights <- getHighlights doc (Position 4 15)-        liftIO $ highlights @?=-          [ DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Write)-          , DocumentHighlight (R 4 14 4 20) (Just DocumentHighlightKind_Read)-          ]-        highlights <- getHighlights doc (Position 3 17)-        liftIO $ highlights @?=-          [ DocumentHighlight (R 3 17 3 23) (Just DocumentHighlightKind_Write)-          , DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Read)-          ]-  ]-  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"-      ]
− test/exe/IfaceTests.hs 
@@ -1,163 +0,0 @@--{-# LANGUAGE OverloadedLabels #-}--module IfaceTests (tests) where--import           Control.Monad.IO.Class        (liftIO)-import           Data.Row-import qualified Data.Text                     as T-import           Development.IDE.GHC.Util-import           Development.IDE.Test          (configureCheckProject,-                                                expectDiagnostics,-                                                expectNoMoreDiagnostics,-                                                getInterfaceFilesDir)-import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Types   hiding-                                               (SemanticTokenAbsolute (..),-                                                SemanticTokenRelative (..),-                                                SemanticTokensEdit (..),-                                                mkRange)-import           Language.LSP.Test-import           System.Directory-import           System.FilePath-import           System.IO.Extra               hiding (withTempDir)-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils--tests :: TestTree-tests = testGroup "Interface loading tests"-    [ -- https://github.com/haskell/ghcide/pull/645/-      ifaceErrorTest-    , ifaceErrorTest2-    , ifaceErrorTest3-    , ifaceTHTest-    ]----- | 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 propagates to C-    changeDoc cdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ cSource]-    expectDiagnostics-      [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")])-      ,("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")])]-    closeDoc cdoc--ifaceErrorTest :: TestTree-ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do-    configureCheckProject True-    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", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So what we know P has been loaded--    -- Change y from Int to B-    changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]-    -- save so that we can that the error propagates to A-    sendNotification SMethod_TextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing)---    -- Check that the error propagates to A-    expectDiagnostics-      [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])]--    -- Check that we wrote the interfaces for B when we saved-    hidir <- getInterfaceFilesDir bdoc-    hi_exists <- liftIO $ doesFileExist $ hidir </> "B.hi"-    liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists--    pdoc <- openDoc pPath "haskell"-    expectDiagnostics-      [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])-      ]-    changeDoc pdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ 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", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])-      ,("P.hs", [(DiagnosticSeverity_Warning,(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", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So that we know P has been loaded--    -- Change y from Int to B-    changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]--    -- Add a new definition to P-    changeDoc pdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ 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", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])-      ,("P.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding")])-      ,("P.hs", [(DiagnosticSeverity_Warning, (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 . InR . (.==) #text $ 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", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])-      ,("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])-      ]-    expectNoMoreDiagnostics 2
− test/exe/InitializeResponseTests.hs 
@@ -1,97 +0,0 @@--{-# LANGUAGE DataKinds        #-}-{-# LANGUAGE OverloadedLabels #-}--module InitializeResponseTests (tests) where--import           Control.Monad-import           Data.List.Extra-import           Data.Row-import qualified Data.Text                         as T-import           Development.IDE.Plugin.TypeLenses (typeLensCommandId)-import qualified Language.LSP.Protocol.Lens        as L-import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Types       hiding-                                                   (SemanticTokenAbsolute (..),-                                                    SemanticTokenRelative (..),-                                                    SemanticTokensEdit (..),-                                                    mkRange)-import           Language.LSP.Test--- import Test.QuickCheck.Instances ()-import           Control.Lens                      ((^.))-import           Development.IDE.Plugin.Test       (blockCommandId)-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils--tests :: TestTree-tests = 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 (TResponseMessage Method_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 True) Nothing)-    , 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 $ InL True)-    , chk "   code action"             _codeActionProvider  (Just $ InL False)-    , chk "   code lens"                 _codeLensProvider  (Just $ CodeLensOptions (Just False) (Just True))-    , 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"                   (^. L.colorProvider) (Just $ InL False)-    , chk "NO folding range"          _foldingRangeProvider (Just $ InL False)-    , che "   execute command"      _executeCommandProvider [typeLensCommandId, blockCommandId]-    , chk "   workspace"                   (^. L.workspace) (Just $ #workspaceFolders .== Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )}-                                                                 .+ #fileOperations   .== Nothing)-    , chk "NO experimental"             (^. L.experimental) Nothing-    ] where--      tds = Just (InL (TextDocumentSyncOptions-                              { _openClose = Just True-                              , _change    = Just TextDocumentSyncKind_Incremental-                              , _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 = commands} = getActual $ innerCaps ir-                    commandNames = (!! 2) . T.splitOn ":" <$> commands-                zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames)--  innerCaps :: TResponseMessage Method_Initialize -> ServerCapabilities-  innerCaps (TResponseMessage _ _ (Right (InitializeResult c _))) = c-  innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error"--  acquire :: IO (TResponseMessage Method_Initialize)-  acquire = run initializeResponse--  release :: TResponseMessage Method_Initialize -> IO ()-  release = const $ pure ()-
− test/exe/LogType.hs 
@@ -1,21 +0,0 @@-module LogType (Log(..)) where--import qualified Development.IDE.LSP.Notifications as Notifications-import qualified Development.IDE.Main              as IDE-import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide--import           Ide.Logger                        (Pretty (pretty))-import           Language.LSP.VFS                  (VfsLog)--data Log-  = LogGhcIde Ghcide.Log-  | LogIDEMain IDE.Log-  | LogVfs VfsLog-  | LogNotifications Notifications.Log--instance Pretty Log where-  pretty = \case-    LogGhcIde log  -> pretty log-    LogIDEMain log -> pretty log-    LogVfs log     -> pretty log-    LogNotifications log -> pretty log
− test/exe/Main.hs 
@@ -1,127 +0,0 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.--- SPDX-License-Identifier: Apache-2.0--{-- NOTE On enforcing determinism--   The tests below use two mechanisms to enforce deterministic LSP sequences:--    1. Progress reporting: waitForProgress(Begin|Done)-    2. Diagnostics: expectDiagnostics--    Either is fine, but diagnostics are generally more reliable.--    Mixing them both in the same test is NOT FINE as it will introduce race-    conditions since multiple interleavings are possible. In other words,-    the sequence of diagnostics and progress reports is not deterministic.-    For example:--    < do something >-    waitForProgressDone-    expectDiagnostics [...]--    - When the diagnostics arrive after the progress done message, as they usually do, the test will pass-    - When the diagnostics arrive before the progress done msg, when on a slow machine occasionally, the test will timeout--    Therefore, avoid mixing both progress reports and diagnostics in the same test- -}----module Main (main) where--- import Test.QuickCheck.Instances ()-import           Data.Function                            ((&))-import           Ide.Logger             (Logger (Logger),-                                                           LoggingColumn (DataColumn, PriorityColumn),-                                                           Pretty (pretty),-                                                           Priority (Debug),-                                                           Recorder (Recorder, logger_),-                                                           WithPriority (WithPriority, priority),-                                                           cfilter,-                                                           cmapWithPrio,-                                                           makeDefaultStderrRecorder)-import           GHC.Stack                                (emptyCallStack)-import qualified HieDbRetry-import           Test.Tasty-import           Test.Tasty.Ingredients.Rerun--import LogType ()-import OpenCloseTest-import InitializeResponseTests-import CompletionTests-import CPPTests-import DiagnosticTests-import CodeLensTests-import OutlineTests-import HighlightTests-import FindDefinitionAndHoverTests-import PluginSimpleTests-import PluginParsedResultTests-import PreprocessorTests-import THTests-import SymlinkTests-import SafeTests-import UnitTests-import HaddockTests-import PositionMappingTests-import WatchedFileTests-import CradleTests-import DependentFileTest-import NonLspCommandLine-import IfaceTests-import BootTests-import RootUriTests-import AsyncTests-import ClientSettingsTests-import ReferenceTests-import GarbageCollectionTests-import ExceptionTests--main :: IO ()-main = do-  docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn])--  let docWithFilteredPriorityRecorder@Recorder{ logger_ } =-        docWithPriorityRecorder-        & cfilter (\WithPriority{ priority } -> priority >= Debug)--  -- exists so old-style logging works. intended to be phased out-  let logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m))--  let recorder = docWithFilteredPriorityRecorder-               & cmapWithPrio pretty--  -- We mess with env vars so run single-threaded.-  defaultMainWithRerun $ testGroup "ghcide"-    [ OpenCloseTest.tests-    , InitializeResponseTests.tests-    , CompletionTests.tests-    , CPPTests.tests-    , DiagnosticTests.tests-    , CodeLensTests.tests-    , OutlineTests.tests-    , HighlightTests.tests-    , FindDefinitionAndHoverTests.tests-    , PluginSimpleTests.tests-    , PluginParsedResultTests.tests-    , PreprocessorTests.tests-    , THTests.tests-    , SymlinkTests.tests-    , SafeTests.tests-    , UnitTests.tests recorder logger-    , HaddockTests.tests-    , PositionMappingTests.tests-    , WatchedFileTests.tests-    , CradleTests.tests-    , DependentFileTest.tests-    , NonLspCommandLine.tests-    , IfaceTests.tests-    , BootTests.tests-    , RootUriTests.tests-    , AsyncTests.tests-    , ClientSettingsTests.tests-    , ReferenceTests.tests-    , GarbageCollectionTests.tests-    , HieDbRetry.tests-    , ExceptionTests.tests recorder logger-    ]
− test/exe/NonLspCommandLine.hs 
@@ -1,27 +0,0 @@--module NonLspCommandLine (tests) where--import           Development.IDE.Test.Runfiles-import           System.Environment.Blank      (setEnv)-import           System.Exit                   (ExitCode (ExitSuccess))-import           System.Process.Extra          (CreateProcess (cwd), proc,-                                                readCreateProcessWithExitCode)-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils----- A test to ensure that the command line ghcide workflow stays working-tests :: TestTree-tests = 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-  ]
− test/exe/OpenCloseTest.hs 
@@ -1,18 +0,0 @@--module OpenCloseTest (tests) where--import           Control.Applicative.Combinators-import           Control.Monad-import           Language.LSP.Protocol.Message-import           Language.LSP.Test--- import Test.QuickCheck.Instances ()-import           Test.Tasty-import           TestUtils--tests :: TestTree-tests = testSession "open close" $ do-    doc <- createDoc "Testing.hs" "haskell" ""-    void (skipManyTill anyMessage $ message SMethod_WindowWorkDoneProgressCreate)-    waitForProgressBegin-    closeDoc doc-    waitForProgressDone
− test/exe/OutlineTests.hs 
@@ -1,189 +0,0 @@--module OutlineTests (tests) where--import           Control.Monad.IO.Class      (liftIO)-import qualified Data.Text                   as T-import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),-                                              SemanticTokenRelative (..),-                                              SemanticTokensEdit (..), mkRange)-import           Language.LSP.Test-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils--tests :: TestTree-tests = 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 @?= Right-      [ moduleSymbol-          "A"-          (R 0 7 0 8)-          [ classSymbol "A a"-                        (R 1 0 1 30)-                        [docSymbol' "a" SymbolKind_Method (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 @?= Right-      [ classSymbol "A a" (R 0 0 0 15) []-      , docSymbol "A ()" SymbolKind_Interface (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 @?= Right [docSymbolD "A" "type family" SymbolKind_Function (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 @?= Right-      [ docSymbolD "A a"   "type family" SymbolKind_Function     (R 1 0 1 15)-      , docSymbol "A ()" SymbolKind_Interface (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 @?= Right [docSymbolD "A" "data family" SymbolKind_Function (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 @?= Right-      [ docSymbolD "A a"   "data family" SymbolKind_Function     (R 1 0 1 11)-      , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25)-      ]-  , testSessionWait "constant" $ do-    let source = T.unlines ["a = ()"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [docSymbol "a" SymbolKind_Function (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 @?= Right-      [docSymbol "Just foo" SymbolKind_Function (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 @?= Right-      [docSymbol "a :: ()" SymbolKind_Function (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 @?= Right [docSymbol "a" SymbolKind_Function (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 @?= Right-      [docSymbol' "A" SymbolKind_TypeParameter (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 @?= Right-      [ docSymbolWithChildren "A"-                              SymbolKind_Struct-                              (R 0 0 0 10)-                              [docSymbol "C" SymbolKind_Constructor (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 @?= Right-      [ docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 2 13)-          [ docSymbolWithChildren' "B" SymbolKind_Constructor (R 0 9 2 13) (R 0 9 0 10)-            [ docSymbol "x" SymbolKind_Field (R 1 2 1 3)-            , docSymbol "y" SymbolKind_Field (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 @?= Right-      [docSymbolWithChildren "imports"-                             SymbolKind_Module-                             (R 0 0 0 20)-                             [ docSymbol "import Data.Maybe" SymbolKind_Module (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 @?= Right-      [docSymbolWithChildren "imports"-                             SymbolKind_Module-                             (R 1 0 3 27)-                             [ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20)-                             , docSymbol "import Control.Exception" SymbolKind_Module (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 @?= Right [docSymbolD "a" "import" SymbolKind_Object (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 @?= Right [docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)]-  ]- where-  docSymbol name kind loc =-    DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing-  docSymbol' name kind loc selectionLoc =-    DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing-  docSymbolD name detail kind loc =-    DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing-  docSymbolWithChildren name kind loc cc =-    DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just cc)-  docSymbolWithChildren' name kind loc selectionLoc cc =-    DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just cc)-  moduleSymbol name loc cc = DocumentSymbol name-                                            Nothing-                                            SymbolKind_File-                                            Nothing-                                            Nothing-                                            (R 0 0 maxBound 0)-                                            loc-                                            (Just cc)-  classSymbol name loc cc = DocumentSymbol name-                                           (Just "class")-                                           SymbolKind_Interface-                                           Nothing-                                           Nothing-                                           loc-                                           loc-                                           (Just cc)
− test/exe/PluginParsedResultTests.hs 
@@ -1,16 +0,0 @@--module PluginParsedResultTests (tests) where--import           Development.IDE.Test (expectNoMoreDiagnostics)-import           Language.LSP.Test-import           System.FilePath--- import Test.QuickCheck.Instances ()-import           Test.Tasty-import           TestUtils--tests :: TestTree-tests =-  ignoreForGHC92Plus "No need for this plugin anymore!" $-  testSessionWithExtraFiles "plugin-recorddot" "parsedResultAction plugin" $ \dir -> do-    _ <- openDoc (dir</> "RecordDot.hs") "haskell"-    expectNoMoreDiagnostics 2
− test/exe/PluginSimpleTests.hs 
@@ -1,50 +0,0 @@--module PluginSimpleTests (tests) where--import           Control.Monad.IO.Class      (liftIO)-import           Development.IDE.GHC.Compat  (GhcVersion (..))-import           Development.IDE.Test        (expectDiagnostics)-import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),-                                              SemanticTokenRelative (..),-                                              SemanticTokensEdit (..), mkRange)-import           Language.LSP.Test-import           System.FilePath--- import Test.QuickCheck.Instances ()-import           Test.Tasty-import           TestUtils--tests :: TestTree-tests =-  -- Build profile: -w ghc-9.4.2 -O1-  -- In order, the following will be built (use -v for more details):-  -- - ghc-typelits-natnormalise-0.7.7 (lib) (requires build)-  -- - ghc-typelits-knownnat-0.7.7 (lib) (requires build)-  -- - plugin-1.0.0 (lib) (first run)-  -- Starting     ghc-typelits-natnormalise-0.7.7 (lib)-  -- Building     ghc-typelits-natnormalise-0.7.7 (lib)--  -- Failed to build ghc-typelits-natnormalise-0.7.7.-  -- Build log (-  -- C:\cabal\logs\ghc-9.4.2\ghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.log-  -- ):-  -- Preprocessing library for ghc-typelits-natnormalise-0.7.7..-  -- Building library for ghc-typelits-natnormalise-0.7.7..-  -- [1 of 3] Compiling GHC.TypeLits.Normalise.SOP ( src\GHC\TypeLits\Normalise\SOP.hs, dist\build\GHC\TypeLits\Normalise\SOP.o )-  -- [2 of 3] Compiling GHC.TypeLits.Normalise.Unify ( src\GHC\TypeLits\Normalise\Unify.hs, dist\build\GHC\TypeLits\Normalise\Unify.o )-  -- [3 of 3] Compiling GHC.TypeLits.Normalise ( src-ghc-9.4\GHC\TypeLits\Normalise.hs, dist\build\GHC\TypeLits\Normalise.o )-  -- C:\tools\ghc-9.4.2\lib\../mingw/bin/llvm-ar.exe: error: dist\build\objs-5156\libHSghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.a: No such file or directory--  -- Error: cabal: Failed to build ghc-typelits-natnormalise-0.7.7 (which is-  -- required by plugin-1.0.0). See the build log above for details.-  ignoreFor (BrokenForGHC [GHC96, GHC98]) "fragile, frequently times out" $-  ignoreFor (BrokenSpecific Windows [GHC94]) "ghc-typelist-natnormalise fails to build on GHC 9.4.2 for windows only" $-  testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do-    _ <- openDoc (dir </> "KnownNat.hs") "haskell"-    liftIO $ writeFile (dir</>"hie.yaml")-      "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}"--    expectDiagnostics-      [ ( "KnownNat.hs",-          [(DiagnosticSeverity_Error, (9, 15), "Variable not in scope: c")]-          )-      ]
− test/exe/PositionMappingTests.hs 
@@ -1,199 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE OverloadedLabels    #-}--module PositionMappingTests (tests) where--import           Data.Row-import qualified Data.Text                            as T-import           Data.Text.Utf16.Rope                 (Rope)-import qualified Data.Text.Utf16.Rope                 as Rope-import           Development.IDE.Core.PositionMapping (PositionResult (..),-                                                       fromCurrent,-                                                       positionResultToMaybe,-                                                       toCurrent)-import           Development.IDE.Types.Location-import           Language.LSP.Protocol.Types          hiding-                                                      (SemanticTokenAbsolute (..),-                                                       SemanticTokenRelative (..),-                                                       SemanticTokensEdit (..),-                                                       mkRange)-import           Language.LSP.VFS                     (applyChange)-import           Test.QuickCheck--- import Test.QuickCheck.Instances ()-import           Data.Functor.Identity                (runIdentity)-import           Test.Tasty-import           Test.Tasty.HUnit-import           Test.Tasty.QuickCheck--tests ::  TestTree-tests =-    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 = runIdentity $ applyChange mempty rope-                                (TextDocumentContentChangeEvent $ InL $ #range .== range-                                                                     .+ #rangeLength .== Nothing-                                                                     .+ #text .== 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-    let rows :: Int = fromIntegral $ Rope.lengthInLines r-    row <- choose (0, max 0 $ rows - 1) `suchThat` inBounds @UInt-    let columns = T.length (nthLine (fromIntegral row) r)-    column <- choose (0, max 0 $ columns - 1) `suchThat` inBounds @UInt-    pure $ Position (fromIntegral row) (fromIntegral column)--genRange :: Rope -> Gen Range-genRange r = do-    let rows :: Int = fromIntegral $ Rope.lengthInLines r-    startPos@(Position startLine startColumn) <- genPosition r-    let maxLineDiff = max 0 $ rows - 1 - fromIntegral startLine-    endLine <- choose (fromIntegral startLine, fromIntegral startLine + maxLineDiff) `suchThat` inBounds @UInt-    let columns = T.length (nthLine (fromIntegral endLine) r)-    endColumn <--        if fromIntegral startLine == endLine-            then choose (fromIntegral startColumn, columns)-            else choose (0, max 0 $ columns - 1)-        `suchThat` inBounds @UInt-    pure $ Range startPos (Position (fromIntegral endLine) (fromIntegral endColumn))--inBounds :: forall b a . (Integral a, Integral b, Bounded b) => a -> Bool-inBounds a = let i = toInteger a in i <= toInteger (maxBound @b) && i >= toInteger (minBound @b)---- | Get the ith line of a rope, starting from 0. Trailing newline not included.-nthLine :: Int -> Rope -> T.Text-nthLine i r-    | Rope.null r = ""-    | otherwise = Rope.lines r !! i
− test/exe/PreprocessorTests.hs 
@@ -1,27 +0,0 @@--module PreprocessorTests (tests) where--import qualified Data.Text                   as T-import           Development.IDE.Test        (expectDiagnostics)-import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),-                                              SemanticTokenRelative (..),-                                              SemanticTokensEdit (..), mkRange)-import           Language.LSP.Test--- import Test.QuickCheck.Instances ()-import           Test.Tasty-import           TestUtils--tests :: TestTree-tests = 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",-        [(DiagnosticSeverity_Error, (2, 8), "Variable not in scope: z")]-      )-    ]
− test/exe/Progress.hs 
@@ -1,60 +0,0 @@-{-# LANGUAGE PackageImports #-}-module Progress (tests) where--import           Control.Concurrent.STM-import           Data.Foldable                          (for_)-import qualified Data.HashMap.Strict                    as Map-import           Development.IDE                        (NormalizedFilePath)-import           Development.IDE.Core.ProgressReporting-import qualified "list-t" ListT-import qualified StmContainers.Map                      as STM-import           Test.Tasty-import           Test.Tasty.HUnit--tests :: TestTree-tests = testGroup "Progress"-    [ reportProgressTests-    ]--data InProgressModel = InProgressModel {-    done, todo :: Int,-    current    :: Map.HashMap NormalizedFilePath Int-}--reportProgressTests :: TestTree-reportProgressTests = testGroup "recordProgress"-    [ test "addNew"   addNew-    , test "increase" increase-    , test "decrease" decrease-    , test "done" done-    ]-    where-        p0 = pure $ InProgressModel 0 0 mempty-        addNew = recordProgressModel "A" succ p0-        increase = recordProgressModel "A" succ addNew-        decrease = recordProgressModel "A" succ increase-        done = recordProgressModel "A" pred decrease-        recordProgressModel key change state =-            model state $ \st -> recordProgress st key change-        model stateModelIO k = do-            state <- fromModel =<< stateModelIO-            k state-            toModel state-        test name p = testCase name $ do-            InProgressModel{..} <- p-            (done, todo) @?= (length (filter (==0) (Map.elems current)), Map.size current)--fromModel :: InProgressModel -> IO InProgressState-fromModel InProgressModel{..} = do-    doneVar <- newTVarIO done-    todoVar <- newTVarIO todo-    currentVar <- STM.newIO-    atomically $ for_ (Map.toList current) $ \(k,v) -> STM.insert v k currentVar-    return InProgressState{..}--toModel :: InProgressState -> IO InProgressModel-toModel InProgressState{..} = atomically $ do-    done <- readTVar doneVar-    todo <- readTVar todoVar-    current <- Map.fromList <$> ListT.toList (STM.listT currentVar)-    return InProgressModel{..}
− test/exe/ReferenceTests.hs 
@@ -1,199 +0,0 @@--module ReferenceTests (tests) where--import           Control.Applicative.Combinators-import qualified Control.Lens                    as Lens-import           Control.Monad-import           Control.Monad.IO.Class          (liftIO)-import           Data.List.Extra-import qualified Data.Set                        as Set-import           Development.IDE.Test            (configureCheckProject,-                                                  referenceReady)-import           Development.IDE.Types.Location-import qualified Language.LSP.Protocol.Lens      as L-import           Language.LSP.Protocol.Types     hiding-                                                 (SemanticTokenAbsolute (..),-                                                  SemanticTokenRelative (..),-                                                  SemanticTokensEdit (..),-                                                  mkRange)-import           Language.LSP.Test-import           System.Directory-import           System.FilePath--- import Test.QuickCheck.Instances ()-import           Control.Lens                    ((^.))-import           Data.Tuple.Extra-import           Test.Tasty-import           Test.Tasty.ExpectedFailure-import           Test.Tasty.HUnit-import           TestUtils---tests :: TestTree-tests = 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 ([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-  -- needed to build whole project indexing-  configureCheckProject True-  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 $ referenceReady (`elem` docs)-      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-        actual <- getReferences' loc includeDeclaration-        liftIO $ actual `expectSameLocations` map (first3 (dir </>)) expected-  where-    docs = map fst3 expected--type SymbolLocation = (FilePath, UInt, UInt)--expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion-expectSameLocations actual expected = do-    let actual' =-            Set.map (\location -> (location ^. L.uri-                                   , location ^. L.range . L.start . L.line . Lens.to fromIntegral-                                   , location ^. L.range . L.start . L.character . Lens.to fromIntegral))-            $ Set.fromList actual-    expected' <- Set.fromList <$>-        (forM expected $ \(file, l, c) -> do-                              fp <- canonicalizePath file-                              return (filePathToUri fp, l, c))-    actual' @?= expected'
− test/exe/RootUriTests.hs 
@@ -1,26 +0,0 @@--module RootUriTests (tests) where--import           Control.Monad.IO.Class   (liftIO)-import           Development.IDE.GHC.Util-import           Development.IDE.Test     (expectNoMoreDiagnostics)-import           Language.LSP.Test-import           System.FilePath--- import Test.QuickCheck.Instances ()-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils----- | checks if we use InitializeParams.rootUri for loading session-tests :: TestTree-tests = 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/exe/SafeTests.hs 
@@ -1,38 +0,0 @@--module SafeTests (tests) where--import qualified Data.Text            as T-import           Development.IDE.Test (expectNoMoreDiagnostics)-import           Language.LSP.Test--import           Test.Tasty-import           TestUtils--tests :: TestTree-tests =-  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 ]
− test/exe/SymlinkTests.hs 
@@ -1,27 +0,0 @@--module SymlinkTests (tests) where--import           Control.Monad.IO.Class      (liftIO)-import           Development.IDE.Test        (expectDiagnosticsWithTags)-import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),-                                              SemanticTokenRelative (..),-                                              SemanticTokensEdit (..), mkRange)-import           Language.LSP.Test-import           System.Directory-import           System.FilePath--import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils---- | Tests for projects that use symbolic links one way or another-tests :: TestTree-tests =-  testGroup "Projects using Symlinks"-    [ testCase "Module is symlinked" $ runWithExtraFiles "symlink" $ \dir -> do-        liftIO $ createFileLink (dir </> "some_loc" </> "Sym.hs") (dir </> "other_loc" </> "Sym.hs")-        let fooPath = dir </> "src" </> "Foo.hs"-        _ <- openDoc fooPath "haskell"-        expectDiagnosticsWithTags  [("src" </> "Foo.hs", [(DiagnosticSeverity_Warning, (2, 0), "The import of 'Sym' is redundant", Just DiagnosticTag_Unnecessary)])]-        pure ()-    ]
− test/exe/THTests.hs 
@@ -1,203 +0,0 @@--{-# LANGUAGE OverloadedLabels #-}--module THTests (tests) where--import           Control.Monad.IO.Class      (liftIO)-import           Data.Row-import qualified Data.Text                   as T-import           Development.IDE.GHC.Util-import           Development.IDE.GHC.Compat-import           Development.IDE.Test        (expectCurrentDiagnostics,-                                              expectDiagnostics,-                                              expectNoMoreDiagnostics)-import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),-                                              SemanticTokenRelative (..),-                                              SemanticTokensEdit (..), mkRange)-import           Language.LSP.Test-import           System.FilePath-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils--tests :: TestTree-tests =-  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", [(DiagnosticSeverity_Error, (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-    , thLoadingTest-    , thCoreTest-    , ignoreFor (BrokenForGHC [GHC92]) "ghc 9.2 doesn't support -working-dir" thWorkingDirTest-    , 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"-                , "import Language.Haskell.TH (ExpQ)"-                , "a :: ExpQ" -- TH 2.17 requires an explicit type signature since splices are polymorphic-                , "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", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ]-    , 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, [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ]-    ]----- | Test that all modules have linkables-thWorkingDirTest :: TestTree-thWorkingDirTest = testCase "working dir is set" $ runWithExtraFiles "working-dir" $ \dir -> do-    let thb = dir </> "a" </> "B.hs"-    _ <- openDoc thb "haskell"-    expectDiagnostics [("a" </> "B.hs", [(DiagnosticSeverity_Warning, (5,thDollarIdx), "Top-level binding")])]---- | Test that all modules have linkables-thLoadingTest :: TestTree-thLoadingTest = testCase "Loading linkables" $ runWithExtraFiles "THLoading" $ \dir -> do-    let thb = dir </> "THB.hs"-    _ <- openDoc thb "haskell"-    expectNoMoreDiagnostics 1--thCoreTest :: TestTree-thCoreTest = testCase "Verifying TH core files" $ runWithExtraFiles "THCoreFile" $ \dir -> do-    let thc = dir </> "THC.hs"-    _ <- openDoc thc "haskell"-    expectNoMoreDiagnostics 1---- | 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", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")])]--    -- Change th from () to Bool-    let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"]-    changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ aSource']-    -- generate an artificial warning to avoid timing out if the TH change does not propagate-    changeDoc cdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ cSource <> "\nfoo=()"]--    -- Check that the change propagates to C-    expectDiagnostics-        [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")])-        ,("THC.hs", [(DiagnosticSeverity_Warning, (6,0), "Top-level binding")])-        ,("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level bindin")])-        ]--    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", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")])]--    let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"]-    changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ aSource']--    -- modify b too-    let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"]-    changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ bSource']-    waitForProgressBegin-    waitForAllProgressDone--    expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")]--    closeDoc adoc-    closeDoc bdoc-  where-    name = "th-linking-test" <> if unboxed then "-unboxed" else ""-    dir | unboxed = "THUnboxed"-        | otherwise = "TH"
− test/exe/TestUtils.hs 
@@ -1,328 +0,0 @@--{-# LANGUAGE GADTs           #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE TypeOperators   #-}--module TestUtils where--import           Control.Applicative.Combinators-import           Control.Concurrent.Async-import           Control.Exception               (bracket_, finally, throw)-import           Control.Lens                    ((.~), (^.))-import qualified Control.Lens                    as Lens-import qualified Control.Lens.Extras             as Lens-import           Control.Monad-import           Control.Monad.IO.Class          (liftIO)-import           Data.Foldable-import           Data.Function                   ((&))-import           Data.Maybe-import qualified Data.Text                       as T-import           Development.IDE.GHC.Compat      (GhcVersion (..), ghcVersion)-import           Development.IDE.GHC.Util-import qualified Development.IDE.Main            as IDE-import           Development.IDE.Test            (canonicalizeUri,-                                                  configureCheckProject,-                                                  expectNoMoreDiagnostics)-import           Development.IDE.Test.Runfiles-import           Development.IDE.Types.Location-import           Development.Shake               (getDirectoryFilesIO)-import           Ide.Logger                      (Recorder, WithPriority,-                                                  cmapWithPrio)-import qualified Language.LSP.Protocol.Lens      as L-import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Types     hiding-                                                 (SemanticTokenAbsolute (..),-                                                  SemanticTokenRelative (..),-                                                  SemanticTokensEdit (..),-                                                  mkRange)-import           Language.LSP.Test-import           System.Directory-import           System.Environment.Blank        (getEnv, setEnv, unsetEnv)-import           System.FilePath-import           System.Info.Extra               (isMac, isWindows)-import qualified System.IO.Extra-import           System.Process.Extra            (createPipe)-import           Test.Tasty-import           Test.Tasty.ExpectedFailure-import           Test.Tasty.HUnit--import           LogType--import           Data.Traversable                (for)---- | Wait for the next progress begin step-waitForProgressBegin :: Session ()-waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case-  FromServerMess  SMethod_Progress  (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressBegin v-> Just ()-  _ -> Nothing---- | Wait for the first progress end step--- Also implemented in hls-test-utils Test.Hls-waitForProgressDone :: Session ()-waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case-  FromServerMess  SMethod_Progress  (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressEnd v -> Just ()-  _ -> Nothing---- | Wait for all progress to be done--- Needs at least one progress done notification to return--- Also implemented in hls-test-utils Test.Hls-waitForAllProgressDone :: Session ()-waitForAllProgressDone = loop-  where-    loop = do-      ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case-        FromServerMess  SMethod_Progress  (TNotificationMessage _ _ (ProgressParams _ v)) |Lens.is _workDoneProgressEnd v-> Just ()-        _ -> Nothing-      done <- null <$> getIncompleteProgressSessions-      unless done loop--run :: Session a -> IO a-run s = run' (const s)--run' :: (FilePath -> Session a) -> IO a-run' s = withTempDir $ \dir -> runInDir dir (s dir)--runInDir :: FilePath -> Session a -> IO a-runInDir dir = runInDir' dir "." "." []---- | 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' = runInDir'' lspTestCaps--runInDir''-    :: ClientCapabilities-    -> FilePath-    -> FilePath-    -> FilePath-    -> [String]-    -> Session b-    -> IO b-runInDir'' lspCaps dir startExeIn startSessionIn extraOptions s = do--  ghcideExe <- locateGhcideExecutable-  let startDir = dir </> startExeIn-  let projDir = dir </> startSessionIn--  createDirectoryIfMissing True startDir-  createDirectoryIfMissing True projDir-  -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56-  -- since the package import test creates "Data/List.hs", which otherwise has no physical home-  createDirectoryIfMissing True $ projDir ++ "/Data"--  shakeProfiling <- getEnv "SHAKE_PROFILING"-  let cmd = unwords $-       [ghcideExe, "--lsp", "--test", "--verify-core-file", "--verbose", "-j2", "--cwd", startDir-       ] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling]-       ] ++ extraOptions-  -- HIE calls getXgdDirectory which assumes that HOME is set.-  -- Only sets HOME if it wasn't already set.-  setEnv "HOME" "/homeless-shelter" False-  conf <- getConfigFromEnv-  runSessionWithConfig conf cmd lspCaps projDir $ do-      configureCheckProject False-      s---- | 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'--lspTestCaps :: ClientCapabilities-lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing }--getConfigFromEnv :: IO SessionConfig-getConfigFromEnv = do-  logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR"-  timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT"-  return defaultConfig-    { messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride-    , logColor-    }-  where-    checkEnv :: String -> IO (Maybe Bool)-    checkEnv s = fmap convertVal <$> getEnv s-    convertVal "0" = False-    convertVal _   = True--testSessionWait :: HasCallStack => 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)--testSession :: String -> Session () -> TestTree-testSession name = testCase name . run--xfail :: TestTree -> String -> TestTree-xfail = flip expectFailBecause--ignoreInWindowsBecause :: String -> TestTree -> TestTree-ignoreInWindowsBecause = ignoreFor (BrokenForOS Windows)--ignoreForGHC92Plus :: String -> TestTree -> TestTree-ignoreForGHC92Plus = ignoreFor (BrokenForGHC [GHC92, GHC94, GHC96, GHC98])--knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree-knownBrokenForGhcVersions ghcVers = knownBrokenFor (BrokenForGHC ghcVers)--data BrokenOS = Linux | MacOS | Windows deriving (Show)--data IssueSolution = Broken | Ignore deriving (Show)--data BrokenTarget =-    BrokenSpecific BrokenOS [GhcVersion]-    -- ^Broken for `BrokenOS` with `GhcVersion`-    | BrokenForOS BrokenOS-    -- ^Broken for `BrokenOS`-    | BrokenForGHC [GhcVersion]-    -- ^Broken for `GhcVersion`-    deriving (Show)---- | Ignore test for specific os and ghc with reason.-ignoreFor :: BrokenTarget -> String -> TestTree -> TestTree-ignoreFor = knownIssueFor Ignore---- | Known broken for specific os and ghc with reason.-knownBrokenFor :: BrokenTarget -> String -> TestTree -> TestTree-knownBrokenFor = knownIssueFor Broken---- | Deal with `IssueSolution` for specific OS and GHC.-knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree-knownIssueFor solution = go . \case-    BrokenSpecific bos vers -> isTargetOS bos && isTargetGhc vers-    BrokenForOS bos         -> isTargetOS bos-    BrokenForGHC vers       -> isTargetGhc vers-    where-        isTargetOS = \case-            Windows -> isWindows-            MacOS   -> isMac-            Linux   -> not isWindows && not isMac--        isTargetGhc = elem ghcVersion--        go True = case solution of-            Broken -> expectFailBecause-            Ignore -> ignoreTestBecause-        go False = const id--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-  | ExpectHoverExcludeText [T.Text] -- the hover message must _not_ contain these snippets-  | ExpectHoverTextRegex T.Text -- the hover message must match this pattern-  | 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 :: UInt -> UInt -> UInt -> UInt -> Expect-mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn--mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect-mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn----testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree-testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix--testSession' :: String -> (FilePath -> Session ()) -> TestTree-testSession' name = testCase name . run'----mkRange :: UInt -> UInt -> UInt -> UInt -> Range-mkRange a b c d = Range (Position a b) (Position c d)---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)--withLongTimeout :: IO a -> IO a-withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT")----lspTestCapsNoFileWatches :: ClientCapabilities-lspTestCapsNoFileWatches = lspTestCaps & L.workspace . Lens._Just . L.didChangeWatchedFiles .~ Nothing--openTestDataDoc :: FilePath -> Session TextDocumentIdentifier-openTestDataDoc path = do-  source <- liftIO $ readFileUtf8 $ "test/data" </> path-  createDoc path "haskell" source--pattern R :: UInt -> UInt -> UInt -> UInt -> Range-pattern R x y x' y' = Range (Position x y) (Position x' y')--checkDefs :: Definition |? ([DefinitionLink] |? Null) -> Session [Expect] -> Session ()-checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpectations where-  check (ExpectRange expectedRange) = do-    def <- assertOneDefinitionFound defs-    assertRangeCorrect def expectedRange-  check (ExpectLocation expectedLocation) = do-    def <- assertOneDefinitionFound defs-    liftIO $ do-      canonActualLoc <- canonicalizeLocation def-      canonExpectedLoc <- canonicalizeLocation expectedLocation-      canonActualLoc @?= canonExpectedLoc-  check ExpectNoDefinitions = do-    liftIO $ assertBool "Expecting no definitions" $ null defs-  check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"-  check _ = pure () -- all other expectations not relevant to getDefinition--  assertOneDefinitionFound :: [Location] -> Session Location-  assertOneDefinitionFound [def] = pure def-  assertOneDefinitionFound _ = liftIO $ assertFailure "Expecting exactly one definition"--  assertRangeCorrect Location{_range = foundRange} expectedRange =-    liftIO $ expectedRange @=? foundRange--canonicalizeLocation :: Location -> IO Location-canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range--defToLocation :: Definition |? ([DefinitionLink] |? Null) -> [Location]-defToLocation (InL (Definition (InL l))) = [l]-defToLocation (InL (Definition (InR ls))) = ls-defToLocation (InR (InL defLink)) = (\(DefinitionLink LocationLink{_targetUri,_targetRange}) -> Location _targetUri _targetRange) <$> defLink-defToLocation (InR (InR Null)) = []---- | Ghc 9 doesn't include the $-sign in TH warnings like earlier versions did-thDollarIdx :: UInt-thDollarIdx | ghcVersion >= GHC90 = 1-            | otherwise = 0--testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO ()-testIde recorder arguments session = do-    config <- getConfigFromEnv-    cwd <- getCurrentDirectory-    (hInRead, hInWrite) <- createPipe-    (hOutRead, hOutWrite) <- createPipe-    let projDir = "."-    let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments-            { IDE.argsHandleIn = pure hInRead-            , IDE.argsHandleOut = pure hOutWrite-            }--    flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ ->-        runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session
− test/exe/UnitTests.hs 
@@ -1,110 +0,0 @@--module UnitTests (tests) where--import           Control.Concurrent-import           Control.Monad.IO.Class            (liftIO)-import           Data.IORef-import           Data.IORef.Extra                  (atomicModifyIORef_)-import           Data.List.Extra-import           Data.String                       (IsString (fromString))-import qualified Data.Text                         as T-import           Development.IDE.Core.FileStore    (getModTime)-import qualified Development.IDE.Main              as IDE-import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide-import qualified Development.IDE.Types.Diagnostics as Diagnostics-import           Development.IDE.Types.Location-import qualified FuzzySearch-import           Ide.Logger                        (Logger, Recorder,-                                                    WithPriority, cmapWithPrio)-import           Ide.PluginUtils                   (pluginDescToIdePlugins)-import           Ide.Types-import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Types       hiding-                                                   (SemanticTokenAbsolute (..),-                                                    SemanticTokenRelative (..),-                                                    SemanticTokensEdit (..),-                                                    mkRange)-import           Language.LSP.Test-import           LogType                           (Log (..))-import           Network.URI-import qualified Progress-import           System.IO.Extra                   hiding (withTempDir)-import           System.Mem                        (performGC)-import           Test.Tasty-import           Test.Tasty.ExpectedFailure-import           Test.Tasty.HUnit-import           TestUtils-import           Text.Printf                       (printf)--tests :: Recorder (WithPriority Log) -> Logger -> TestTree-tests recorder logger = 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 "showDiagnostics prints ranges 1-based (like vscode)" $ do-         let diag = ("", Diagnostics.ShowDiag, Diagnostic-               {  _codeDescription = Nothing-                , _data_ = Nothing-                , _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-     , testCase "notification handlers run in priority order" $ do-        orderRef <- newIORef []-        let plugins = pluginDescToIdePlugins $-                [ (priorityPluginDescriptor i)-                    { pluginNotificationHandlers = mconcat-                        [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ ->-                            liftIO $ atomicModifyIORef_ orderRef (i:)-                        ]-                    }-                    | i <- [1..20]-                ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder)-            priorityPluginDescriptor i = (defaultPluginDescriptor $ fromString $ show i){pluginPriority = i}--        testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger plugins) $ do-            _ <- createDoc "A.hs" "haskell" "module A where"-            waitForProgressDone-            actualOrder <- liftIO $ reverse <$> readIORef orderRef--            -- Handlers are run in priority descending order-            liftIO $ actualOrder @?= [20, 19 .. 1]-     , ignoreTestBecause "The test fails sometimes showing 10000us" $-         testCase "timestamps have millisecond resolution" $ do-           resolution_us <- findResolution_us 1-           let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us-           assertBool msg (resolution_us <= 1000)-     , Progress.tests-     , FuzzySearch.tests-     ]--findResolution_us :: Int -> IO Int-findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution"-findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do-    performGC-    writeFile f ""-    threadDelay delay_us-    writeFile f' ""-    t <- getModTime f-    t' <- getModTime f'-    if t /= t' then return delay_us else findResolution_us (delay_us * 10)
− test/exe/WatchedFileTests.hs 
@@ -1,83 +0,0 @@--{-# LANGUAGE GADTs     #-}-{-# LANGUAGE PolyKinds #-}--module WatchedFileTests (tests) where--import           Control.Applicative.Combinators-import           Control.Monad.IO.Class          (liftIO)-import qualified Data.Aeson                      as A-import qualified Data.Text                       as T-import           Development.IDE.Test            (expectDiagnostics)-import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Types     hiding-                                                 (SemanticTokenAbsolute (..),-                                                  SemanticTokenRelative (..),-                                                  SemanticTokensEdit (..),-                                                  mkRange)-import           Language.LSP.Test-import           System.Directory-import           System.FilePath--- import Test.QuickCheck.Instances ()-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils--tests :: TestTree-tests = testGroup "watched files"-  [ testGroup "Subscriptions"-    [ 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 SMethod_TextDocumentPublishDiagnostics--        -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle-        liftIO $ length watchedFileRegs @?= 2--    , testSession' "non workspace file" $ \sessionDir -> do-        tmpDir <- liftIO getTemporaryDirectory-        let yaml = "cradle: {direct: {arguments: [\"-i" <> tail(init(show tmpDir)) <> "\", \"A\", \"WatchedFilesMissingModule\"]}}"-        liftIO $ writeFile (sessionDir </> "hie.yaml") yaml-        _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"-        watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics--        -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle-        liftIO $ length watchedFileRegs @?= 2--    -- TODO add a test for didChangeWorkspaceFolder-    ]-  , testGroup "Changes"-    [-      testSession' "workspace files" $ \sessionDir -> do-        liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}"-        liftIO $ writeFile (sessionDir </> "B.hs") $ unlines-          ["module B where"-          ,"b :: Bool"-          ,"b = False"]-        _doc <- createDoc "A.hs" "haskell" $ T.unlines-          ["module A where"-          ,"import B"-          ,"a :: ()"-          ,"a = b"-          ]-        expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'")])]-        -- modify B off editor-        liftIO $ writeFile (sessionDir </> "B.hs") $ unlines-          ["module B where"-          ,"b :: Int"-          ,"b = 0"]-        sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $-               [FileEvent (filePathToUri $ sessionDir </> "B.hs") FileChangeType_Changed ]-        expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Int'")])]-    ]-  ]--getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions]-getWatchedFilesSubscriptionsUntil m = do-      msgs <- manyTill (Just <$> message SMethod_ClientRegisterCapability <|> Nothing <$ anyMessage) (message m)-      return-            [ x-            | Just TRequestMessage{_params = RegistrationParams regs} <- msgs-            , Registration _id "workspace/didChangeWatchedFiles" (Just args) <- regs-            , Just x@(DidChangeWatchedFilesRegistrationOptions _) <- [A.decode . A.encode $ args]-            ]
− test/preprocessor/Main.hs 
@@ -1,10 +0,0 @@--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 
@@ -1,258 +0,0 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.--- SPDX-License-Identifier: Apache-2.0--{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE PolyKinds             #-}--module Development.IDE.Test-  ( Cursor-  , cursorPosition-  , requireDiagnostic-  , diagnostic-  , expectDiagnostics-  , expectDiagnosticsWithTags-  , expectNoMoreDiagnostics-  , expectMessages-  , expectCurrentDiagnostics-  , checkDiagnosticsForDoc-  , canonicalizeUri-  , standardizeQuotes-  , flushMessages-  , waitForAction-  , getInterfaceFilesDir-  , garbageCollectDirtyKeys-  , getFilesOfInterest-  , waitForTypecheck-  , waitForBuildQueue-  , getStoredKeys-  , waitForCustomMessage-  , waitForGC-  , configureCheckProject-  , isReferenceReady-  , referenceReady) where--import           Control.Applicative.Combinators-import           Control.Lens                    hiding (List)-import           Control.Monad-import           Control.Monad.IO.Class-import           Data.Aeson                      (toJSON)-import qualified Data.Aeson                      as A-import           Data.Bifunctor                  (second)-import           Data.Default-import qualified Data.Map.Strict                 as Map-import           Data.Maybe                      (fromJust)-import           Data.Proxy-import           Data.Text                       (Text)-import qualified Data.Text                       as T-import           Development.IDE.Plugin.Test     (TestRequest (..),-                                                  WaitForIdeRuleResult,-                                                  ideResultSuccess)-import           Development.IDE.Test.Diagnostic-import           GHC.TypeLits                    (symbolVal)-import           Ide.Plugin.Config               (CheckParents, checkProject)-import qualified Language.LSP.Protocol.Lens      as L-import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Types-import           Language.LSP.Test               hiding (message)-import qualified Language.LSP.Test               as LspTest-import           System.Directory                (canonicalizePath)-import           System.FilePath                 (equalFilePath)-import           System.Time.Extra-import           Test.Tasty.HUnit--requireDiagnosticM-    :: (Foldable f, Show (f Diagnostic), HasCallStack)-    => f Diagnostic-    -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)-    -> Assertion-requireDiagnosticM actuals expected = case requireDiagnostic actuals expected of-    Nothing  -> pure ()-    Just err -> assertFailure err---- |wait for @timeout@ seconds and report an assertion failure--- if any diagnostic messages arrive in that period-expectNoMoreDiagnostics :: HasCallStack => Seconds -> Session ()-expectNoMoreDiagnostics timeout =-  expectMessages SMethod_TextDocumentPublishDiagnostics timeout $ \diagsNot -> do-    let fileUri = diagsNot ^. L.params . L.uri-        actual = diagsNot ^. L.params . L.diagnostics-    unless (actual == []) $ liftIO $-      assertFailure $-        "Got unexpected diagnostics for " <> show fileUri-          <> " got "-          <> show actual--expectMessages :: SMethod m -> Seconds -> (TServerMessage 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 = SMethod_CustomMethod (Proxy @"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 = SMethod_CustomMethod (Proxy @"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 :: HasCallStack => [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()-expectDiagnostics-  = expectDiagnosticsWithTags-  . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing))))--unwrapDiagnostic :: TServerMessage Method_TextDocumentPublishDiagnostics  -> (Uri, [Diagnostic])-unwrapDiagnostic diagsNot = (diagsNot^. L.params . L.uri, diagsNot^. L.params . L.diagnostics)--expectDiagnosticsWithTags :: HasCallStack => [(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' ::-  (HasCallStack, MonadIO m) =>-  m (Uri, [Diagnostic]) ->-  Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] ->-  m ()-expectDiagnosticsWithTags' next m | null m = do-    (_,actual) <- next-    case actual of-        [] ->-            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_ (requireDiagnosticM 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 :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session ()-expectCurrentDiagnostics doc expected = do-    diags <- getCurrentDiagnostics doc-    checkDiagnosticsForDoc doc expected diags--checkDiagnosticsForDoc :: HasCallStack => 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, obtained)) expected'--canonicalizeUri :: Uri -> IO Uri-canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePath uri))--diagnostic :: Session (TNotificationMessage Method_TextDocumentPublishDiagnostics)-diagnostic = LspTest.message SMethod_TextDocumentPublishDiagnostics--tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)-tryCallTestPlugin cmd = do-    let cm = SMethod_CustomMethod (Proxy @"test")-    waitId <- sendRequest cm (A.toJSON cmd)-    TResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId-    return $ case _result of-         Left e -> Left e-         Right json -> case A.fromJSON json of-             A.Success a -> Right a-             A.Error e   -> error e--callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b-callTestPlugin cmd = do-    res <- tryCallTestPlugin cmd-    case res of-        Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err-        Right a                      -> pure a---waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResult-waitForAction key TextDocumentIdentifier{_uri} =-    callTestPlugin (WaitForIdeRule key _uri)--getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath-getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri)--garbageCollectDirtyKeys :: CheckParents -> Int -> Session [String]-garbageCollectDirtyKeys parents age = callTestPlugin (GarbageCollectDirtyKeys parents age)--getStoredKeys :: Session [Text]-getStoredKeys = callTestPlugin GetStoredKeys--waitForTypecheck :: TextDocumentIdentifier -> Session Bool-waitForTypecheck tid = ideResultSuccess <$> waitForAction "typecheck" tid--waitForBuildQueue :: Session ()-waitForBuildQueue = callTestPlugin WaitForShakeQueue--getFilesOfInterest :: Session [FilePath]-getFilesOfInterest = callTestPlugin GetFilesOfInterest--waitForCustomMessage :: T.Text -> (A.Value -> Maybe res) -> Session res-waitForCustomMessage msg pred =-    skipManyTill anyMessage $ satisfyMaybe $ \case-        FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params = value})-            | symbolVal p == T.unpack msg -> pred value-        _ -> Nothing--waitForGC :: Session [T.Text]-waitForGC = waitForCustomMessage "ghcide/GC" $ \v ->-    case A.fromJSON v of-        A.Success x -> Just x-        _           -> Nothing--configureCheckProject :: Bool -> Session ()-configureCheckProject overrideCheckProject = setConfigSection "haskell" (toJSON $ def{checkProject = overrideCheckProject})---- | Pattern match a message from ghcide indicating that a file has been indexed-isReferenceReady :: FilePath -> Session ()-isReferenceReady p = void $ referenceReady (equalFilePath p)--referenceReady :: (FilePath -> Bool) -> Session FilePath-referenceReady pred = satisfyMaybe $ \case-  FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params})-    | A.Success fp <- A.fromJSON _params-    , pred fp-    , symbolVal p == "ghcide/reference/ready"-    -> Just fp-  _ -> Nothing-
− test/src/Development/IDE/Test/Diagnostic.hs 
@@ -1,47 +0,0 @@-module Development.IDE.Test.Diagnostic where--import           Control.Lens                ((^.))-import qualified Data.Text                   as T-import           GHC.Stack                   (HasCallStack)-import           Language.LSP.Protocol.Lens-import           Language.LSP.Protocol.Types---- | (0-based line number, 0-based column number)-type Cursor = (UInt, UInt)--cursorPosition :: Cursor -> Position-cursorPosition (line,  col) = Position line col--type ErrorMsg = String--requireDiagnostic-    :: (Foldable f, Show (f Diagnostic), HasCallStack)-    => f Diagnostic-    -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)-    -> Maybe ErrorMsg-requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag)-    | any match actuals = Nothing-    | otherwise = Just $-            "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 [DiagnosticTag] -> Bool-    hasTag Nothing  _                   = True-    hasTag (Just _) Nothing             = False-    hasTag (Just actualTag) (Just tags) = actualTag `elem` tags--standardizeQuotes :: T.Text -> T.Text-standardizeQuotes msg = let-        repl '‘' = '\''-        repl '’' = '\''-        repl '`' = '\''-        repl  c  = c-    in  T.map repl msg