packages feed

ghcide 1.7.0.0 → 2.14.0.0

raw patch · 284 files changed

Files

CHANGELOG.md view
@@ -3,8 +3,8 @@ * Progress reporting improvements (#1784) - Pepe Iborra * Unify session loading using implicit-hie (#1783) - fendor * Fix remove constraint (#1578) - Kostas Dermentzis-* Fix wrong extend import while type constuctor and data constructor have the same name (#1775) - Lei Zhu-* Imporve vscode extension schema generation (#1742) - Potato Hatsue+* Fix wrong extend import while type constructor and data constructor have the same name (#1775) - Lei Zhu+* Improve vscode extension schema generation (#1742) - Potato Hatsue * Add hls-graph abstracting over shake (#1748) - Neil Mitchell * Tease apart the custom SYB from ExactPrint (#1746) - Sandy Maguire * fix class method completion (#1741) - Lei Zhu
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,312 +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.6, and that the first time a module is loaded in the editor will trigger generation of support files in the background if those do not already exist.--### Configuration--`ghcide` accepts the following lsp configuration options:--```typescript-{-  // When to check the dependents of a module-  // AlwaysCheck means retypechecking them on every change-  // CheckOnSave means dependent/parent modules will only be checked when you save-  // "CheckOnSaveAndClose" by default-  checkParents : "NeverCheck" | "CheckOnClose" | "CheckOnSaveAndClose" | "AlwaysCheck" | ,-  // Whether to check the entire project on initial load-  // true by default-  checkProject : boolean--}-```--### Using with VS Code--The [Haskell](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) extension has a setting for ghcide.--### Using with Atom--You can follow the [instructions](https://github.com/moodmosaic/ide-haskell-ghcide#readme) to install with `apm`.--### Using with Sublime Text--* Install [LSP](https://packagecontrol.io/packages/LSP)-* Press Ctrl+Shift+P or Cmd+Shift+P in Sublime Text and search for *Preferences: LSP Settings*, then paste these settings-```-{-  "clients":-  {-    "ghcide":-    {-      "enabled"   : true,-      "languageId": "haskell",-      "command"   : ["ghcide", "--lsp"],-      "scopes"    : ["source.haskell"],-      "syntaxes"  : ["Packages/Haskell/Haskell.sublime-syntax"]-    }-  }-}-```--### Using with Emacs--If you don't already have [MELPA](https://melpa.org/#/) package installation configured, visit MELPA [getting started](https://melpa.org/#/getting-started) page to get set up. Then, install [`use-package`](https://melpa.org/#/use-package).--Now you have a choice of two different Emacs packages which can be used to communicate with the `ghcide` LSP server:--+ `lsp-ui`-+ `eglot` (requires Emacs 26.1+)--In each case, you can enable support by adding the shown lines to your `.emacs`:--#### lsp-ui--```elisp-;; LSP-(use-package flycheck-  :ensure t-  :init-  (global-flycheck-mode t))-(use-package yasnippet-  :ensure t)-(use-package lsp-mode-  :ensure t-  :hook (haskell-mode . lsp)-  :commands lsp)-(use-package lsp-ui-  :ensure t-  :commands lsp-ui-mode)-(use-package lsp-haskell- :ensure t- :config- (setq lsp-haskell-process-path-hie "ghcide")- (setq lsp-haskell-process-args-hie '())- ;; Comment/uncomment this line to see interactions between lsp client/server.- ;;(setq lsp-log-io t)-)-```--#### eglot--````elisp-(use-package eglot-  :ensure t-  :config-  (add-to-list 'eglot-server-programs '(haskell-mode . ("ghcide" "--lsp"))))-````--### Using with Vim/Neovim--#### LanguageClient-neovim-Install [LanguageClient-neovim](https://github.com/autozimu/LanguageClient-neovim)--Add this to your vim config:-```vim-let g:LanguageClient_rootMarkers = ['*.cabal', 'stack.yaml']-let g:LanguageClient_serverCommands = {-    \ 'rust': ['rls'],-    \ 'haskell': ['ghcide', '--lsp'],-    \ }-```--Refer to `:he LanguageClient` for more details on usage and configuration.--#### vim-lsp-Install [vim-lsp](https://github.com/prabirshrestha/vim-lsp).--Add this to your vim config:--```vim-au User lsp_setup call lsp#register_server({-    \ 'name': 'ghcide',-    \ 'cmd': {server_info->['/your/path/to/ghcide', '--lsp']},-    \ 'whitelist': ['haskell'],-    \ })-```--To verify it works move your cursor over a symbol and run `:LspHover`.--### coc.nvim--Install [coc.nvim](https://github.com/neoclide/coc.nvim)--Add this to your coc-settings.json (which you can edit with :CocConfig):--```json-{-  "languageserver": {-    "haskell": {-      "command": "ghcide",-      "args": [-        "--lsp"-      ],-      "rootPatterns": [-        ".stack.yaml",-        ".hie-bios",-        "BUILD.bazel",-        "cabal.config",-        "package.yaml"-      ],-      "filetypes": [-        "hs",-        "lhs",-        "haskell"-      ]-    }-  }-}-```--Here's a nice article on setting up neovim and coc: [Vim and Haskell in-2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/) (this is actually for haskell-ide, not ghcide)--Here is a Docker container that pins down the build and configuration for-Neovim and ghcide on a minimal Debian 10 base system:-[docker-ghcide-neovim](https://github.com/carlohamalainen/docker-ghcide-neovim/).--### SpaceVim--In the `autocomplete` layer, add the `autocomplete_method` option to force the use of `coc`:--```toml-[[layers]]-  name = 'autocomplete'-  auto-completion-return-key-behavior = "complete"-  auto-completion-tab-key-behavior = "smart"-  [options]-    autocomplete_method = "coc"-```--Add this to your coc-settings.json (which you can edit with :CocConfig):--```json-{-  "languageserver": {-    "haskell": {-      "command": "ghcide",-      "args": [-        "--lsp"-      ],-      "rootPatterns": [-        ".stack.yaml",-        ".hie-bios",-        "BUILD.bazel",-        "cabal.config",-        "package.yaml"-      ],-      "filetypes": [-        "hs",-        "lhs",-        "haskell"-      ]-    }-  }-}-```--This example above describes a setup in which `ghcide` is installed-using `stack install ghcide` within a project.--### Using with Kakoune--Install [kak-lsp](https://github.com/ul/kak-lsp).--Change `kak-lsp.toml` to include this:--```toml-[language.haskell]-filetypes = ["haskell"]-roots = ["Setup.hs", "stack.yaml", "*.cabal", "cabal.project", "hie.yaml"]-command = "ghcide"-args = ["--lsp"]-```--## Hacking on ghcide--To build and work on `ghcide` itself, you should use cabal, e.g.,-running `cabal test` will execute the test suite. You can use `stack test` too, but-note that some tests will fail, and none of the maintainers are currently using `stack`.--If you are using Nix, there is a Cachix nix-shell cache for all the supported platforms: `cachix use haskell-ghcide`.--If you are using Windows, you should disable the `auto.crlf` setting and configure your editor to use LF line endings, directly or making it use the existing `.editor-config`.--If you are chasing down test failures, you can use the tasty-rerun feature by running tests as--    cabal test --test-options"--rerun"--This writes a log file called `.tasty-rerun-log` of the failures, and only runs those.-See the [tasty-rerun](https://hackage.haskell.org/package/tasty-rerun-1.1.17/docs/Test-Tasty-Ingredients-Rerun.html) documentation for other options.--If you are touching performance sensitive code, take the time to run a differential-benchmark between HEAD and master using the benchHist script. This assumes that-"master" points to the upstream master.--Run the benchmarks with `cabal bench`.--It should take around 15 minutes and the results will be stored in the `bench-results` folder. To interpret the results, see the comments in the `bench/hist/Main.hs` module.--More details in [bench/README](bench/README.md)---## History and relationship to other Haskell IDE's--The teams behind this project and the [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme) have agreed to join forces under the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server), see the [original announcement](https://neilmitchell.blogspot.com/2020/01/one-haskell-ide-to-rule-them-all.html). The technical work is ongoing, with the likely model being that this project serves as the core, while plugins and integrations are kept in the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server).--The code behind `ghcide` was originally developed by [Digital Asset](https://digitalasset.com/) as part of the [DAML programming language](https://github.com/digital-asset/daml). DAML is a smart contract language targeting distributed-ledger runtimes, based on [GHC](https://www.haskell.org/ghc/) with custom language extensions. The DAML programming language has [an IDE](https://webide.daml.com/), and work was done to separate off a reusable Haskell-only IDE (what is now `ghcide`) which the [DAML IDE then builds upon](https://github.com/digital-asset/daml/tree/master/compiler/damlc). Since that time, there have been various [non-Digital Asset contributors](https://github.com/haskell/ghcide/graphs/contributors), in addition to continued investment by Digital Asset. The project has been handed over to Haskell.org as of September 2020.--The Haskell community [has](https://github.com/DanielG/ghc-mod) [various](https://github.com/chrisdone/intero) [IDE](https://github.com/rikvdkleij/intellij-haskell) [choices](http://leksah.org/), but the one that had been gathering momentum is [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme). Our project owes a debt of gratitude to the `haskell-ide-engine`. We reuse libraries from their ecosystem, including [`hie-bios`](https://github.com/mpickering/hie-bios#readme) (a likely future environment setup layer in `haskell-ide-engine`), [`haskell-lsp`](https://github.com/alanz/haskell-lsp#readme) and [`lsp-test`](https://github.com/bubba/lsp-test#readme) (the `haskell-ide-engine` [LSP protocol](https://microsoft.github.io/language-server-protocol/) pieces). We make heavy use of their contributions to GHC itself, in particular the work to make GHC take string buffers rather than files.--The best summary of the architecture of `ghcide` is available [this talk](https://www.youtube.com/watch?v=cijsaeWNf2E&list=PLxxF72uPfQVRdAsvj7THoys-nVj-oc4Ss) ([slides](https://ndmitchell.com/downloads/slides-making_a_haskell_ide-07_sep_2019.pdf)), given at [MuniHac 2019](https://munihac.de/2019.html). However, since that talk the project has renamed from `hie-core` to `ghcide`, and the repo has moved to [this location](https://github.com/haskell/ghcide/).+Set-up and usage instructions can be found on [haskell-language-server documentation](https://haskell-language-server.readthedocs.io/en/latest/components/ghcide.html)
− bench/exe/Main.hs 
@@ -1,59 +0,0 @@-{- An automated benchmark built around the simple experiment described in:--  > https://neilmitchell.blogspot.com/2020/05/fixing-space-leaks-in-ghcide.html--  As an example project, it unpacks Cabal-3.2.0.0 in the local filesystem and-  loads the module 'Distribution.Simple'. The rationale for this choice is:--    - It's convenient to download with `cabal unpack Cabal-3.2.0.0`-    - It has very few dependencies, and all are already needed to build ghcide-    - Distribution.Simple has 235 transitive module dependencies, so non trivial--  The experiments are sequences of lsp commands scripted using lsp-test.-  A more refined approach would be to record and replay real IDE interactions,-  once the replay functionality is available in lsp-test.-  A more declarative approach would be to reuse ide-debug-driver:--  > https://github.com/digital-asset/daml/blob/master/compiler/damlc/ide-debug-driver/README.md--  The result of an experiment is a total duration in seconds after a preset-  number of iterations. There is ample room for improvement:-     - Statistical analysis to detect outliers and auto infer the number of iterations needed-     - GC stats analysis (currently -S is printed as part of the experiment)-     - Analyisis of performance over the commit history of the project--  How to run:-     1. `cabal exec cabal run ghcide-bench -- -- ghcide-bench-options`-     1. `stack build ghcide:ghcide-bench && stack exec ghcide-bench -- -- ghcide-bench-options`--  Note that the package database influences the response times of certain actions,-  e.g. code actions, and therefore the two methods above do not necessarily-  produce the same results.-- -}--{-# LANGUAGE ImplicitParams #-}--import           Control.Exception.Safe-import           Control.Monad-import           Experiments-import           Options.Applicative-import           System.IO--optsP :: Parser (Config, Bool)-optsP = (,) <$> configP <*> switch (long "no-clean")--main :: IO ()-main = do-  hSetBuffering stdout LineBuffering-  hSetBuffering stderr LineBuffering-  (config, noClean) <- execParser $ info (optsP <**> helper) fullDesc-  let ?config = config--  hPrint stderr config--  output "starting test"--  SetupResult{..} <- setup--  runBenchmarks experiments `finally` unless noClean cleanUp
− bench/hist/Main.hs 
@@ -1,192 +0,0 @@-{-  Bench history--    A Shake script to analyze the performance of ghcide over the git history of the project--    Driven by a config file `bench/config.yaml` containing the list of Git references to analyze.--    Builds each one of them and executes a set of experiments using the ghcide-bench suite.--    The results of the benchmarks and the analysis are recorded in the file-    system with the following structure:--    bench-results-    ├── <git-reference>-    │   ├── ghc.path                          - path to ghc used to build the binary-    │   ├── ghcide                            - binary for this version-    ├─ <example>-    │   ├── results.csv                           - aggregated results for all the versions-    │   └── <git-reference>-    │       ├── <experiment>.gcStats.log          - RTS -s output-    │       ├── <experiment>.csv                  - stats for the experiment-    │       ├── <experiment>.svg                  - Graph of bytes over elapsed time-    │       ├── <experiment>.diff.svg             - idem, including the previous version-    │       ├── <experiment>.log                  - ghcide-bench output-    │       └── results.csv                       - results of all the experiments for the example-    ├── results.csv        - aggregated results of all the experiments and versions-    └── <experiment>.svg   - graph of bytes over elapsed time, for all the included versions--   For diff graphs, the "previous version" is the preceding entry in the list of versions-   in the config file. A possible improvement is to obtain this info via `git rev-list`.--   To execute the script:--   > cabal/stack bench--   To build a specific analysis, enumerate the desired file artifacts--   > stack bench --ba "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg"-   > cabal bench --benchmark-options "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg"-- -}-{-# LANGUAGE DeriveAnyClass     #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE TypeFamilies       #-}-{-# OPTIONS -Wno-orphans #-}--import           Control.Monad.Extra-import           Data.Foldable               (find)-import           Data.Maybe-import           Data.Yaml                   (FromJSON (..), decodeFileThrow)-import           Development.Benchmark.Rules-import           Development.Shake-import           Development.Shake.Classes-import           Experiments.Types           (Example (exampleName),-                                              exampleToOptions)-import           GHC.Generics                (Generic)-import           Numeric.Natural             (Natural)-import           System.Console.GetOpt-import           System.FilePath--configPath :: FilePath-configPath = "bench/config.yaml"--configOpt :: OptDescr (Either String FilePath)-configOpt = Option [] ["config"] (ReqArg Right configPath) "config file"---- | Read the config without dependency-readConfigIO :: FilePath -> IO (Config BuildSystem)-readConfigIO = decodeFileThrow--instance IsExample Example where getExampleName = exampleName-type instance RuleResult GetExample = Maybe Example-type instance RuleResult GetExamples = [Example]--shakeOpts :: ShakeOptions-shakeOpts =-    shakeOptions{shakeChange = ChangeModtimeAndDigestInput, shakeThreads = 0}--main :: IO ()-main = shakeArgsWith shakeOpts [configOpt] $ \configs wants -> pure $ Just $ do-  let config = fromMaybe configPath $ listToMaybe configs-  _configStatic <- createBuildSystem config-  case wants of-      [] -> want ["all"]-      _  -> want wants--ghcideBuildRules :: MkBuildRules BuildSystem-ghcideBuildRules = MkBuildRules findGhcForBuildSystem "ghcide" projectDepends buildGhcide-  where-      projectDepends = do-        need . map ("../hls-graph/src" </>) =<< getDirectoryFiles "../hls-graph/src" ["//*.hs"]-        need . map ("../hls-plugin-api/src" </>) =<< getDirectoryFiles "../hls-plugin-api/src" ["//*.hs"]-        need . map ("src" </>) =<< getDirectoryFiles "src" ["//*.hs"]-        need . map ("session-loader" </>) =<< getDirectoryFiles "session-loader" ["//*.hs"]-        need =<< getDirectoryFiles "." ["*.cabal"]------------------------------------------------------------------------------------data Config buildSystem = Config-  { experiments     :: [Unescaped String],-    examples        :: [Example],-    samples         :: Natural,-    versions        :: [GitCommit],-    -- | Output folder ('foo' works, 'foo/bar' does not)-    outputFolder    :: String,-    buildTool       :: buildSystem,-    profileInterval :: Maybe Double-  }-  deriving (Generic, Show)-  deriving anyclass (FromJSON)--createBuildSystem :: FilePath -> Rules (Config BuildSystem )-createBuildSystem config = do-  readConfig <- newCache $ \fp -> need [fp] >> liftIO (readConfigIO fp)--  _ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config-  _ <- addOracle $ \GetVersions {} -> versions <$> readConfig config-  _ <- versioned 1 $ addOracle $ \GetExamples{} -> examples <$> readConfig config-  _ <- versioned 1 $ addOracle $ \(GetExample name) -> find (\e -> getExampleName e == name) . examples <$> readConfig config-  _ <- addOracle $ \GetBuildSystem {} -> buildTool <$> readConfig config-  _ <- addOracle $ \GetSamples{} -> samples <$> readConfig config--  configStatic <- liftIO $ readConfigIO config-  let build = outputFolder configStatic--  buildRules build ghcideBuildRules-  benchRules build (MkBenchRules (askOracle $ GetSamples ()) benchGhcide warmupGhcide "ghcide")-  csvRules build-  svgRules build-  heapProfileRules build-  phonyRules "" "ghcide" NoProfiling build (examples configStatic)--  whenJust (profileInterval configStatic) $ \i -> do-    phonyRules "profiled-" "ghcide" (CheapHeapProfiling i) build (examples configStatic)--  return configStatic--newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show)-type instance RuleResult GetSamples = Natural------------------------------------------------------------------------------------buildGhcide :: BuildSystem -> [CmdOption] -> FilePath -> Action ()-buildGhcide Cabal args out = do-    command_ args "cabal"-        ["install"-        ,"exe:ghcide"-        ,"--installdir=" ++ out-        ,"--install-method=copy"-        ,"--overwrite-policy=always"-        ,"--ghc-options=-rtsopts"-        ,"--ghc-options=-eventlog"-        ]--buildGhcide Stack args out =-    command_ args "stack"-        ["--local-bin-path=" <> out-        ,"build"-        ,"ghcide:ghcide"-        ,"--copy-bins"-        ,"--ghc-options=-rtsopts"-        ,"--ghc-options=-eventlog"-        ]--benchGhcide-  :: Natural -> BuildSystem -> [CmdOption] -> BenchProject Example -> Action ()-benchGhcide samples buildSystem args BenchProject{..} = do-  command_ args "ghcide-bench" $-    [ "--timeout=300",-      "--no-clean",-        "-v",-        "--samples=" <> show samples,-        "--csv="     <> outcsv,-        "--ghcide="  <> exePath,-        "--select",-        unescaped (unescapeExperiment experiment)-    ] ++-    exampleToOptions example exeExtraArgs ++-    [ "--stack" | Stack == buildSystem-    ]--warmupGhcide :: BuildSystem -> FilePath -> [CmdOption] -> Example -> Action ()-warmupGhcide buildSystem exePath args example = do-  command args "ghcide-bench" $-    [ "--no-clean",-      "-v",-      "--samples=1",-      "--ghcide=" <> exePath,-      "--select=hover"-    ] ++-    exampleToOptions example [] ++-    [ "--stack" | Stack == buildSystem-    ]
− bench/lib/Experiments.hs 
@@ -1,684 +0,0 @@-{-# LANGUAGE ConstraintKinds           #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE ImplicitParams            #-}-{-# LANGUAGE ImpredicativeTypes        #-}-{-# LANGUAGE PolyKinds                 #-}-{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-}--module Experiments-( Bench(..)-, BenchRun(..)-, Config(..)-, Verbosity(..)-, CabalStack(..)-, SetupResult(..)-, Example(..)-, experiments-, configP-, defConfig-, output-, setup-, runBench-, exampleToOptions-) where-import           Control.Applicative.Combinators (skipManyTill)-import           Control.Exception.Safe          (IOException, handleAny, try)-import           Control.Monad.Extra-import           Control.Monad.IO.Class-import           Data.Aeson                      (Value (Null), toJSON)-import           Data.Either                     (fromRight)-import           Data.List-import           Data.Maybe-import qualified Data.Text                       as T-import           Data.Version-import           Development.IDE.Plugin.Test-import           Development.IDE.Test            (getBuildEdgesCount,-                                                  getBuildKeysBuilt,-                                                  getBuildKeysChanged,-                                                  getBuildKeysVisited,-                                                  getStoredKeys,-                                                  getRebuildsCount,-                                                  )-import           Development.IDE.Test.Diagnostic-import           Development.Shake               (CmdOption (Cwd, FileStdout),-                                                  cmd_)-import           Experiments.Types-import           Language.LSP.Test-import           Language.LSP.Types              hiding-                                                 (SemanticTokenAbsolute (length, line),-                                                  SemanticTokenRelative (length),-                                                  SemanticTokensEdit (_start))-import           Language.LSP.Types.Capabilities-import           Numeric.Natural-import           Options.Applicative-import           System.Directory-import           System.Environment.Blank        (getEnv)-import           System.FilePath                 ((<.>), (</>))-import           System.Process-import           System.Time.Extra-import           Text.ParserCombinators.ReadP    (readP_to_S)--charEdit :: Position -> TextDocumentContentChangeEvent-charEdit p =-    TextDocumentContentChangeEvent-    { _range = Just (Range p p),-      _rangeLength = Nothing,-      _text = "a"-    }--data DocumentPositions = DocumentPositions {-    identifierP    :: Maybe Position,-    stringLiteralP :: !Position,-    doc            :: !TextDocumentIdentifier-}--allWithIdentifierPos :: Monad m => (DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool-allWithIdentifierPos f docs = allM f (filter (isJust . identifierP) docs)--experiments :: [Bench]-experiments =-    [ ----------------------------------------------------------------------------------------      bench "hover" $ allWithIdentifierPos $ \DocumentPositions{..} ->-        isJust <$> getHover doc (fromJust identifierP),-      ----------------------------------------------------------------------------------------      bench "edit" $ \docs -> do-        forM_ docs $ \DocumentPositions{..} -> do-          changeDoc doc [charEdit stringLiteralP]-          -- wait for a fresh build start-          waitForProgressStart-        -- wait for the build to be finished-        waitForProgressDone-        return True,-      ----------------------------------------------------------------------------------------      bench "hover after edit" $ \docs -> do-        forM_ docs $ \DocumentPositions{..} ->-          changeDoc doc [charEdit stringLiteralP]-        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->-          isJust <$> getHover doc (fromJust identifierP),-      ----------------------------------------------------------------------------------------      bench "getDefinition" $ allWithIdentifierPos $ \DocumentPositions{..} ->-        either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP),-      ----------------------------------------------------------------------------------------      bench "getDefinition after edit" $ \docs -> do-          forM_ docs $ \DocumentPositions{..} ->-            changeDoc doc [charEdit stringLiteralP]-          flip allWithIdentifierPos docs $ \DocumentPositions{..} ->-            either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP),-      ----------------------------------------------------------------------------------------      bench "documentSymbols" $ allM $ \DocumentPositions{..} -> do-        fmap (either (not . null) (not . null)) . getDocumentSymbols $ doc,-      ----------------------------------------------------------------------------------------      bench "documentSymbols after edit" $ \docs -> do-        forM_ docs $ \DocumentPositions{..} ->-          changeDoc doc [charEdit stringLiteralP]-        flip allM docs $ \DocumentPositions{..} ->-          either (not . null) (not . null) <$> getDocumentSymbols doc,-      ----------------------------------------------------------------------------------------      bench "completions" $ \docs -> do-        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->-          not . null <$> getCompletions doc (fromJust identifierP),-      ----------------------------------------------------------------------------------------      bench "completions after edit" $ \docs -> do-        forM_ docs $ \DocumentPositions{..} ->-          changeDoc doc [charEdit stringLiteralP]-        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->-          not . null <$> getCompletions doc (fromJust identifierP),-      ----------------------------------------------------------------------------------------      benchWithSetup-        "code actions"-        ( \docs -> do-            unless (any (isJust . identifierP) docs) $-                error "None of the example modules is suitable for this experiment"-            forM_ docs $ \DocumentPositions{..} -> do-                forM_ identifierP $ \p -> changeDoc doc [charEdit p]-                waitForProgressStart-            waitForProgressDone-        )-        ( \docs -> not . null . catMaybes <$> forM docs (\DocumentPositions{..} ->-            forM identifierP $ \p ->-              getCodeActions doc (Range p p))-        ),-      ----------------------------------------------------------------------------------------      benchWithSetup-        "code actions after edit"-        ( \docs -> do-            unless (any (isJust . identifierP) docs) $-                error "None of the example modules is suitable for this experiment"-            forM_ docs $ \DocumentPositions{..} ->-                forM_ identifierP $ \p -> changeDoc doc [charEdit p]-        )-        ( \docs -> do-            forM_ docs $ \DocumentPositions{..} -> do-              changeDoc doc [charEdit stringLiteralP]-              waitForProgressStart-            waitForProgressDone-            not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do-              forM identifierP $ \p ->-                getCodeActions doc (Range p p))-        ),-      ----------------------------------------------------------------------------------------      benchWithSetup-        "code actions after cradle edit"-        ( \docs -> do-            forM_ docs $ \DocumentPositions{..} -> do-                forM identifierP $ \p -> do-                    changeDoc doc [charEdit p]-                    waitForProgressStart-            void waitForBuildQueue-        )-        ( \docs -> do-            hieYamlUri <- getDocUri "hie.yaml"-            liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n"-            sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $-                List [ FileEvent hieYamlUri FcChanged ]-            waitForProgressStart-            waitForProgressStart-            waitForProgressStart -- the Session logic restarts a second time-            waitForProgressDone-            not . all null . catMaybes <$> forM docs (\DocumentPositions{..} -> do-              forM identifierP $ \p ->-                getCodeActions doc (Range p p))-        ),-      ----------------------------------------------------------------------------------------      bench-        "hover after cradle edit"-        (\docs -> do-            hieYamlUri <- getDocUri "hie.yaml"-            liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n"-            sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $-                List [ FileEvent hieYamlUri FcChanged ]-            flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP)-        ),-      ----------------------------------------------------------------------------------------      benchWithSetup-        "hole fit suggestions"-        ( mapM_ $ \DocumentPositions{..} -> do-            let edit :: TextDocumentContentChangeEvent =TextDocumentContentChangeEvent-                  { _range = Just Range {_start = bottom, _end = bottom}-                  , _rangeLength = Nothing, _text = t}-                bottom = Position maxBound 0-                t = T.unlines-                    [""-                    ,"holef :: [Int] -> [Int]"-                    ,"holef = _"-                    ,""-                    ,"holeg :: [()] -> [()]"-                    ,"holeg = _"-                    ]-            changeDoc doc [edit]-        )-        (\docs -> do-            forM_ docs $ \DocumentPositions{..} ->-              changeDoc doc [charEdit stringLiteralP]-            void waitForDiagnostics-            waitForProgressDone-            flip allM docs $ \DocumentPositions{..} -> do-                bottom <- pred . length . T.lines <$> documentContents doc-                diags <- getCurrentDiagnostics doc-                case requireDiagnostic diags (DsError, (fromIntegral bottom, 8), "Found hole", Nothing) of-                    Nothing   -> pure True-                    Just _err -> pure False-        )-    ]-------------------------------------------------------------------------------------------------examplesPath :: FilePath-examplesPath = "bench/example"--defConfig :: Config-Success defConfig = execParserPure defaultPrefs (info configP fullDesc) []--quiet, verbose :: Config -> Bool-verbose = (== All) . verbosity-quiet   = (== Quiet) . verbosity--type HasConfig = (?config :: Config)--configP :: Parser Config-configP =-  Config-    <$> (flag' All (short 'v' <> long "verbose")-         <|> flag' Quiet (short 'q' <> long "quiet")-         <|> pure Normal-        )-    <*> optional (strOption (long "shake-profiling" <> metavar "PATH"))-    <*> optional (strOption (long "ot-profiling" <> metavar "DIR" <> help "Enable OpenTelemetry and write eventlog for each benchmark in DIR"))-    <*> strOption (long "csv" <> metavar "PATH" <> value "results.csv" <> showDefault)-    <*> flag Cabal Stack (long "stack" <> help "Use stack (by default cabal is used)")-    <*> many (strOption (long "ghcide-options" <> help "additional options for ghcide"))-    <*> many (strOption (short 's' <> long "select" <> help "select which benchmarks to run"))-    <*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count"))-    <*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide")-    <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response")-    <*> ( Example "name"-               <$> (Right <$> packageP)-               <*> (some moduleOption <|> pure ["src/Distribution/Simple.hs"])-               <*> pure []-         <|>-          Example "name"-                <$> (Left <$> pathP)-                <*> some moduleOption-                <*> pure [])-  where-      moduleOption = strOption (long "example-module" <> metavar "PATH")--      packageP = ExamplePackage-            <$> strOption (long "example-package-name" <> value "Cabal")-            <*> option versionP (long "example-package-version" <> value (makeVersion [3,6,0,0]))-      pathP = strOption (long "example-path")--versionP :: ReadM Version-versionP = maybeReader $ extract . readP_to_S parseVersion-  where-      extract parses = listToMaybe [ res | (res,"") <- parses]--output :: (MonadIO m, HasConfig) => String -> m ()-output = if quiet?config then (\_ -> pure ()) else liftIO . putStrLn-------------------------------------------------------------------------------------------type Experiment = [DocumentPositions] -> Session Bool--data Bench =-  Bench-  { name       :: !String,-    enabled    :: !Bool,-    samples    :: !Natural,-    benchSetup :: [DocumentPositions] -> Session (),-    experiment :: Experiment-  }--select :: HasConfig => Bench -> Bool-select Bench {name, enabled} =-  enabled && (null mm || name `elem` mm)-  where-    mm = matches ?config--benchWithSetup ::-  String ->-  ([DocumentPositions] -> Session ()) ->-  Experiment ->-  Bench-benchWithSetup name benchSetup experiment = Bench {..}-  where-    enabled = True-    samples = 100--bench :: String -> Experiment -> Bench-bench name = benchWithSetup name (const $ pure ())--runBenchmarksFun :: HasConfig => FilePath -> [Bench] -> IO ()-runBenchmarksFun dir allBenchmarks = do-  let benchmarks = [ b{samples = fromMaybe 100 (repetitions ?config) }-                   | b <- allBenchmarks-                   , select b ]--  whenJust (otMemoryProfiling ?config) $ \eventlogDir ->-      createDirectoryIfMissing True eventlogDir--  results <- forM benchmarks $ \b@Bench{name} -> do-                let run = runSessionWithConfig conf (cmd name dir) lspTestCaps dir-                (b,) <$> runBench run b--  -- output raw data as CSV-  let headers =-        [ "name"-        , "success"-        , "samples"-        , "startup"-        , "setup"-        , "userTime"-        , "delayedTime"-        , "firstBuildTime"-        , "averageTimePerResponse"-        , "totalTime"-        , "buildRulesBuilt"-        , "buildRulesChanged"-        , "buildRulesVisited"-        , "buildRulesTotal"-        , "buildEdges"-        , "ghcRebuilds"-        ]-      rows =-        [ [ name,-            show success,-            show samples,-            show startup,-            show runSetup',-            show userWaits,-            show delayedWork,-            show $ firstResponse+firstResponseDelayed,-            -- Exclude first response as it has a lot of setup time included-            -- Assume that number of requests = number of modules * number of samples-            show ((userWaits - firstResponse)/((fromIntegral samples - 1)*modules)),-            show runExperiment,-            show rulesBuilt,-            show rulesChanged,-            show rulesVisited,-            show rulesTotal,-            show edgesTotal,-            show rebuildsTotal-          ]-          | (Bench {name, samples}, BenchRun {..}) <- results,-            let runSetup' = if runSetup < 0.01 then 0 else runSetup-                modules = fromIntegral $ length $ exampleModules $ example ?config-        ]-      csv = unlines $ map (intercalate ", ") (headers : rows)-  writeFile (outputCSV ?config) csv--  -- print a nice table-  let pads = map (maximum . map length) (transpose (headers : rowsHuman))-      paddedHeaders = zipWith pad pads headers-      outputRow = putStrLn . intercalate " | "-      rowsHuman =-        [ [ name,-            show success,-            show samples,-            showDuration startup,-            showDuration runSetup',-            showDuration userWaits,-            showDuration delayedWork,-            showDuration firstResponse,-            showDuration runExperiment,-            show rulesBuilt,-            show rulesChanged,-            show rulesVisited,-            show rulesTotal,-            show edgesTotal,-            show rebuildsTotal-          ]-          | (Bench {name, samples}, BenchRun {..}) <- results,-            let runSetup' = if runSetup < 0.01 then 0 else runSetup-        ]-  outputRow paddedHeaders-  outputRow $ (map . map) (const '-') paddedHeaders-  forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row-  where-    ghcideCmd dir =-        [ ghcide ?config,-          "--lsp",-          "--test",-          "--cwd",-          dir,-          "+RTS"-        ]-    cmd name dir =-      unwords $-            ghcideCmd dir-          ++ case otMemoryProfiling ?config of-            Just dir -> ["-l", "-ol" ++ (dir </> map (\c -> if c == ' ' then '-' else c) name <.> "eventlog")]-            Nothing -> []-          ++ [ "-RTS" ]-          ++ ghcideOptions ?config-          ++ concat-            [ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config]-            ]-          ++ ["--verbose" | verbose ?config]-          ++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]]-    lspTestCaps =-      fullCaps {_window = Just $ WindowClientCapabilities (Just True) Nothing Nothing }-    conf =-      defaultConfig-        { logStdErr = verbose ?config,-          logMessages = verbose ?config,-          logColor = False,-          messageTimeout = timeoutLsp ?config-        }--data BenchRun = BenchRun-  { startup       :: !Seconds,-    runSetup      :: !Seconds,-    runExperiment :: !Seconds,-    userWaits     :: !Seconds,-    delayedWork   :: !Seconds,-    firstResponse :: !Seconds,-    firstResponseDelayed :: !Seconds,-    rulesBuilt    :: !Int,-    rulesChanged  :: !Int,-    rulesVisited  :: !Int,-    rulesTotal    :: !Int,-    edgesTotal    :: !Int,-    rebuildsTotal :: !Int,-    success       :: !Bool-  }--badRun :: BenchRun-badRun = BenchRun 0 0 0 0 0 0 0 0 0 0 0 0 0 False--waitForProgressStart :: Session ()-waitForProgressStart = void $ do-    skipManyTill anyMessage $ satisfy $ \case-      FromServerMess SWindowWorkDoneProgressCreate _ -> True-      _                                              -> False---- | Wait for all progress to be done--- Needs at least one progress done notification to return-waitForProgressDone :: Session ()-waitForProgressDone = loop-  where-    loop = do-      ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case-        FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just ()-        _ -> Nothing-      done <- null <$> getIncompleteProgressSessions-      unless done loop---- | Wait for the build queue to be empty-waitForBuildQueue :: Session Seconds-waitForBuildQueue = do-    let m = SCustomMethod "test"-    waitId <- sendRequest m (toJSON WaitForShakeQueue)-    (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId-    case resp of-        ResponseMessage{_result=Right Null} -> return td-        -- assume a ghcide binary lacking the WaitForShakeQueue method-        _                                   -> return 0--runBench ::-  (?config :: Config) =>-  (Session BenchRun -> IO BenchRun) ->-  Bench ->-  IO BenchRun-runBench runSess b = handleAny (\e -> print e >> return badRun)-  $ runSess-  $ do-    case b of-     Bench{..} -> do-      (startup, docs) <- duration $ do-        (d, docs) <- duration $ setupDocumentContents ?config-        output $ "Setting up document contents took " <> showDuration d-        -- wait again, as the progress is restarted once while loading the cradle-        -- make an edit, to ensure this doesn't block-        let DocumentPositions{..} = head docs-        changeDoc doc [charEdit stringLiteralP]-        waitForProgressDone-        return docs--      liftIO $ output $ "Running " <> name <> " benchmark"-      (runSetup, ()) <- duration $ benchSetup docs-      let loop' (Just timeForFirstResponse) !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork, timeForFirstResponse)-          loop' timeForFirstResponse !userWaits !delayedWork n = do-            (t, res) <- duration $ experiment docs-            if not res-              then return Nothing-            else do-                output (showDuration t)-                -- Wait for the delayed actions to finish-                td <- waitForBuildQueue-                loop' (timeForFirstResponse <|> (Just (t,td))) (userWaits+t) (delayedWork+td) (n -1)-          loop = loop' Nothing--      (runExperiment, result) <- duration $ loop 0 0 samples-      let success = isJust result-          (userWaits, delayedWork, (firstResponse, firstResponseDelayed)) = fromMaybe (0,0,(0,0)) result--      rulesTotal <- length <$> getStoredKeys-      rulesBuilt <- either (const 0) length <$> getBuildKeysBuilt-      rulesChanged <- either (const 0) length <$> getBuildKeysChanged-      rulesVisited <- either (const 0) length <$> getBuildKeysVisited-      edgesTotal   <- fromRight 0 <$> getBuildEdgesCount-      rebuildsTotal <- fromRight 0 <$> getRebuildsCount--      return BenchRun {..}--data SetupResult = SetupResult {-    runBenchmarks :: [Bench] -> IO (),-    -- | Path to the setup benchmark example-    benchDir      :: FilePath,-    cleanUp       :: IO ()-}--callCommandLogging :: HasConfig => String -> IO ()-callCommandLogging cmd = do-    output cmd-    callCommand cmd--setup :: HasConfig => IO SetupResult-setup = do---   when alreadyExists $ removeDirectoryRecursive examplesPath-  benchDir <- case exampleDetails(example ?config) of-      Left examplePath -> do-          let hieYamlPath = examplePath </> "hie.yaml"-          alreadyExists <- doesFileExist hieYamlPath-          unless alreadyExists $-                cmd_ (Cwd examplePath) (FileStdout hieYamlPath) ("gen-hie"::String)-          return examplePath-      Right ExamplePackage{..} -> do-        let path = examplesPath </> package-            package = packageName <> "-" <> showVersion packageVersion-            hieYamlPath = path </> "hie.yaml"-        alreadySetup <- doesDirectoryExist path-        unless alreadySetup $-          case buildTool ?config of-            Cabal -> do-                let cabalVerbosity = "-v" ++ show (fromEnum (verbose ?config))-                callCommandLogging $ "cabal get " <> cabalVerbosity <> " " <> package <> " -d " <> examplesPath-                let hieYamlPath = path </> "hie.yaml"-                cmd_ (Cwd path) (FileStdout hieYamlPath) ("gen-hie"::String)-                -- Need this in case there is a parent cabal.project somewhere-                writeFile-                    (path </> "cabal.project")-                    "packages: ."-                writeFile-                    (path </> "cabal.project.local")-                    ""-            Stack -> do-                let stackVerbosity = case verbosity ?config of-                        Quiet  -> "--silent"-                        Normal -> ""-                        All    -> "--verbose"-                callCommandLogging $ "stack " <> stackVerbosity <> " unpack " <> package <> " --to " <> examplesPath-                -- Generate the stack descriptor to match the one used to build ghcide-                stack_yaml <- fromMaybe "stack.yaml" <$> getEnv "STACK_YAML"-                stack_yaml_lines <- lines <$> readFile stack_yaml-                writeFile (path </> stack_yaml)-                        (unlines $-                        "packages: [.]" :-                            [ l-                            | l <- stack_yaml_lines-                            , any (`isPrefixOf` l)-                                ["resolver"-                                ,"allow-newer"-                                ,"compiler"]-                            ]-                        )--                cmd_ (Cwd path) (FileStdout hieYamlPath) ("gen-hie"::String) ["--stack"::String]-        return path--  whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True--  let cleanUp = case exampleDetails(example ?config) of-        Right _ -> removeDirectoryRecursive examplesPath-        Left _  -> return ()--      runBenchmarks = runBenchmarksFun benchDir--  return SetupResult{..}--setupDocumentContents :: Config -> Session [DocumentPositions]-setupDocumentContents config =-        forM (exampleModules $ example config) $ \m -> do-        doc <- openDoc m "haskell"--        -- Setup the special positions used by the experiments-        lastLine <- fromIntegral . length . T.lines <$> documentContents doc-        changeDoc doc [TextDocumentContentChangeEvent-            { _range = Just (Range (Position lastLine 0) (Position lastLine 0))-            , _rangeLength = Nothing-            , _text = T.unlines [ "_hygienic = \"hygienic\"" ]-            }]-        let-        -- Points to a string in the target file,-        -- convenient for hygienic edits-            stringLiteralP = Position lastLine 15--        -- Find an identifier defined in another file in this project-        symbols <- getDocumentSymbols doc-        let endOfImports = case symbols of-                Left symbols | Just x <- findEndOfImports symbols -> x-                _ -> error $ "symbols: " <> show symbols-        contents <- documentContents doc-        identifierP <- searchSymbol doc contents endOfImports-        return $ DocumentPositions{..}--findEndOfImports :: [DocumentSymbol] -> Maybe Position-findEndOfImports (DocumentSymbol{_kind = SkModule, _name = "imports", _range} : _) =-    Just $ Position (succ $ _line $ _end _range) 4-findEndOfImports [DocumentSymbol{_kind = SkFile, _children = Just (List cc)}] =-    findEndOfImports cc-findEndOfImports (DocumentSymbol{_range} : _) =-    Just $ _start _range-findEndOfImports _ = Nothing------------------------------------------------------------------------------------------------pad :: Int -> String -> String-pad n []     = replicate n ' '-pad 0 _      = error "pad"-pad n (x:xx) = x : pad (n-1) xx---- | Search for a position where:---     - get definition works and returns a uri other than this file---     - get completions returns a non empty list-searchSymbol :: TextDocumentIdentifier -> T.Text -> Position -> Session (Maybe Position)-searchSymbol doc@TextDocumentIdentifier{_uri} fileContents pos = do-    -- this search is expensive, so we cache the result on disk-    let cachedPath = fromJust (uriToFilePath _uri) <.> "identifierPosition"-    cachedRes <- liftIO $ try @_ @IOException $ read <$> readFile cachedPath-    case cachedRes of-        Left _ -> do-            result <- loop pos-            liftIO $ writeFile cachedPath $ show result-            return result-        Right res ->-            return res-  where-      loop pos-        | (fromIntegral $ _line pos) >= lll =-            return Nothing-        | (fromIntegral $ _character pos) >= lengthOfLine (fromIntegral $ _line pos) =-            loop (nextLine pos)-        | otherwise = do-                checks <- checkDefinitions pos &&^ checkCompletions pos-                if checks-                    then return $ Just pos-                    else loop (nextIdent pos)--      nextIdent p = p{_character = _character p + 2}-      nextLine p = Position (_line p + 1) 4--      lengthOfLine n = if n >= lll then 0 else T.length (ll !! n)-      ll = T.lines fileContents-      lll = length ll--      checkDefinitions pos = do-        defs <- getDefinitions doc pos-        case defs of-            (InL [Location uri _]) -> return $ uri /= _uri-            _                      -> return False-      checkCompletions pos =-        not . null <$> getCompletions doc pos-
− bench/lib/Experiments/Types.hs 
@@ -1,74 +0,0 @@-{-# LANGUAGE DeriveAnyClass     #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE OverloadedStrings  #-}-module Experiments.Types (module Experiments.Types ) where--import           Data.Aeson-import           Data.Maybe                (fromMaybe)-import           Data.Version-import           Development.Shake.Classes-import           GHC.Generics-import           Numeric.Natural--data CabalStack = Cabal | Stack-  deriving (Eq, Show)--data Verbosity = Quiet | Normal | All-  deriving (Eq, Show)-data Config = Config-  { verbosity         :: !Verbosity,-    -- For some reason, the Shake profile files are truncated and won't load-    shakeProfiling    :: !(Maybe FilePath),-    otMemoryProfiling :: !(Maybe FilePath),-    outputCSV         :: !FilePath,-    buildTool         :: !CabalStack,-    ghcideOptions     :: ![String],-    matches           :: ![String],-    repetitions       :: Maybe Natural,-    ghcide            :: FilePath,-    timeoutLsp        :: Int,-    example           :: Example-  }-  deriving (Eq, Show)--data ExamplePackage = ExamplePackage {packageName :: !String, packageVersion :: !Version}-  deriving (Eq, Generic, Show)-  deriving anyclass (Binary, Hashable, NFData)--data Example = Example-    { exampleName      :: !String-    , exampleDetails   :: Either FilePath ExamplePackage-    , exampleModules   :: [FilePath]-    , exampleExtraArgs :: [String]}-  deriving (Eq, Generic, Show)-  deriving anyclass (Binary, Hashable, NFData)--instance FromJSON Example where-    parseJSON = withObject "example" $ \x -> do-        exampleName <- x .: "name"-        exampleModules <- x .: "modules"-        exampleExtraArgs <- fromMaybe [] <$> x .:? "extra-args"--        path <- x .:? "path"-        case path of-            Just examplePath -> do-                let exampleDetails = Left examplePath-                return Example{..}-            Nothing -> do-                packageName <- x .: "package"-                packageVersion <- x .: "version"-                let exampleDetails = Right ExamplePackage{..}-                return Example{..}--exampleToOptions :: Example -> [String] -> [String]-exampleToOptions Example{exampleDetails = Right ExamplePackage{..}, ..} extraArgs =-    ["--example-package-name", packageName-    ,"--example-package-version", showVersion packageVersion-    ,"--ghcide-options", unwords $ exampleExtraArgs ++ extraArgs-    ] ++-    ["--example-module=" <> m | m <- exampleModules]-exampleToOptions Example{exampleDetails = Left examplePath, ..} extraArgs =-    ["--example-path", examplePath-    ,"--ghcide-options", unwords $ exampleExtraArgs ++ extraArgs-    ] ++-    ["--example-module=" <> m | m <- exampleModules]
exe/Arguments.hs view
@@ -15,6 +15,7 @@     ,argsOTMemoryProfiling          :: Bool     ,argsTesting                    :: Bool     ,argsDisableKick                :: Bool+    ,argsVerifyCoreFile             :: Bool     ,argsThreads                    :: Int     ,argsVerbose                    :: Bool     ,argsCommand                    :: Command@@ -36,6 +37,7 @@       <*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect")       <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")       <*> switch (long "test-no-kick" <> help "Disable kick. Useful for testing cancellation")+      <*> switch (long "verify-core-file" <> help "Verify core trips by roundtripping after serialization. Slow, only useful for testing purposes")       <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault)       <*> switch (short 'd' <> long "verbose" <> help "Include internal events in logging output")       <*> (commandP plugins <|> lspCommand <|> checkCommand)
exe/Main.hs view
@@ -1,47 +1,47 @@ -- 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 qualified Development.IDE.Main              as IDEMain-import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde-import           Development.IDE.Types.Logger      (Logger (Logger),-                                                    LoggingColumn (DataColumn, PriorityColumn),-                                                    Pretty (pretty),-                                                    Priority (Debug, Info, Error),-                                                    Recorder (Recorder),-                                                    WithPriority (WithPriority, priority),-                                                    cfilter, cmapWithPrio,-                                                    makeDefaultStderrRecorder, layoutPretty, renderStrict, defaultLayoutOptions)-import qualified Development.IDE.Types.Logger      as Logger+import           Arguments                                (Arguments (..),+                                                           getArguments)+import           Control.Monad.IO.Class                   (liftIO)+import           Data.Default                             (def)+import           Data.Function                            ((&))+import           Data.Version                             (showVersion)+import           Development.GitRev                       (gitHash)+import           Development.IDE.Core.Rules               (mainRule)+import qualified Development.IDE.Core.Rules               as Rules+import           Development.IDE.Core.Tracing             (withTelemetryRecorder)+import qualified Development.IDE.Main                     as IDEMain+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           Language.LSP.Server               as LSP-import           Language.LSP.Types                as LSP-import           Ide.Plugin.Config                 (Config (checkParents, checkProject))-import           Ide.PluginUtils                   (pluginDescToIdePlugins)-import           Ide.Types                         (PluginDescriptor (pluginNotificationHandlers), defaultPluginDescriptor, mkPluginNotificationHandler)-import           Paths_ghcide                      (version)-import qualified System.Directory.Extra            as IO-import           System.Environment                (getExecutablePath)-import           System.Exit                       (exitSuccess)-import           System.IO                         (hPutStrLn, stderr)-import           System.Info                       (compilerVersion)+import           Ide.Logger                               (LoggingColumn (..),+                                                           Pretty (pretty),+                                                           Priority (Debug, Error, Info),+                                                           WithPriority (WithPriority, priority),+                                                           cfilter,+                                                           cmapWithPrio,+                                                           defaultLayoutOptions,+                                                           layoutPretty,+                                                           makeDefaultStderrRecorder,+                                                           renderStrict)+import qualified Ide.Logger                               as Logger+import           Ide.Plugin.Config                        (Config (checkParents, checkProject))+import           Ide.PluginUtils                          (pluginDescToIdePlugins)+import           Ide.Types                                (PluginDescriptor (pluginNotificationHandlers),+                                                           defaultPluginDescriptor,+                                                           mkPluginNotificationHandler)+import           Language.LSP.Protocol.Message            as LSP+import           Language.LSP.Server                      as LSP+import           Paths_ghcide                             (version)+import qualified System.Directory.Extra                   as IO+import           System.Environment                       (getExecutablePath)+import           System.Exit                              (exitSuccess)+import           System.Info                              (compilerVersion)+import           System.IO                                (hPutStrLn, stderr)  data Log   = LogIDEMain IDEMain.Log@@ -66,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]) Info+      <$> makeDefaultStderrRecorder (Just [ThreadIdColumn, PriorityColumn, DataColumn])      let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde pluginCliRecorder))     -- WARNING: If you write to stdout before runLanguageServer@@ -87,14 +87,14 @@      let minPriority = if argsVerbose then Debug else Info -    docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) minPriority+    docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn])      (lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder     (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")-          { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SInitialized $ \_ _ _ _ -> do+    let lspRecorderPlugin = (defaultPluginDescriptor "LSPRecorderCallback" "Internal plugin")+          { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SMethod_Initialized $ \_ _ _ _ -> do               env <- LSP.getLspEnv               liftIO $ (cb1 <> cb2) env           }@@ -104,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-          else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) logger+          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) @@ -137,9 +129,10 @@             let defOptions = IDEMain.argsIdeOptions arguments config sessionLoader             in defOptions                 { optShakeProfiling = argsShakeProfiling-                , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling                 , optCheckParents = pure $ checkParents config                 , optCheckProject = pure $ checkProject config                 , optRunSubset = not argsConservativeChangeTracking+                , optVerifyCoreFile = argsVerifyCoreFile                 }+        , IDEMain.argsMonitoring = OpenTelemetry.monitoring         }
ghcide.cabal view
@@ -1,504 +1,255 @@-cabal-version:      2.4+cabal-version:      3.4 build-type:         Simple category:           Development name:               ghcide-version:            1.7.0.0+version:            2.14.0.0 license:            Apache-2.0 license-file:       LICENSE author:             Digital Asset and Ghcide contributors maintainer:         Ghcide contributors copyright:          Digital Asset and Ghcide contributors 2018-2020 synopsis:           The core of an IDE-description:-    A library for building Haskell IDE's on top of the GHC API.-homepage:           https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme+description:        A library for building Haskell IDE's on top of the GHC API.+homepage:+  https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme+ bug-reports:        https://github.com/haskell/haskell-language-server/issues-tested-with:        GHC == 8.6.5 || == 8.8.4 || == 8.10.6 || == 8.10.7 || == 9.0.1 || == 9.0.2 || == 9.2.1 || == 9.2.2-extra-source-files: README.md CHANGELOG.md-                    test/data/**/*.project-                    test/data/**/*.cabal-                    test/data/**/*.yaml-                    test/data/**/*.hs-                    test/data/**/*.hs-boot+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  source-repository head-    type:     git-    location: https://github.com/haskell/haskell-language-server.git--flag ghc-patched-unboxed-bytecode-    description: The GHC version we link against supports unboxed sums and tuples in bytecode-    default:     False-    manual:      True--library-    default-language:   Haskell2010-    build-depends:-        aeson,-        aeson-pretty,-        array,-        async,-        base == 4.*,-        binary,-        bytestring,-        case-insensitive,-        containers,-        data-default,-        deepseq,-        directory,-        dependent-map,-        dependent-sum,-        dlist,-        exceptions,-        extra >= 1.7.4,-        enummapset,-        filepath,-        fingertree,-        focus,-        ghc-exactprint,-        ghc-trace-events,-        Glob,-        haddock-library >= 1.8 && < 1.11,-        hashable,-        hie-compat ^>= 0.2.0.0,-        hls-plugin-api ^>= 1.4,-        lens,-        list-t,-        hiedb == 0.4.1.*,-        lsp-types ^>= 1.4.0.1,-        lsp ^>= 1.4.0.0 ,-        monoid-subclasses,-        mtl,-        network-uri,-        optparse-applicative,-        parallel,-        prettyprinter-ansi-terminal,-        prettyprinter,-        random,-        regex-tdfa >= 1.3.1.0,-        retrie,-        rope-utf16-splay,-        safe,-        safe-exceptions,-        hls-graph ^>= 1.7,-        sorted-list,-        sqlite-simple,-        stm,-        stm-containers,-        syb,-        text,-        time,-        transformers,-        unordered-containers >= 0.2.10.0,-        utf8-string,-        vector,-        vector-algorithms,-        hslogger,-        Diff ^>=0.4.0,-        vector,-        opentelemetry >=0.6.1,-        heapsize ==0.3.*,-        unliftio,-        unliftio-core,-        ghc-boot-th,-        ghc-boot,-        ghc >= 8.6,-        ghc-check >=0.5.0.4,-        ghc-paths,-        cryptohash-sha1 >=0.11.100 && <0.12,-        hie-bios ^>= 0.9.1,-        implicit-hie-cradle ^>= 0.3.0.5 || ^>= 0.5,-        base16-bytestring >=0.1.1 && <1.1-    if os(windows)-      build-depends:-        Win32-    else-      build-depends:-        unix--    default-extensions:-        BangPatterns-        DeriveFunctor-        DeriveGeneric-        DeriveFoldable-        DeriveTraversable-        FlexibleContexts-        GeneralizedNewtypeDeriving-        LambdaCase-        NamedFieldPuns-        OverloadedStrings-        RecordWildCards-        ScopedTypeVariables-        StandaloneDeriving-        TupleSections-        TypeApplications-        ViewPatterns-        DataKinds-        TypeOperators-        KindSignatures--    hs-source-dirs:-        src-        session-loader-    exposed-modules:-        Control.Concurrent.Strict-        Generics.SYB.GHC-        Development.IDE-        Development.IDE.Main-        Development.IDE.Core.Actions-        Development.IDE.Main.HeapStats-        Development.IDE.Core.Debouncer-        Development.IDE.Core.FileStore-        Development.IDE.Core.FileUtils-        Development.IDE.Core.IdeConfiguration-        Development.IDE.Core.OfInterest-        Development.IDE.Core.PositionMapping-        Development.IDE.Core.Preprocessor-        Development.IDE.Core.ProgressReporting-        Development.IDE.Core.Rules-        Development.IDE.Core.RuleTypes-        Development.IDE.Core.Service-        Development.IDE.Core.Shake-        Development.IDE.Core.Tracing-        Development.IDE.Core.UseStale-        Development.IDE.GHC.Compat-        Development.IDE.GHC.Compat.Core-        Development.IDE.GHC.Compat.Env-        Development.IDE.GHC.Compat.ExactPrint-        Development.IDE.GHC.Compat.Iface-        Development.IDE.GHC.Compat.Logger-        Development.IDE.GHC.Compat.Outputable-        Development.IDE.GHC.Compat.Parser-        Development.IDE.GHC.Compat.Plugins-        Development.IDE.GHC.Compat.Units-        Development.IDE.GHC.Compat.Util-        Development.IDE.Core.Compile-        Development.IDE.GHC.Dump-        Development.IDE.GHC.Error-        Development.IDE.GHC.ExactPrint-        Development.IDE.GHC.Orphans-        Development.IDE.GHC.Util-        Development.IDE.Import.DependencyInformation-        Development.IDE.Import.FindImports-        Development.IDE.LSP.HoverDefinition-        Development.IDE.LSP.LanguageServer-        Development.IDE.LSP.Outline-        Development.IDE.LSP.Server-        Development.IDE.Session-        Development.IDE.Spans.Common-        Development.IDE.Spans.Documentation-        Development.IDE.Spans.AtPoint-        Development.IDE.Spans.LocalBindings-        Development.IDE.Spans.Pragmas-        Development.IDE.Types.Diagnostics-        Development.IDE.Types.Exports-        Development.IDE.Types.HscEnvEq-        Development.IDE.Types.KnownTargets-        Development.IDE.Types.Location-        Development.IDE.Types.Logger-        Development.IDE.Types.Options-        Development.IDE.Types.Shake-        Development.IDE.Plugin-        Development.IDE.Plugin.Completions-        Development.IDE.Plugin.Completions.Types-        Development.IDE.Plugin.CodeAction-        Development.IDE.Plugin.CodeAction.ExactPrint-        Development.IDE.Plugin.HLS-        Development.IDE.Plugin.HLS.GhcIde-        Development.IDE.Plugin.Test-        Development.IDE.Plugin.TypeLenses-        Text.Fuzzy.Parallel+  type:     git+  location: https://github.com/haskell/haskell-language-server.git -    other-modules:-        Development.IDE.Core.FileExists-        Development.IDE.GHC.CPP-        Development.IDE.GHC.Warnings-        Development.IDE.LSP.Notifications-        Development.IDE.Plugin.CodeAction.PositionIndexed-        Development.IDE.Plugin.CodeAction.Args-        Development.IDE.Plugin.Completions.Logic-        Development.IDE.Session.VersionCheck-        Development.IDE.Types.Action+flag pedantic+  description: Enable -Werror+  default:     False+  manual:      True -    ghc-options:-                -Wall-                -Wno-name-shadowing-                -Wincomplete-uni-patterns-                -Wno-unticked-promoted-constructors-                -fno-ignore-asserts+common warnings+  ghc-options:+    -Werror=incomplete-patterns+    -Wall+    -Wincomplete-uni-patterns+    -Wunused-packages+    -Wno-name-shadowing+    -Wno-unticked-promoted-constructors+    -fno-ignore-asserts -    if flag(ghc-patched-unboxed-bytecode)-      cpp-options: -DGHC_PATCHED_UNBOXED_BYTECODE+library+  import: warnings+  default-language:   GHC2021+  build-depends:+    , aeson+    , array+    , async+    , base                         >=4.16     && <5+    , base16-bytestring            >=0.1.1    && <1.1+    , binary+    , bytestring+    , case-insensitive+    , co-log-core+    , containers+    , cryptohash-sha1              >=0.11.100 && <0.12+    , data-default+    , deepseq+    , dependent-map+    , dependent-sum+    , 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.2+    , ghc-boot+    , ghc-boot-th+    , ghc-trace-events+    , Glob+    , haddock-library              >=1.8      && <1.12+    , hashable+    , 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.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+    , safe-exceptions+    , sorted-list+    , sqlite-simple+    , stm+    , stm-containers+    , syb+    , text+    , text-rope+    , time+    , transformers+    , unliftio                     >=0.2.6+    , unliftio-core+    , unordered-containers         >=0.2.21+    , vector -    if impl(ghc < 8.10)-      exposed-modules:-        Development.IDE.GHC.Compat.CPP+  if os(windows)+    build-depends: Win32 -flag test-exe-    description: Build the ghcide-test-preprocessor executable-    default: True+  else+    build-depends: unix -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.*+  default-extensions:+    DataKinds+    ExplicitNamespaces+    LambdaCase+    OverloadedStrings+    RecordWildCards+    ViewPatterns -    if !flag(test-exe)-        buildable: False+  hs-source-dirs:     src session-loader+  exposed-modules:+    Control.Concurrent.Strict+    Development.IDE+    Development.IDE.Core.Actions+    Development.IDE.Core.Compile+    Development.IDE.Core.Debouncer+    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+    Development.IDE.Core.Preprocessor+    Development.IDE.Core.ProgressReporting+    Development.IDE.Core.Rules+    Development.IDE.Core.RuleTypes+    Development.IDE.Core.Service+    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+    Development.IDE.GHC.Compat.Parser+    Development.IDE.GHC.Compat.Plugins+    Development.IDE.GHC.Compat.Units+    Development.IDE.GHC.Compat.Util+    Development.IDE.GHC.CoreFile+    Development.IDE.GHC.Error+    Development.IDE.GHC.Orphans+    Development.IDE.GHC.Util+    Development.IDE.Import.DependencyInformation+    Development.IDE.Import.FindImports+    Development.IDE.LSP.HoverDefinition+    Development.IDE.LSP.LanguageServer+    Development.IDE.LSP.Notifications+    Development.IDE.LSP.Outline+    Development.IDE.LSP.Server+    Development.IDE.Main+    Development.IDE.Main.HeapStats+    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+    Development.IDE.Spans.LocalBindings+    Development.IDE.Spans.Pragmas+    Development.IDE.Types.Diagnostics+    Development.IDE.Types.Exports+    Development.IDE.Types.HscEnvEq+    Development.IDE.Types.KnownTargets+    Development.IDE.Types.Location+    Development.IDE.Types.Monitoring+    Development.IDE.Types.Options+    Development.IDE.Types.Shake+    Generics.SYB.GHC+    Text.Fuzzy.Parallel+    Text.Fuzzy.Levenshtein -benchmark benchHist-    type: exitcode-stdio-1.0-    default-language: Haskell2010-    ghc-options: -Wall -Wno-name-shadowing -threaded-    main-is: Main.hs-    hs-source-dirs: bench/hist bench/lib-    other-modules: Experiments.Types-    build-tool-depends:-        ghcide:ghcide-bench,-        hp2pretty:hp2pretty,-        implicit-hie:gen-hie-    default-extensions:-        BangPatterns-        DeriveFunctor-        DeriveGeneric-        FlexibleContexts-        GeneralizedNewtypeDeriving-        LambdaCase-        NamedFieldPuns-        RecordWildCards-        ScopedTypeVariables-        StandaloneDeriving-        TupleSections-        TypeApplications-        ViewPatterns+  other-modules:+    Development.IDE.Core.FileExists+    Development.IDE.GHC.CPP+    Development.IDE.GHC.Warnings+    Development.IDE.Types.Action+    Development.IDE.Session.OrderedSet -    build-depends:-        aeson,-        base == 4.*,-        shake-bench == 0.1.*,-        directory,-        extra,-        filepath,-        lens,-        optparse-applicative,-        shake,-        text,-        yaml+  if flag(pedantic)+    ghc-options:+      -Werror  flag executable-    description: Build the ghcide executable-    default: True+  description: Build the ghcide executable+  default:     True  executable ghcide-    default-language:   Haskell2010-    hs-source-dirs:     exe-    ghc-options:-                -threaded-                -Wall-                -Wincomplete-uni-patterns-                -Wno-name-shadowing-                -- allow user RTS overrides-                -rtsopts-                -- disable idle GC-                -- increase nursery size-                -- Enable collection of heap statistics-                "-with-rtsopts=-I0 -A128M -T"-    main-is: Main.hs-    build-depends:-        hiedb,-        aeson,-        base == 4.*,-        data-default,-        directory,-        extra,-        filepath,-        gitrev,-        safe-exceptions,-        ghc,-        hashable,-        lsp,-        lsp-types,-        heapsize,-        hie-bios,-        hls-plugin-api,-        ghcide,-        lens,-        optparse-applicative,-        hls-graph,-        text,-        unordered-containers,-    other-modules:-        Arguments-        Paths_ghcide-    autogen-modules:-        Paths_ghcide+  import: warnings+  default-language:   GHC2021+  hs-source-dirs:     exe+  ghc-options:        -threaded -rtsopts "-with-rtsopts=-I0 -A128M -T" -    default-extensions:-        BangPatterns-        DeriveFunctor-        DeriveGeneric-        FlexibleContexts-        GeneralizedNewtypeDeriving-        LambdaCase-        NamedFieldPuns-        OverloadedStrings-        RecordWildCards-        ScopedTypeVariables-        StandaloneDeriving-        TupleSections-        TypeApplications-        ViewPatterns -    if !flag(executable)-        buildable: False--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,-        binary,-        bytestring,-        containers,-        data-default,-        directory,-        extra,-        filepath,-        fuzzy,-        ---------------------------------------------------------------        -- 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.-        ghc,-        ---------------------------------------------------------------        ghcide,-        ghc-typelits-knownnat,-        haddock-library,-        lsp,-        lsp-types,-        hls-plugin-api,-        lens,-        list-t,-        lsp-test ^>= 0.14,-        monoid-subclasses,-        network-uri,-        optparse-applicative,-        parallel,-        process,-        QuickCheck,-        quickcheck-instances,-        random,-        rope-utf16-splay,-        regex-tdfa ^>= 1.3.1,-        safe,-        safe-exceptions,-        shake,-        sqlite-simple,-        stm,-        stm-containers,-        hls-graph,-        tasty,-        tasty-expected-failure,-        tasty-hunit,-        tasty-quickcheck,-        tasty-rerun,-        text,-        unordered-containers,-        vector,-    if (impl(ghc >= 8.6) && impl(ghc < 9.2))-      build-depends:-          record-dot-preprocessor,-          record-hasfield-    hs-source-dirs: test/cabal test/exe test/src bench/lib-    ghc-options: -threaded -Wall -Wno-name-shadowing -O0 -Wno-unticked-promoted-constructors-    main-is: Main.hs-    other-modules:-        Development.IDE.Test-        Development.IDE.Test.Diagnostic-        Development.IDE.Test.Runfiles-        Experiments-        Experiments.Types-        FuzzySearch-        Progress-        HieDbRetry-    default-extensions:-        BangPatterns-        DeriveFunctor-        DeriveGeneric-        FlexibleContexts-        GeneralizedNewtypeDeriving-        LambdaCase-        NamedFieldPuns-        OverloadedStrings-        RecordWildCards-        ScopedTypeVariables-        StandaloneDeriving-        TupleSections-        TypeApplications-        ViewPatterns+  -- allow user RTS overrides+  -- disable idle GC+  -- increase nursery size+  -- Enable collection of heap statistics+  main-is:            Main.hs+  build-depends:+    , base                  >=4.16 && <5+    , data-default+    , extra+    , ghcide+    , gitrev+    , hls-plugin-api+    , lsp+    , lsp-types+    , optparse-applicative -flag bench-exe-    description: Build the ghcide-bench executable-    default: True+  other-modules:+    Arguments+    Paths_ghcide -executable ghcide-bench-    default-language: Haskell2010-    build-tool-depends:-        ghcide:ghcide-    build-depends:-        aeson,-        base,-        bytestring,-        containers,-        data-default,-        directory,-        extra,-        filepath,-        ghcide,-        hls-plugin-api,-        lens,-        lsp-test,-        lsp-types,-        optparse-applicative,-        process,-        safe-exceptions,-        hls-graph,-        shake,-        tasty-hunit,-        text-    hs-source-dirs: bench/lib bench/exe test/src-    ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts-    main-is: Main.hs-    other-modules:-        Development.IDE.Test-        Development.IDE.Test.Diagnostic-        Experiments-        Experiments.Types-    default-extensions:-        BangPatterns-        DeriveFunctor-        DeriveGeneric-        FlexibleContexts-        GeneralizedNewtypeDeriving-        LambdaCase-        NamedFieldPuns-        OverloadedStrings-        RecordWildCards-        ScopedTypeVariables-        StandaloneDeriving-        TupleSections-        TypeApplications-        ViewPatterns+  autogen-modules:    Paths_ghcide+  default-extensions:+    LambdaCase+    OverloadedStrings+    RecordWildCards+    ViewPatterns -    if !flag(bench-exe)-        buildable: False+  if !flag(executable)+    buildable: False
session-loader/Development/IDE/Session.hs view
@@ -1,1083 +1,1139 @@-{-# 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 qualified Data.HashMap.Strict                  as HM-import           Data.Hashable-import           Data.IORef-import           Data.List-import qualified Data.Map.Strict                      as Map-import           Data.Maybe-import qualified Data.Text                            as T-import           Data.Time.Clock-import           Data.Version-import           Development.IDE.Core.RuleTypes-import           Development.IDE.Core.Shake           hiding (Log, Priority,-                                                       withHieDb)-import qualified Development.IDE.GHC.Compat           as Compat-import           Development.IDE.GHC.Compat.Core      hiding (Target,-                                                       TargetFile, TargetModule,-                                                       Var, Warning)-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.Logger         (Pretty (pretty),-                                                       Priority (Debug, Error, Info, Warning),-                                                       Recorder, WithPriority,-                                                       logWith, nest, vcat,-                                                       viaShow, (<+>))-import           Development.IDE.Types.Options-import           GHC.Check-import qualified HIE.Bios                             as HieBios-import           HIE.Bios.Environment                 hiding (getCacheDir)-import           HIE.Bios.Types-import           Hie.Implicit.Cradle                  (loadImplicitHieCradle)-import           Language.LSP.Server-import           Language.LSP.Types-import           System.Directory-import qualified System.Directory.Extra               as IO-import           System.FilePath-import           System.Info--import           Control.Applicative                  (Alternative ((<|>)))-import           Data.Void--import           Control.Concurrent.STM.Stats         (atomically, modifyTVar',-                                                       readTVar, writeTVar)-import           Control.Concurrent.STM.TQueue-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.Types.Shake          (WithHieDb)-import           HieDb.Create-import           HieDb.Types-import           HieDb.Utils-import           System.Random                        (RandomGen)-import qualified System.Random                        as Random-import Control.Monad.IO.Unlift (MonadUnliftIO)--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)-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 maxRetryCount e ->-      nest 2 $-        vcat-          [ "Retrying hiedb action..."-          , "delay:" <+> pretty delay-          , "maximum delay:" <+> pretty maxDelay-          , "retries remaining:" <+> pretty maxRetryCount-          , "SQLite error:" <+> pretty (displayException e) ]-    LogHieDbRetriesExhausted baseDelay maxDelay maxRetryCount e ->-      nest 2 $-        vcat-          [ "Retries exhausted for hiedb action."-          , "base delay:" <+> pretty baseDelay-          , "maximum delay:" <+> pretty maxDelay-          , "retries remaining:" <+> pretty maxRetryCount-          , "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---- | 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)-  , 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-  }--instance Default SessionLoadingOptions where-    def =  SessionLoadingOptions-        {findCradle = HieBios.findCradle-        ,loadCradle = loadWithImplicitCradle-        ,getCacheDirs = getCacheDirsDefault-        ,getInitialGhcLibDir = getInitialGhcLibDirDefault-        ,fakeUid = Compat.toUnitId (Compat.stringToUnit "main")-        }---- | 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-  let log = logWith recorder-  hieYaml <- findCradle def rootDir-  cradle <- loadCradle def hieYaml rootDir-  libDirRes <- getRuntimeGhcLibDir cradle-  case libDirRes of-      CradleSuccess libdir -> pure $ Just $ LibDir libdir-      CradleFail err -> do-        log Error $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle-        pure Nothing-      CradleNone -> do-        log 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 !maxRetryCount rng action = do-  result <- tryJust exceptionPred action-  case result of-    Left e-      | maxRetryCount > 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 newMaxRetryCount = maxRetryCount - 1-        liftIO $ do-          log Warning $ LogHieDbRetry delay maxDelay newMaxRetryCount (toException e)-          threadDelay delay-        retryOnException exceptionPred recorder maxDelay newBaseDelay newMaxRetryCount newRng action--      | otherwise -> do-        liftIO $ do-          log Warning $ LogHieDbRetriesExhausted baseDelay maxDelay maxRetryCount (toException e)-          throwIO e--    Right b -> pure b-  where-    log = logWith recorder---- | 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. `withWriteDbRetrable 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-    log = logWith recorder--    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-        k <- atomically $ readTQueue chan-        -- TODO: probably should let exceptions be caught/logged/handled by top level handler-        k withHieDbRetryable-          `Safe.catch` \e@SQLError{} -> do-            log Error $ LogHieDbWriterThreadSQLiteError e-          `Safe.catchAny` \e -> do-            log Error $ LogHieDbWriterThreadException e---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 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 new_deps--              new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do-                  -- Remove all inplace dependencies from package flags for-                  -- components in this HscEnv-                  let (df2, uids) = removeInplacePackages fakeUid inplace rawComponentDynFlags-                  let prefix = show rawComponentUnitId-                  -- See Note [Avoiding bad interface files]-                  let hscComponents = sort $ map show uids-                      cacheDirOpts = hscComponents ++ componentOptions opts-                  cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts-                  processed_df <- setCacheDirs 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-              log Info $ LogMakingNewHscEnv inplace-              hscEnv <- emptyHscEnv ideNc libDir-              newHscEnv <--                -- Add the options for the current component to the HscEnv-                evalGhcEnv hscEnv $ do-                  _ <- setSessionDynFlags $ setHomeUnitId_ fakeUid df-                  getSession--              -- Modify the map so the hieYaml now maps to the newly created-              -- HscEnv-              -- Returns-              -- . the new HscEnv so it can be used to modify the-              --   FilePath -> HscEnv map (fileToFlags)-              -- . The information for the new component which caused this cache miss-              -- . The modified information (without -inplace flags) for-              --   existing packages-              pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps'))---    let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)-                -> IO (IdeResult HscEnvEq,[FilePath])-        session args@(hieYaml, _cfp, _opts, _libDir) = do-          (hscEnv, new, old_deps) <- packageSetup args--          -- Whenever we spin up a session on Linux, dynamically load libm.so.6-          -- in. We need this in case the binary is statically linked, in which-          -- case the interactive session will fail when trying to load-          -- ghc-prim, which happens whenever Template Haskell is being-          -- evaluated or haskell-language-server's eval plugin tries to run-          -- some code. If the binary is dynamically linked, then this will have-          -- no effect.-          -- See https://github.com/haskell/haskell-language-server/issues/221-          when (os == "linux") $ do-            initObjLinker hscEnv-            res <- loadDLL hscEnv "libm.so.6"-            case res of-              Nothing  -> pure ()-              Just err -> log 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-                    extras <- getShakeExtras-                    let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces-                    liftIO $ atomically $ modifyTVar' (exportsMap extras) (exportsMap' <>)--          return (second Map.keys res)--    let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])-        consultCradle hieYaml cfp = do-           lfp <- flip makeRelative cfp <$> getCurrentDirectory-           log Info $ LogCradlePath lfp--           when (isNothing hieYaml) $-             log Warning $ LogCradleNotFound lfp--           cradle <- loadCradle hieYaml dir-           lfp <- flip makeRelative cfp <$> getCurrentDirectory--           when optTesting $ mRunLspT lspEnv $-            sendNotification (SCustomMethod "ghcide/cradle/loaded") (toJSON cfp)--           -- Display a user friendly progress message here: They probably don't know what a cradle is-           let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle))-                         <> " (for " <> T.pack lfp <> ")"-           eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $-              withTrace "Load cradle" $ \addTag -> do-                  addTag "file" lfp-                  res <- cradleToOptsAndLibDir recorder cradle cfp-                  addTag "result" (show res)-                  return res--           log 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 (renderCradleError ncfp) err, Nothing)-               void $ modifyVar' fileToFlags $-                    Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info))-               void $ modifyVar' filesMap $ HM.insert ncfp hieYaml-               return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err)--    -- This caches the mapping from hie.yaml + Mod.hs -> [String]-    -- Returns the Ghc session and the cradle dependencies-    let sessionOpts :: (Maybe FilePath, FilePath)-                    -> IO (IdeResult HscEnvEq, [FilePath])-        sessionOpts (hieYaml, file) = do-          v <- 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-        as <- async $ getOptions file-        return (as, wait as)-      pure opts-  where-    log = logWith recorder---- | 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-    cradleRes <- HieBios.getCompilerOptions file cradle-    case cradleRes of-        CradleSuccess r -> do-            -- Now get the GHC lib dir-            libDirRes <- getRuntimeGhcLibDir cradle-            case libDirRes of-                -- This is the successful path-                CradleSuccess libDir -> pure (Right (r, libDir))-                CradleFail err       -> return (Left [err])-                CradleNone           -> do-                    logWith recorder Info $ LogNoneCradleFound file-                    return (Left [])--        CradleFail err -> return (Left [err])-        CradleNone -> do-            logWith recorder Info $ LogNoneCradleFound file-            return (Left [])--emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv-emptyHscEnv nc libDir = do-    env <- runGhc (Just libDir) getSession-    initDynLinker env-    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 mod) env dep = do-    let fps = [i </> moduleNameSlashes mod -<.> ext <> boot-              | ext <- exts-              , i <- is-              , boot <- ["", "-boot"]-              ]-    locs <- mapM (fmap toNormalizedFilePath' . makeAbsolute) fps-    return [TargetDetails (TargetModule mod) env dep locs]--- For a 'TargetFile' we consider all the possible module names-fromTargetId _ _ (GHC.TargetFile f _) env deps = do-    nf <- toNormalizedFilePath' <$> makeAbsolute f-    return [TargetDetails (TargetFile nf) env deps [nf]]--toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))]-toFlagsMap TargetDetails{..} =-    [ (l, (targetEnv, targetDepends)) | l <-  targetLocations]---setNameCache :: IORef NameCache -> HscEnv -> HscEnv-setNameCache nc hsc = hsc { hsc_NC = nc }---- | Create a mapping from FilePaths to HscEnvEqs-newComponentCache-         :: 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' <--      -- 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---    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--    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---renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic-renderCradleError nfp (CradleError _ _ec t) =-  ideErrorWithSource (Just "cradle") (Just DsError) nfp (T.unlines (map T.pack t))---- See Note [Multi Cradle Dependency Info]-type DependencyInfo = Map.Map FilePath (Maybe UTCTime)-type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo])--- | Maps a "hie.yaml" location to all its Target Filepaths and options.-type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))--- | Maps a Filepath to its respective "hie.yaml" location.--- It aims to be the reverse of 'FlagsMap'.-type FilesMap = HM.HashMap NormalizedFilePath (Maybe FilePath)---- This is pristine information about a component-data RawComponentInfo = RawComponentInfo-  { rawComponentUnitId         :: 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-    tryIO :: IO a -> IO (Either IOException a)-    tryIO = Safe.try--    do_one :: FilePath -> IO (FilePath, Maybe UTCTime)-    do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp)---- | This function removes all the -package flags which refer to packages we--- are going to deal with ourselves. For example, if a executable depends--- on a library component, then this function will remove the library flag--- from the package flags for the executable------ There are several places in GHC (for example the call to hptInstances in--- tcRnImports) which assume that all modules in the HPT have the same unit--- ID. Therefore we create a fake one and give them all the same unit id.-removeInplacePackages-    :: 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.-    env <- hscSetFlags dflags'' <$> getSession-    final_env' <- liftIO $ wrapPackageSetupException $ Compat.initUnits env-    return (hsc_dflags final_env', 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 DsError) (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
@@ -0,0 +1,133 @@+{-# LANGUAGE DeriveAnyClass #-}++module Development.IDE.Session.Diagnostics where+import           Control.Applicative+import           Control.Lens+import           Control.Monad+import qualified Data.Aeson                        as Aeson+import           Data.List+import           Data.List.Extra                   (split)+import           Data.Maybe+import qualified Data.Text                         as T+import           Development.IDE.Types.Diagnostics+import           Development.IDE.Types.Location+import           GHC.Generics+import qualified HIE.Bios.Cradle                   as HieBios+import           HIE.Bios.Types                    hiding (Log)+import           System.FilePath++data CradleErrorDetails =+  CradleErrorDetails+    { 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 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+    ms = cradleErrorStderr cradleError++    absDeps = fmap (cradleRootDir cradle </>) (cradleErrorDependencies cradleError)+    userFriendlyMessage :: [String]+    userFriendlyMessage+      | HieBios.isCabalCradle cradle = fromMaybe ms $ fileMissingMessage <|> (unknownModuleMessage (fromNormalizedFilePath nfp) <$ mkUnknownModuleDetails)+      | otherwise = ms++    -- Produce structured details when unknown module error is detected+    mkUnknownModuleDetails :: Maybe UnknownModuleDetails+    mkUnknownModuleDetails+      | any (isInfixOf "Failed extracting script block:") ms =+          let fp = fromNormalizedFilePath nfp+          in Just UnknownModuleDetails+               { moduleFilePath   = fp+               , suggestedModuleName = dropExtension (takeFileName fp)+               }+      | otherwise = Nothing++    fileMissingMessage :: Maybe [String]+    fileMissingMessage =+      multiCradleErrMessage <$> parseMultiCradleErr ms++-- | Information included in Multi Cradle error messages+data MultiCradleErr = MultiCradleErr+  { mcPwd      :: FilePath+  , mcFilePath :: FilePath+  , mcPrefixes :: [(FilePath, String)]+  } deriving (Show)++-- | Attempt to parse a multi-cradle message+parseMultiCradleErr :: [String] -> Maybe MultiCradleErr+parseMultiCradleErr ms = do+  _  <- lineAfter "Multi Cradle: "+  wd <- lineAfter "pwd: "+  fp <- lineAfter "filepath: "+  ps <- prefixes+  pure $ MultiCradleErr wd fp ps++  where+    lineAfter :: String -> Maybe String+    lineAfter pre = listToMaybe $ mapMaybe (stripPrefix pre) ms++    prefixes :: Maybe [(FilePath, String)]+    prefixes = do+      pure $ mapMaybe tuple ms++    tuple :: String -> Maybe (String, String)+    tuple line = do+      line' <- surround '(' line ')'+      [f, s] <- pure $ split (==',') line'+      pure (f, s)++    -- extracts the string surrounded by required characters+    surround :: Char -> String -> Char -> Maybe String+    surround start s end = do+      guard (listToMaybe s == Just start)+      guard (listToMaybe (reverse s) == Just end)+      pure $ drop 1 $ take (length s - 1) s++multiCradleErrMessage :: MultiCradleErr -> [String]+multiCradleErrMessage e =+    unknownModuleMessage (mcFilePath e)+    <> [""]+    <> map prefix (mcPrefixes e)+  where+    prefix (f, r) = f <> " - " <> r++unknownModuleMessage :: String -> [String]+unknownModuleMessage moduleFileName =+  [ "Loading the module '" <> moduleFileName <> "' failed."+  , ""+  , "It may not be listed in your .cabal file!"+  , "Perhaps you need to add `"<> dropExtension (takeFileName moduleFileName) <> "` to other-modules or exposed-modules."+  , ""+  , "For more information, visit: https://cabal.readthedocs.io/en/3.4/developing-packages.html#modules-included-in-the-package"+  ]
+ 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,17 +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           Data.Maybe-import           GHC.Check--- Only use this for checking against the compile time GHC libDir!--- Use getRuntimeGhcLibDir from hie-bios instead for everything else--- otherwise binaries will not be distributable since paths will be baked into them-import qualified GHC.Paths-import           System.Environment--ghcVersionChecker :: GhcVersionChecker-ghcVersionChecker = $$(makeGhcVersionChecker (fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"))
src/Development/IDE.hs view
@@ -8,30 +8,32 @@  import           Development.IDE.Core.Actions          as X (getAtPoint,                                                              getDefinition,-                                                             getTypeDefinition,-                                                             useE, useNoFileE,-                                                             usesE)+                                                             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)-import           Development.IDE.Core.RuleTypes        as X import           Development.IDE.Core.Rules            as X (getClientConfigAction,-                                                             getParsedModule)+                                                             getParsedModule,+                                                             usePropertyAction)+import           Development.IDE.Core.RuleTypes        as X import           Development.IDE.Core.Service          as X (runAction) import           Development.IDE.Core.Shake            as X (FastResult (..),                                                              IdeAction (..),                                                              IdeRule, IdeState,                                                              RuleBody (..),                                                              ShakeExtras,+                                                             VFSModified (..),                                                              actionLogger,                                                              define,                                                              defineEarlyCutoff,                                                              defineNoDiagnostics,                                                              getClientConfig,-                                                             getPluginConfig,-                                                             ideLogger,+                                                             getPluginConfigAction,+                                                             ideLogger, rootDir,                                                              runIdeAction,                                                              shakeExtras, use,                                                              useNoFile,@@ -40,8 +42,7 @@                                                              useWithStaleFast,                                                              useWithStaleFast',                                                              useWithStale_,-                                                             use_, uses, uses_,-                                                             VFSModified(..))+                                                             use_, uses, uses_) import           Development.IDE.GHC.Compat            as X (GhcVersion (..),                                                              ghcVersion) import           Development.IDE.GHC.Error             as X@@ -51,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           Development.IDE.Types.Logger          as X+import           Ide.Logger                            as X
src/Development/IDE/Core/Actions.hs view
@@ -1,51 +1,43 @@-{-# LANGUAGE RankNTypes   #-} {-# LANGUAGE TypeFamilies #-} module Development.IDE.Core.Actions ( getAtPoint , getDefinition , getTypeDefinition+, getImplementationDefinition , highlightAtPoint , refsAtPoint-, useE-, useNoFileE-, usesE , workspaceSymbols+, lookupMod ) where +import           Control.Monad.Extra                  (mapMaybeM) import           Control.Monad.Reader import           Control.Monad.Trans.Maybe import qualified Data.HashMap.Strict                  as HM 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.Types                   (DocumentHighlight (..),-                                                       SymbolInformation (..))----- | 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-+import           Language.LSP.Protocol.Types          (DocumentHighlight (..),+                                                       SymbolInformation (..),+                                                       normalizedFilePathToUri,+                                                       uriToNormalizedFilePath) --- IMPORTANT NOTE : make sure all rules `useE`d by these have a "Persistent Stale" rule defined,+-- 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 -- should just return an empty result@@ -58,50 +50,85 @@   ide <- ask   opts <- liftIO $ getIdeOptionsIO ide -  (hf, mapping) <- useE GetHieAst file-  env <- hscEnv . fst <$> useE GhcSession file-  dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useE GetDocMap file)--  !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)-  MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap env pos'+  (hf, mapping) <- useWithStaleFastMT GetHieAst file+  shakeExtras <- lift askShake -toCurrentLocations :: PositionMapping -> [Location] -> [Location]-toCurrentLocations mapping = mapMaybe go-  where-    go (Location uri range) = Location uri <$> toCurrentRange mapping range+  env <- hscEnv . fst <$> useWithStaleFastMT GhcSession 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)) --- | useE is useful to implement functions that aren’t rules but need shortcircuiting--- e.g. getDefinition.-useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping)-useE k = MaybeT . useWithStaleFast k+  !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) -useNoFileE :: IdeRule k v => IdeState -> k -> MaybeT IdeAction v-useNoFileE _ide k = fst <$> useE k emptyFilePath+  MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$>+    AtPoint.atPoint opts shakeExtras hf dkMap env pos' enabledExtensions -usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT IdeAction [(v,PositionMapping)]-usesE k = MaybeT . fmap sequence . mapM (useWithStaleFast k)+-- | 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 (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+    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) <- useE GetHieAst file-    (ImportMap imports, _) <- useE GetImportMap file+    (hf, mapping) <- useWithStaleFastMT GetHieAst file+    (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file     !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)-    toCurrentLocations mapping <$> AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'+    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) <- useE GetHieAst file+    (hf, mapping) <- useWithStaleFastMT GetHieAst file     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)-    toCurrentLocations mapping <$> AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos'+    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-    (HAR _ hf rf _ _,mapping) <- useE GetHieAst file+    (HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst file     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)     let toCurrentHighlight (DocumentHighlight range t) = flip DocumentHighlight t <$> toCurrentRange mapping range     mapMaybe toCurrentHighlight <$>AtPoint.documentHighlight hf rf pos'
src/Development/IDE/Core/Compile.hs view
@@ -1,1344 +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-  ) where--import           Control.Concurrent.Extra-import           Control.Concurrent.STM.Stats      hiding (orElse)-import           Control.DeepSeq                   (force, liftRnf, rnf, rwhnf)-import           Control.Exception                 (evaluate)-import           Control.Exception.Safe-import           Control.Lens                      hiding (List)-import           Control.Monad.Except-import           Control.Monad.Extra-import           Control.Monad.Trans.Except-import           Data.Aeson                        (toJSON)-import           Data.Bifunctor                    (first, second)-import           Data.Binary-import qualified Data.Binary                       as B-import qualified Data.ByteString                   as BS-import qualified Data.ByteString.Lazy              as LBS-import           Data.Coerce-import qualified Data.DList                        as DL-import           Data.Functor-import qualified Data.HashMap.Strict               as HashMap-import           Data.IORef-import           Data.IntMap                       (IntMap)-import qualified Data.IntMap.Strict                as IntMap-import           Data.List.Extra-import           Data.Map                          (Map)-import qualified Data.Map.Strict                   as Map-import           Data.Maybe-import qualified Data.Text                         as T-import           Data.Time                         (UTCTime (..),-                                                    getCurrentTime)-import           Data.Time.Clock.POSIX             (posixSecondsToUTCTime)-import           Data.Tuple.Extra                  (dupe)-import           Data.Unique                       as Unique-import           Debug.Trace-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.Error-import           Development.IDE.GHC.Orphans       ()-import           Development.IDE.GHC.Util-import           Development.IDE.GHC.Warnings-import           Development.IDE.Spans.Common-import           Development.IDE.Types.Diagnostics-import           Development.IDE.Types.Location-import           Development.IDE.Types.Options-import           GHC                               (ForeignHValue,-                                                    GetDocsFailure (..),-                                                    mgModSummaries,-                                                    parsedSource)-import qualified GHC.LanguageExtensions            as LangExt-import           GHC.Serialized-import           HieDb-import qualified Language.LSP.Server               as LSP-import           Language.LSP.Types                (DiagnosticTag (..))-import qualified Language.LSP.Types                as LSP-import           System.Directory-import           System.FilePath-import           System.IO.Extra                   (fixIO, newTempFileWithin)-import           Unsafe.Coerce--#if !MIN_VERSION_ghc(8,10,0)-import           ErrUtils-#endif--#if MIN_VERSION_ghc(9,0,1)-import           GHC.Tc.Gen.Splice-#else-import           TcSplice-#endif--#if MIN_VERSION_ghc(9,2,0)-import           Development.IDE.GHC.Compat.Util   (emptyUDFM, fsLit,-                                                    plusUDFM_C)-import           GHC                               (Anchor (anchor),-                                                    EpaComment (EpaComment),-                                                    EpaCommentTok (EpaBlockComment, EpaLineComment),-                                                    epAnnComments,-                                                    priorComments)-import qualified GHC                               as G-import           GHC.Hs                            (LEpaComment)-import qualified GHC.Types.Error                   as Error-#endif---- | 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--typecheckModule :: IdeDefer-                -> HscEnv-                -> ModuleEnv UTCTime -- ^ linkables not to unload-                -> ParsedModule-                -> IO (IdeResult TcModuleResult)-typecheckModule (IdeDefer defer) hsc keep_lbls pm = do-        let modSummary = pm_mod_summary pm-            dflags = ms_hspp_opts modSummary-        mmodSummary' <- catchSrcErrors (hsc_dflags hsc) "typecheck (initialize plugins)"-                                      (initPlugins hsc modSummary)-        case mmodSummary' of-          Left errs -> return (errs, Nothing)-          Right modSummary' -> do-            (warnings, etcm) <- withWarnings "typecheck" $ \tweak ->-                let-                  session = tweak (hscSetFlags dflags hsc)-                   -- TODO: maybe settings ms_hspp_opts is unnecessary?-                  mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session}-                in-                  catchSrcErrors (hsc_dflags hsc) "typecheck" $ do-                    tcRnModule session keep_lbls $ demoteIfDefer pm{pm_mod_summary = mod_summary''}-            let errorPipeline = unDefer . hideDiag dflags . tagDiag-                diags = map errorPipeline warnings-                deferedError = any fst diags-            case etcm of-              Left errs -> return (map snd diags ++ errs, Nothing)-              Right tcm -> return (map snd diags, Just $ tcm{tmrDeferedError = deferedError})-    where-        demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id---- | Install hooks to capture the splices as well as the runtime module dependencies-captureSplicesAndDeps :: HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, UniqSet ModuleName)-captureSplicesAndDeps env k = do-  splice_ref <- newIORef mempty-  dep_ref <- newIORef emptyUniqSet-  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 (UniqSet ModuleName) -> 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.-    ---    -- Only compute direct dependencies instead of transitive dependencies.-    -- It is much cheaper to store the direct dependencies, we can compute-    -- the transitive ones when required.-    -- Also only record dependencies from the home package-    compile_bco_hook :: IORef (UniqSet ModuleName) -> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue-    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---#if MIN_VERSION_ghc(9,2,0)-           ; 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_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-                               (icInteractiveModule ictxt)-                               iNTERACTIVELoc-                               prepd_expr--             {- Convert to BCOs -}-           ; bcos <- byteCodeGen hsc_env-                       (icInteractiveModule ictxt)-                       stg_expr-                       [] Nothing-           ; let needed_mods = mkUniqSet [ moduleName mod | 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 == homeUnitId_ dflags -- Only care about stuff from the home package-                                         ]-            -- 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.--             {- load it -}-           ; fv_hvs <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos-           ; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs)-#else-             {- Convert to BCOs -}-           ; bcos <- coreExprToBCOs hsc_env-                       (icInteractiveModule (hsc_IC hsc_env)) prepd_expr--           ; let needed_mods = mkUniqSet [ moduleName mod | n <- uniqDSetToList (bcoFreeNames bcos)-                                         , Just mod <- [nameModule_maybe n] -- Names from other modules-                                         , not (isWiredInName n) -- Exclude wired-in names-                                         , moduleUnitId mod == homeUnitId_ dflags -- Only care about stuff from the home package-                                         ]-            -- 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.--             {- link it -}-           ; hval <- linkExpr hsc_env srcspan bcos-#endif--           ; modifyIORef' var (unionUniqSets needed_mods)-           ; return hval }---    -- | 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-  -> ModuleEnv UTCTime -- ^ Program linkables not to unload-  -> ParsedModule-  -> IO TcModuleResult-tcRnModule hsc_env keep_lbls pmod = do-  let ms = pm_mod_summary pmod-      hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env-      hpt = hsc_HPT hsc_env--  unload hsc_env_tmp $ map (\(mod, time) -> LM time mod []) $ moduleEnvToList keep_lbls--  ((tc_gbl_env', mrn_info), splices, mods)-      <- captureSplicesAndDeps hsc_env_tmp $ \hsc_env_tmp ->-             do  hscTypecheckRename hsc_env_tmp ms $-                          HsParsedModule { hpm_module = parsedSource pmod,-                                           hpm_src_files = pm_extra_src_files pmod,-                                           hpm_annotations = pm_annotations pmod }-  let rn_info = case mrn_info of-        Just x  -> x-        Nothing -> error "no renamed info tcRnModule"--      -- Compute the transitive set of linkables required-      mods_transitive = go emptyUniqSet mods-        where-          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)]--      -- The linkables we depend on at runtime are the transitive closure of 'mods'-      -- restricted to the home package-      -- See Note [Recompilation avoidance in the presence of TH]-      mod_env = filterModuleEnv (\m _ -> elementOfUniqSet (moduleName m) mods_transitive) keep_lbls -- Could use restrictKeys if the constructors were exported--      -- Serialize mod_env so we can read it from the interface-      mod_env_anns = map (\(mod, time) -> Annotation (ModuleTarget mod) $ toSerialized serializeModDepTime (ModDepTime time))-                         (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)--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-#if MIN_VERSION_ghc(8,10,0)-  iface <- mkIfaceTc hsc_env_tmp sf details tcGblEnv-#else-  (iface, _) <- mkIfaceTc hsc_env_tmp Nothing sf details tcGblEnv-#endif-  let mod_info = HomeModInfo iface details Nothing-  pure $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm)--mkHiFileResultCompile-    :: HscEnv-    -> TcModuleResult-    -> ModGuts-    -> LinkableType -- ^ use object code or byte code?-    -> IO (IdeResult HiFileResult)-mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do-  let session = hscSetFlags (ms_hspp_opts ms) session'-      ms = pm_mod_summary $ tmrParsed tcm-      tcGblEnv = tmrTypechecked tcm--  let genLinkable = case ltype of-        ObjectLinkable -> generateObjectCode-        BCOLinkable    -> generateByteCode--  (linkable, details, diags) <--    if mg_hsc_src simplified_guts == HsBootFile-    then do-        -- give variables unique OccNames-        details <- mkBootModDetailsTc session tcGblEnv-        pure (Nothing, details, [])-    else do-        -- give variables unique OccNames-        (guts, details) <- tidyProgram session simplified_guts-        (diags, linkable) <- genLinkable session ms guts-        pure (linkable, details, diags)-#if MIN_VERSION_ghc(9,0,1)-  let !partial_iface = force (mkPartialIface session details simplified_guts)-  final_iface <- mkFullIface session partial_iface Nothing-#elif MIN_VERSION_ghc(8,10,0)-  let !partial_iface = force (mkPartialIface session details simplified_guts)-  final_iface <- mkFullIface session partial_iface-#else-  (final_iface,_) <- mkIface session Nothing details simplified_guts-#endif-  let mod_info = HomeModInfo final_iface details linkable-  pure (diags, Just $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm))--  where-    dflags = hsc_dflags session'-    source = "compile"-    catchErrs x = x `catches`-      [ Handler $ return . (,Nothing) . diagFromGhcException source dflags-      , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "<internal>")-      . (("Error during " ++ T.unpack source) ++) . show @SomeException-      ]--initPlugins :: HscEnv -> ModSummary -> IO ModSummary-initPlugins session modSummary = do-    session1 <- liftIO $ initializePlugins (hscSetFlags (ms_hspp_opts modSummary) session)-    return modSummary{ms_hspp_opts = hsc_dflags session1}---- | Whether we should run the -O0 simplifier when generating core.------ This is required for template Haskell to work but we disable this in DAML.--- See #256-newtype RunSimplifier = RunSimplifier Bool---- | Compile a single type-checked module to a 'CoreModule' value, or--- provide errors.-compileModule-    :: RunSimplifier-    -> HscEnv-    -> ModSummary-    -> TcGblEnv-    -> IO (IdeResult ModGuts)-compileModule (RunSimplifier simplify) session ms tcg =-    fmap (either (, Nothing) (second Just)) $-        catchSrcErrors (hsc_dflags session) "compile" $ do-            (warnings,desugared_guts) <- withWarnings "compile" $ \tweak -> do-               let session' = tweak (hscSetFlags (ms_hspp_opts ms) session)-               -- 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 dot_o $ hsc_dflags env'-                          session' = hscSetFlags newFlags session-#if MIN_VERSION_ghc(9,0,1)-                      (outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts-#else-                      (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts-#endif-#if MIN_VERSION_ghc(8,10,0)-                                (ms_location summary)-#else-                                summary-#endif-                                fp-                      compileFile session' StopLn (outputFilename, Just (As False))-              let unlinked = DotO dot_o_fp-              -- Need time to be the modification time for recompilation checking-              t <- liftIO $ getModificationTime dot_o_fp-              let linkable = LM t mod [unlinked]--              pure (map snd warnings, linkable)--generateByteCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)-generateByteCode hscEnv summary guts = do-    fmap (either (, Nothing) (second Just)) $-          catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do-              (warnings, (_, bytecode, sptEntries)) <--                withWarnings "bytecode" $ \_tweak -> do-                      let 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 guts-#if MIN_VERSION_ghc(8,10,0)-                                (ms_location summary')-#else-                                summary'-#endif-              let unlinked = BCOs bytecode sptEntries-              time <- liftIO getCurrentTime-              let linkable = LM time (ms_mod summary) [unlinked]--              pure (map snd warnings, linkable)--demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule-demoteTypeErrorsToWarnings =-  (update_pm_mod_summary . update_hspp_opts) demoteTEsToWarns where--  demoteTEsToWarns :: DynFlags -> DynFlags-  -- convert the errors into warnings, and also check the warnings are enabled-  demoteTEsToWarns = (`wopt_set` Opt_WarnDeferredTypeErrors)-                   . (`wopt_set` Opt_WarnTypedHoles)-                   . (`wopt_set` Opt_WarnDeferredOutOfScopeVariables)-                   . (`gopt_set` Opt_DeferTypeErrors)-                   . (`gopt_set` Opt_DeferTypedHoles)-                   . (`gopt_set` Opt_DeferOutOfScopeVariables)--update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary-update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}--update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule-update_pm_mod_summary up pm =-  pm{pm_mod_summary = up $ pm_mod_summary pm}--unDefer :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic)-unDefer (Reason Opt_WarnDeferredTypeErrors         , fd) = (True, upgradeWarningToError fd)-unDefer (Reason Opt_WarnTypedHoles                 , fd) = (True, upgradeWarningToError fd)-unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = (True, upgradeWarningToError fd)-unDefer ( _                                        , fd) = (False, fd)--upgradeWarningToError :: FileDiagnostic -> FileDiagnostic-upgradeWarningToError (nfp, sh, fd) =-  (nfp, sh, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where-  warn2err :: T.Text -> T.Text-  warn2err = T.intercalate ": error:" . T.splitOn ": warning:"--hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)-hideDiag originalFlags (Reason warning, (nfp, _sh, fd))-  | not (wopt warning originalFlags)-  = (Reason warning, (nfp, HideDiag, fd))-hideDiag _originalFlags t = t---- | Warnings which lead to a diagnostic tag-unnecessaryDeprecationWarningFlags :: [WarningFlag]-unnecessaryDeprecationWarningFlags-  = [ Opt_WarnUnusedTopBinds-    , Opt_WarnUnusedLocalBinds-    , Opt_WarnUnusedPatternBinds-    , Opt_WarnUnusedImports-    , Opt_WarnUnusedMatches-    , Opt_WarnUnusedTypePatterns-    , Opt_WarnUnusedForalls-#if MIN_VERSION_ghc(8,10,0)-    , Opt_WarnUnusedRecordWildcards-#endif-    , Opt_WarnInaccessibleCode-    , Opt_WarnWarningsDeprecations-    ]---- | Add a unnecessary/deprecated tag to the required diagnostics.-tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)-tagDiag (Reason warning, (nfp, sh, fd))-  | Just tag <- requiresTag warning-  = (Reason warning, (nfp, sh, fd { _tags = addTag tag (_tags fd) }))-  where-    requiresTag :: WarningFlag -> Maybe DiagnosticTag-    requiresTag Opt_WarnWarningsDeprecations-      = Just DtDeprecated-    requiresTag wflag  -- deprecation was already considered above-      | wflag `elem` unnecessaryDeprecationWarningFlags-      = Just DtUnnecessary-    requiresTag _ = Nothing-    addTag :: DiagnosticTag -> Maybe (List DiagnosticTag) -> Maybe (List DiagnosticTag)-    addTag t Nothing          = Just (List [t])-    addTag t (Just (List ts)) = Just (List (t : ts))--- other diagnostics are left unaffected-tagDiag t = t--addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags-addRelativeImport fp modu dflags = dflags-    {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}--atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO ()-atomicFileWrite targetPath write = do-  let dir = takeDirectory targetPath-  createDirectoryIfMissing True dir-  (tempFilePath, cleanUp) <- newTempFileWithin dir-  (write tempFilePath >> renameFile tempFilePath targetPath) `onException` cleanUp--generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type))-generateHieAsts hscEnv tcm =-  handleGenerationErrors' dflags "extended interface generation" $ runHsc hscEnv $ do-    -- These varBinds use unitDataConId but it could be anything as the id name is not used-    -- during the hie file generation process. It's a workaround for the fact that the hie modules-    -- don't export an interface which allows for additional information to be added to hie files.-    let fake_splice_binds = Util.listToBag (map (mkVarBind unitDataConId) (spliceExpresions $ tmrTopLevelSplices tcm))-        real_binds = tcg_binds $ tmrTypechecked tcm-#if MIN_VERSION_ghc(9,0,1)-        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 $-      Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs-#else-    Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm)-#endif-  where-    dflags = hsc_dflags hscEnv-    run ts =-#if MIN_VERSION_ghc(9,2,0)-        fmap (join . snd) . liftIO . initDs hscEnv ts-#else-        id-#endif--spliceExpresions :: Splices -> [LHsExpr GhcTc]-spliceExpresions Splices{..} =-    DL.toList $ mconcat-        [ DL.fromList $ map fst exprSplices-        , DL.fromList $ map fst patSplices-        , DL.fromList $ map fst typeSplices-        , DL.fromList $ map fst declSplices-        , DL.fromList $ map fst awSplices-        ]---- | In addition to indexing the `.hie` file, this function is responsible for--- maintaining the 'IndexQueue' state and notfiying the user about indexing--- progress.------ We maintain a record of all pending index operations in the 'indexPending'--- TVar.--- When 'indexHieFile' is called, it must check to ensure that the file hasn't--- already be queued up for indexing. If it has, then we can just skip it------ Otherwise, we record the current file as pending and write an indexing--- operation to the queue------ When the indexing operation is picked up and executed by the worker thread,--- the first thing it does is ensure that a newer index for the same file hasn't--- been scheduled by looking at 'indexPending'. If a newer index has been--- scheduled, we can safely skip this one------ Otherwise, we start or continue a progress reporting session, telling it--- about progress so far and the current file we are attempting to index. Then--- we can go ahead and call in to hiedb to actually do the indexing operation------ Once this completes, we have to update the 'IndexQueue' state. First, we--- must remove the just indexed file from 'indexPending' Then we check if--- 'indexPending' is now empty. In that case, we end the progress session and--- report the total number of file indexed. We also set the 'indexCompleted'--- TVar to 0 in order to set it up for a fresh indexing session. Otherwise, we--- can just increment the 'indexCompleted' TVar and exit.----indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> 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-          pending <- readTVar indexPending-          pure $ case HashMap.lookup srcPath pending of-            Nothing          -> False-            -- If the hash in the pending list doesn't match the current hash, then skip-            Just pendingHash -> pendingHash /= hash-        unless newerScheduled $ do-          pre optProgressStyle-          withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf')-          post-  where-    mod_location    = ms_location mod_summary-    targetPath      = Compat.ml_hie_file mod_location-    HieDbWriter{..} = hiedbWriter se--    -- Get a progress token to report progress and update it for the current file-    pre 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.ProgressTextToken . T.pack . show . hashUnique <$> liftIO Unique.newUnique-              -- TODO: Wait for the progress create response to use the token-              _ <- LSP.sendRequest LSP.SWindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ())-              LSP.sendNotification LSP.SProgress $ LSP.ProgressParams u $-                LSP.Begin $ LSP.WorkDoneProgressBeginParams-                  { _title = "Indexing"-                  , _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 $ \tok -> LSP.runLspT env $-        LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $-          LSP.Report $-            case style of-                Percentage -> LSP.WorkDoneProgressReportParams-                    { _cancellable = Nothing-                    , _message = Nothing-                    , _percentage = Just progressPct-                    }-                Explicit -> LSP.WorkDoneProgressReportParams-                    { _cancellable = Nothing-                    , _message = Just $-                        T.pack " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..."-                    , _percentage = Nothing-                    }-                NoProgress -> LSP.WorkDoneProgressReportParams-                  { _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.SCustomMethod "ghcide/reference/ready") $-            toJSON $ fromNormalizedFilePath srcPath-      whenJust mdone $ \done ->-        modifyVar_ indexProgressToken $ \tok -> do-          whenJust (lspEnv se) $ \env -> LSP.runLspT env $-            whenJust tok $ \tok ->-              LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $-                LSP.End $ LSP.WorkDoneProgressEndParams-                  { _message = Just $ "Finished indexing " <> T.pack (show done) <> " files"-                  }-          -- We are done with the current indexing cycle, so destroy the token-          pure Nothing--writeAndIndexHieFile :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic]-writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source =-  handleGenerationErrors dflags "extended interface write/compression" $ do-    hf <- runHsc hscEnv $-      GHC.mkHieFile' mod_summary exports ast source-    atomicFileWrite targetPath $ flip GHC.writeHieFile hf-    hash <- 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 :: HscEnv -> HiFileResult -> IO [FileDiagnostic]-writeHiFile hscEnv tc =-  handleGenerationErrors dflags "interface write" $ do-    atomicFileWrite targetPath $ \fp ->-      writeIfaceFile hscEnv fp modIface-  where-    modIface = hm_iface $ hirHomeMod tc-    targetPath = ml_hi_file $ ms_location $ hirModSummary tc-    dflags = hsc_dflags hscEnv--handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic]-handleGenerationErrors dflags source action =-  action >> return [] `catches`-    [ Handler $ return . diagFromGhcException source dflags-    , Handler $ return . diagFromString source DsError (noSpan "<internal>")-    . (("Error during " ++ T.unpack source) ++) . show @SomeException-    ]--handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a)-handleGenerationErrors' dflags source action =-  fmap ([],) action `catches`-    [ Handler $ return . (,Nothing) . diagFromGhcException source dflags-    , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "<internal>")-    . (("Error during " ++ T.unpack source) ++) . show @SomeException-    ]---- | Load modules, quickly. Input doesn't need to be desugared.--- A module must be loaded before dependent modules can be typechecked.--- This variant of loadModuleHome will *never* cause recompilation, it just--- modifies the session.--- The order modules are loaded is important when there are hs-boot files.--- In particular you should make sure to load the .hs version of a file after the--- .hs-boot version.-loadModulesHome-    :: [HomeModInfo]-    -> HscEnv-    -> HscEnv-loadModulesHome mod_infos e =-  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---- Merge the HPTs, module graphs and FinderCaches-mergeEnvs :: HscEnv -> [ModSummary] -> [HomeModInfo] -> [HscEnv] -> IO HscEnv-mergeEnvs env extraModSummaries extraMods envs = do-    prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs-    let ims  = map (\ms -> Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms)  (moduleName (ms_mod ms))) extraModSummaries-        ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) extraModSummaries ims-        -- Very important to force this as otherwise the hsc_mod_graph field is not-        -- forced and ends up retaining a reference to all the old hsc_envs we have merged to get-        -- this new one, which in turn leads to the EPS referencing the HPT.-        module_graph_nodes =-#if MIN_VERSION_ghc(9,2,0)-        -- 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 $-#endif-          extraModSummaries ++ nubOrdOn ms_mod (concatMap (mgModSummaries . hsc_mod_graph) envs)--    newFinderCache <- newIORef $-            foldl'-                (\fc (im, ifr) -> Compat.extendInstalledModuleEnv fc im ifr) prevFinderCache-                $ zip ims ifrs-    liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $ env{-        hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs,-        hsc_FC = newFinderCache,-        hsc_mod_graph = mkModuleGraph module_graph_nodes-    })-    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))--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-getModSummaryFromImports env fp modTime contents = do-    (contents, opts, dflags) <- preprocessor env fp contents--    -- The warns will hopefully be reported when we actually parse the module-    (_warns, L main_loc hsmod) <- parseHeader dflags fp contents--    -- Copied from `HeaderInfo.getImports`, but we also need to keep the parsed imports-    let mb_mod = hsmodName hsmod-        imps = hsmodImports hsmod--        mod = fmap unLoc mb_mod `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 = filter ((/= moduleName gHC_PRIM) . unLoc-                                . ideclName . unLoc)-                               ord_idecls--        implicit_prelude = xopt LangExt.ImplicitPrelude dflags-        implicit_imports = mkPrelImports mod main_loc-                                         implicit_prelude imps--        convImport (L _ i) = (fmap sl_fs (ideclPkgQual i)-                                         , reLoc $ ideclName i)--        srcImports = map convImport src_idecls-        textualImports = map convImport (implicit_imports ++ ordinary_imps)--        msrImports = implicit_imports ++ imps--    -- Force bits that might keep the string buffer and DynFlags alive unnecessarily-    liftIO $ evaluate $ rnf srcImports-    liftIO $ evaluate $ rnf textualImports--    modLoc <- liftIO $ 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 (hscSetFlags dflags env)) mod-        sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile-        msrModSummary =-            ModSummary-                { ms_mod          = modl-#if MIN_VERSION_ghc(8,8,0)-                , ms_hie_date     = Nothing-#endif-                , ms_hs_date      = modTime-                , ms_hsc_src      = sourceType-                -- The contents are used by the GetModSummary rule-                , ms_hspp_buf     = Just contents-                , ms_hspp_file    = fp-                , ms_hspp_opts    = dflags-                , ms_iface_date   = Nothing-                , ms_location     = withBootSuffix sourceType modLoc-                , ms_obj_date     = Nothing-                , ms_parsed_mod   = Nothing-                , ms_srcimps      = srcImports-                , ms_textual_imps = textualImports-                }--    msrFingerprint <- liftIO $ computeFingerprint opts msrModSummary-    return ModSummaryResult{..}-    where-        -- Compute a fingerprint from the contents of `ModSummary`,-        -- eliding the timestamps, the preprocessed source and other non relevant fields-        computeFingerprint opts ModSummary{..} = do-            fingerPrintImports <- fingerprintFromPut $ do-                  put $ Util.uniq $ moduleNameFS $ moduleName ms_mod-                  forM_ (ms_srcimps ++ ms_textual_imps) $ \(mb_p, m) -> do-                    put $ Util.uniq $ moduleNameFS $ unLoc m-                    whenJust mb_p $ put . Util.uniq-            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,0,1)-       -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule))-#else-       -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs))-#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 "parser" dflags $ msgs dflags-     POk pst rdr_module -> do-        let (warns, errs) = getMessages' pst dflags--        -- Just because we got a `POk`, it doesn't mean there-        -- weren't errors! To clarify, the GHC parser-        -- distinguishes between fatal and non-fatal-        -- errors. Non-fatal errors are the sort that don't-        -- prevent parsing from continuing (that is, a parse-        -- tree can still be produced despite the error so that-        -- further errors/warnings can be collected). Fatal-        -- errors are those from which a parse tree just can't-        -- be produced.-        unless (null errs) $-            throwE $ diagFromErrMsgs "parser" dflags errs--        let warnings = diagFromErrMsgs "parser" dflags warns-        return (warnings, rdr_module)---- | Given a buffer, flags, and file path, produce a--- parsed module (or errors) and any parse warnings. Does not run any preprocessors--- ModSummary must contain the (preprocessed) contents of the buffer-parseFileContents-       :: HscEnv-       -> (GHC.ParsedSource -> IdePreprocessedSource)-       -> FilePath  -- ^ the filename (for source locations)-       -> ModSummary-       -> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule)-parseFileContents env customPreprocessor filename ms = do-   let loc  = mkRealSrcLoc (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 "parser" dflags $ msgs dflags-     POk pst rdr_module ->-         let-             hpm_annotations = mkApiAnns pst-             (warns, errs) = getMessages' pst dflags-         in-           do-               -- Just because we got a `POk`, it doesn't mean there-               -- weren't errors! To clarify, the GHC parser-               -- distinguishes between fatal and non-fatal-               -- errors. Non-fatal errors are the sort that don't-               -- prevent parsing from continuing (that is, a parse-               -- tree can still be produced despite the error so that-               -- further errors/warnings can be collected). Fatal-               -- errors are those from which a parse tree just can't-               -- be produced.-               unless (null errs) $-                 throwE $ diagFromErrMsgs "parser" dflags errs--               -- Ok, we got here. It's safe to continue.-               let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module--               unless (null errs) $-                  throwE $ diagFromStrings "parser" DsError errs--               let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns-               parsed' <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed--               -- To get the list of extra source files, we take the list-               -- that the parser gave us,-               --   - eliminate files beginning with '<'.  gcc likes to use-               --     pseudo-filenames like "<built-in>" and "<command-line>"-               --   - normalise them (eliminate differences between ./f and f)-               --   - filter out the preprocessed source file-               --   - filter out anything beginning with tmpdir-               --   - remove duplicates-               --   - filter out the .hs/.lhs source filename if we have one-               ---               let n_hspp  = normalise filename-                   srcs0 = nubOrd $ filter (not . (tmpDir dflags `isPrefixOf`))-                                  $ filter (/= n_hspp)-                                  $ map normalise-                                  $ filter (not . isPrefixOf "<")-                                  $ map 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 "parser" dflags warns-               pure (warnings ++ preproc_warnings, pm)--loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile-loadHieFile ncu f = do-  GHC.hie_file_result <$> GHC.readHieFile ncu f---{- 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-of the linkables used during a previous compile match whatever is currently-in the HPT.--}--data RecompilationInfo m-  = RecompilationInfo-  { source_version :: FileVersion-  , old_value   :: Maybe (HiFileResult, FileVersion)-  , get_file_version :: NormalizedFilePath -> m (Maybe FileVersion)-  , regenerate  :: Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface-  }---- | Retuns 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 = hm_iface    . hirHomeMod . fst <$> old_value-        mb_old_version = snd <$> old_value--        obj_file = ml_obj_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' $ case linkableNeeded of-          Just ObjectLinkable -> ml_obj_file (ms_location ms)-          _                   -> ml_hi_file (ms_location ms)--    -- The source is modified if it is newer than the destination-    let sourceMod = case mb_dest_version of-          Nothing -> SourceModified -- desitination file doesn't exist, assume modified source-          Just dest_version-            | source_version <= dest_version -> SourceUnmodified-            | otherwise -> SourceModified--    -- If mb_old_iface is nothing then checkOldIface will load it for us-    (recomp_iface_reqd, mb_checked_iface)-      <- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod mb_old_iface---    let-      (recomp_obj_reqd, mb_linkable) = case linkableNeeded of-        Nothing -> (UpToDate, Nothing)-        Just linkableType -> case old_value of-          -- We don't have an old result-          Nothing -> recompMaybeBecause "missing"-          -- We have an old result-          Just (old_hir, old_file_version) ->-            case hm_linkable $ hirHomeMod old_hir of-              Nothing -> recompMaybeBecause "missing [not needed before]"-              Just old_lb-                | Just True <- mi_used_th <$> mb_checked_iface -- No need to recompile if TH wasn't used-                , old_file_version /= source_version -> recompMaybeBecause "out of date"--                -- Check if it is the correct type-                -- Ideally we could use object-code in case we already have-                -- it when we are generating bytecode, but this is difficult because something-                -- below us may be bytecode, and object code can't depend on bytecode-                | ObjectLinkable <- linkableType, isObjectLinkable old_lb-                -> (UpToDate, Just old_lb)--                | BCOLinkable    <- linkableType , not (isObjectLinkable old_lb)-                -> (UpToDate, Just old_lb)--                | otherwise -> recompMaybeBecause "missing [wrong type]"-          where-            recompMaybeBecause msg = case linkableType of-              BCOLinkable -> (RecompBecause ("bytecode "++ msg), Nothing)-              ObjectLinkable -> case mb_dest_version of -- The destination file should be the object code-                Nothing -> (RecompBecause ("object code "++ msg), Nothing)-                Just disk_obj_version@(ModificationTime t) ->-                  -- If we make it this far, assume that the object code on disk is up to date-                  -- This assertion works because of the sourceMod check-                  assert (disk_obj_version >= source_version)-                         (UpToDate, Just $ LM (posixSecondsToUTCTime t) mod [DotO obj_file])-                Just (VFSVersion _) -> error "object code in vfs"--    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 <> recomp_obj_reqd) of-      (Just iface, UpToDate) -> do-         -- Force it because we don't want to retain old modsummaries or linkables-         lb <- liftIO $ evaluate $ force mb_linkable--         -- If we have an old value, just return it-         case old_value of-           Just (old_hir, _)-             | Just msg <- checkLinkableDependencies (hsc_HPT sessionWithMsDynFlags) (hirRuntimeModules old_hir)-             -> do_regenerate msg-             | otherwise -> return ([], Just old_hir)-           Nothing -> do-             hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface lb-             -- parse the runtime dependencies from the annotations-             let runtime_deps-                   | not (mi_used_th iface) = emptyModuleEnv-                   | otherwise = parseRuntimeDeps (md_anns (hm_details hmi))-             return ([], Just $ mkHiFileResult ms hmi runtime_deps)-      (_, _reason) -> do_regenerate _reason---- | ModDepTime is stored as an annotation in the iface to--- keep track of runtime dependencies-newtype ModDepTime = ModDepTime UTCTime--deserializeModDepTime :: [Word8] -> ModDepTime-deserializeModDepTime xs = ModDepTime $ case decode (LBS.pack xs) of-  (a,b) -> UTCTime (toEnum a) (toEnum b)--serializeModDepTime :: ModDepTime -> [Word8]-serializeModDepTime (ModDepTime l) = LBS.unpack $-  B.encode (fromEnum $ utctDay l, fromEnum $ utctDayTime l)---- | Find the runtime dependencies by looking at the annotations--- serialized in the iface-parseRuntimeDeps :: [ModIfaceAnnotation] -> ModuleEnv UTCTime-parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns-  where-    go (Annotation (ModuleTarget mod) payload)-      | Just (ModDepTime t) <- fromSerialized deserializeModDepTime payload-      = Just (mod, t)-    go _ = Nothing---- | checkLinkableDependencies compares the linkables in the home package 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 :: HomePackageTable -> ModuleEnv UTCTime -> Maybe RecompileRequired-checkLinkableDependencies hpt runtime_deps-  | isEmptyModuleEnv out_of_date = Nothing -- Nothing out of date, so don't recompile-  | otherwise = Just $-      RecompBecause $ "out of date runtime dependencies: " ++ intercalate ", " (map show (moduleEnvKeys out_of_date))-  where-    out_of_date = filterModuleEnv (\mod time -> case lookupHpt hpt (moduleName mod) of-                                                  Nothing -> False-                                                  Just hm -> case hm_linkable hm of-                                                    Nothing -> False-                                                    Just lm -> linkableTime lm /= time)-                                  runtime_deps--showReason :: RecompileRequired -> String-showReason UpToDate          = "UpToDate"-showReason MustCompile       = "MustCompile"-showReason (RecompBecause s) = s--mkDetailsFromIface :: HscEnv -> ModIface -> Maybe Linkable -> IO HomeModInfo-mkDetailsFromIface session iface linkable = do-  details <- liftIO $ fixIO $ \details -> do-    let hsc' = session { hsc_HPT = addToHpt (hsc_HPT session) (moduleName $ mi_module iface) (HomeModInfo iface details linkable) }-    initIfaceLoad hsc' (typecheckIface iface)-  return (HomeModInfo iface details linkable)---- | Non-interactive, batch version of 'InteractiveEval.getDocs'.---   The interactive paths create problems in ghc-lib builds---- and leads to fun errors like "Cannot continue after interface file error".-getDocsBatch-  :: HscEnv-  -> Module  -- ^ a moudle where the names are in scope-  -> [Name]-  -> IO [Either String (Maybe HsDocString, IntMap HsDocString)]-getDocsBatch hsc_env _mod _names = do-    (msgs, res) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ forM _names $ \name ->-        case nameModule_maybe name of-            Nothing -> return (Left $ NameHasNoModule name)-            Just mod -> do-             ModIface { mi_doc_hdr = mb_doc_hdr-                      , mi_decl_docs = DeclDocMap dmap-                      , mi_arg_docs = ArgDocMap amap-                      } <- loadModuleInterface "getModuleInterface" mod-             if isNothing mb_doc_hdr && Map.null dmap && null amap-               then pure (Left (NoDocsInIface mod $ compiled name))-               else pure (Right ( Map.lookup name dmap ,-#if !MIN_VERSION_ghc(9,2,0)-                                  IntMap.fromAscList $ Map.toAscList $-#endif-                                  Map.findWithDefault mempty name amap))-    case res of-        Just x  -> return $ map (first $ T.unpack . printOutputable) x-        Nothing -> throwErrors-#if MIN_VERSION_ghc(9,2,0)-                     $ Error.getErrorMessages msgs-#else-                     $ snd msgs-#endif-  where-    throwErrors = liftIO . throwIO . mkSrcErr-    compiled n =-      -- TODO: Find a more direct indicator.-      case nameSrcLoc n of-        RealSrcLoc {}   -> False-        UnhelpfulLoc {} -> True--fakeSpan :: RealSrcSpan-fakeSpan = realSrcLocSpan $ mkRealSrcLoc (Util.fsLit "<ghcide>") 1 1---- | Non-interactive, batch version of 'InteractiveEval.lookupNames'.---   The interactive paths create problems in ghc-lib builds---- and leads to fun errors like "Cannot continue after interface file error".-lookupName :: HscEnv-           -> Module -- ^ A module where the Names are in scope-           -> Name-           -> IO (Maybe TyThing)-lookupName hsc_env mod name = do-    (_messages, res) <- initTc hsc_env HsSrcFile False mod fakeSpan $ do-        tcthing <- tcLookup name-        case tcthing of-            AGlobal thing    -> return thing-            ATcId{tct_id=id} -> return (AnId id)-            _                -> panic "tcRnLookupName'"-    return res---pathToModuleName :: FilePath -> ModuleName-pathToModuleName = mkModuleName . map rep-  where-      rep c | isPathSeparator c = '_'-      rep ':' = '_'-      rep c = c+{-# 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/Debouncer.hs view
@@ -50,9 +50,8 @@         sleep delay         fire         atomically $ STM.delete k d-    do-        prev <- atomicallyNamed "debouncer" $ STM.focus (Focus.lookup <* Focus.insert a) k d-        traverse_ cancel prev+    prev <- atomicallyNamed "debouncer" $ STM.focus (Focus.lookup <* Focus.insert a) k d+    traverse_ cancel prev  -- | Debouncer used in the DAML CLI compiler that emits events immediately. noopDebouncer :: Debouncer k
src/Development/IDE/Core/FileExists.hs view
@@ -27,19 +27,21 @@ import qualified Development.IDE.Core.Shake            as Shake import           Development.IDE.Graph import           Development.IDE.Types.Location-import           Development.IDE.Types.Logger          (Pretty (pretty),-                                                        Recorder, WithPriority,-                                                        cmapWithPrio) import           Development.IDE.Types.Options+import           Development.IDE.Types.Shake           (toKey) import qualified Focus+import           Ide.Logger                            (Pretty (pretty),+                                                        Recorder, WithPriority,+                                                        cmapWithPrio) import           Ide.Plugin.Config                     (Config)+import           Language.LSP.Protocol.Types import           Language.LSP.Server                   hiding (getVirtualFile)-import           Language.LSP.Types import qualified StmContainers.Map                     as STM import qualified System.Directory                      as Dir import qualified System.FilePath.Glob                  as Glob  {- Note [File existence cache and LSP file watchers]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some LSP servers provide the ability to register file watches with the client, which will then notify us of file changes. Some clients can do this more efficiently than us, or generally it's a tricky problem@@ -95,8 +97,8 @@  instance Pretty Log where   pretty = \case-    LogFileStore log -> pretty log-    LogShake log     -> pretty log+    LogFileStore msg -> pretty msg+    LogShake msg     -> pretty msg  -- | Grab the current global value of 'FileExistsMap' without acquiring a dependency getFileExistsMapUntracked :: Action FileExistsMap@@ -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@@ -117,16 +119,16 @@     -- See Note [Invalidating file existence results]     -- flush previous values     let (fileModifChanges, fileExistChanges) =-            partition ((== FcChanged) . 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)+            partition ((== FileChangeType_Changed) . snd) changes+    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 FcCreated = Just True-fromChange FcDeleted = Just False-fromChange FcChanged = Nothing+fromChange FileChangeType_Created = Just True+fromChange FileChangeType_Deleted = Just False+fromChange FileChangeType_Changed = Nothing  ------------------------------------------------------------------------------------- @@ -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
@@ -1,10 +1,12 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0-{-# LANGUAGE CPP          #-} {-# LANGUAGE TypeFamilies #-}  module Development.IDE.Core.FileStore(+    getFileModTimeContents,     getFileContents,+    getUriContents,+    getVersionedTextDoc,     setFileModified,     setSomethingModified,     fileStoreRules,@@ -18,66 +20,63 @@     getModTime,     isWatchSupported,     registerFileWatches,-    Log(..)+    shareFilePath,+    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 import qualified Data.ByteString                              as BS-import           Data.Either.Extra-import qualified Data.Rope.UTF16                              as Rope+import qualified Data.ByteString.Lazy                         as LBS+import qualified Data.HashMap.Strict                          as HashMap+import           Data.IORef import qualified Data.Text                                    as T+import qualified Data.Text                                    as Text+import           Data.Text.Utf16.Rope.Mixed                   (Rope) import           Data.Time import           Data.Time.Clock.POSIX+import           Development.IDE.Core.FileUtils+import           Development.IDE.Core.IdeConfiguration        (isWorkspaceFile) import           Development.IDE.Core.RuleTypes import           Development.IDE.Core.Shake                   hiding (Log)-import           Development.IDE.Core.FileUtils+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.Plugin.Config                            (CheckParents (..),-                                                               Config)-import           System.IO.Error--#ifdef mingw32_HOST_OS-import qualified System.Directory                             as Dir-#else-#endif--import qualified Development.IDE.Types.Logger                 as L--import qualified Data.Binary                                  as B-import qualified Data.ByteString.Lazy                         as LBS-import qualified Data.HashSet                                 as HSet-import           Data.List                                    (foldl')-import qualified Data.Text                                    as Text-import           Development.IDE.Core.IdeConfiguration        (isWorkspaceFile)-import qualified Development.IDE.Core.Shake                   as Shake-import           Development.IDE.Types.Logger                 (Pretty (pretty),+import           Ide.Logger                                   (Pretty (pretty),                                                                Priority (Info),                                                                Recorder,                                                                WithPriority,                                                                cmapWithPrio,                                                                logWith, viaShow,                                                                (<+>))-import qualified Language.LSP.Server                          as LSP-import           Language.LSP.Types                           (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions),-                                                               FileChangeType (FcChanged),+import qualified Ide.Logger                                   as L+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 (..),-                                                               WatchKind (..),-                                                               _watchers)-import qualified Language.LSP.Types                           as LSP-import qualified Language.LSP.Types.Capabilities              as LSP+                                                               TextDocumentIdentifier (..),+                                                               VersionedTextDocumentIdentifier (..),+                                                               _watchers,+                                                               uriToNormalizedFilePath)+import qualified Language.LSP.Protocol.Types                  as LSP+import qualified Language.LSP.Server                          as LSP import           Language.LSP.VFS import           System.FilePath+import           System.IO.Error+import           System.IO.Unsafe  data Log   = LogCouldNotIdentifyReverseDeps !NormalizedFilePath@@ -90,11 +89,11 @@     LogCouldNotIdentifyReverseDeps path ->       "Could not identify reverse dependencies for" <+> viaShow path     (LogTypeCheckingReverseDeps path reverseDepPaths) ->-      "Typechecking reverse dependecies for"+      "Typechecking reverse dependencies for"       <+> viaShow path       <> ":"       <+> pretty (fmap (fmap show) reverseDepPaths)-    LogShake log -> pretty log+    LogShake msg -> pretty msg  addWatchedFileRule :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \AddWatchedFile f -> do@@ -147,31 +146,58 @@                         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. isInterface :: NormalizedFilePath -> Bool-isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hi-boot"]+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, 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-            FcChanged-            --  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@@ -183,26 +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 . _text <$> mbVirtual+        pure $ _file_text <$> mbVirtual     pure ([], Just (time, res)) -ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a)-ideTryIOException fp act =-  mapLeft-      (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e)-      <$> try act- -- | Returns the modification time and the contents. --   For VFS paths, the modification time is the current time.-getFileContents :: NormalizedFilePath -> Action (UTCTime, Maybe T.Text)-getFileContents f = do-    (fv, txt) <- use_ GetFileContents f+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@@ -212,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 @@ -227,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 @@ -246,25 +291,21 @@  typecheckParentsAction :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action () typecheckParentsAction recorder nfp = do-    revs <- transitiveReverseDependencies nfp <$> useNoFile_ GetModuleGraph-    let log = logWith recorder+    revs <- transitiveReverseDependencies nfp <$> useWithSeparateFingerprintRule_ GetModuleGraphTransReverseDepsFingerprints GetModuleGraph nfp     case revs of-      Nothing -> log Info $ LogCouldNotIdentifyReverseDeps nfp+      Nothing -> logWith recorder Info $ LogCouldNotIdentifyReverseDeps nfp       Just rs -> do-        log Info $ LogTypeCheckingReverseDeps nfp revs+        logWith recorder Info $ LogTypeCheckingReverseDeps nfp revs         void $ uses GetModIface rs  -- | 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 HSet.insert) 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@@ -272,26 +313,27 @@       if watchSupported       then do         let-          regParams    = LSP.RegistrationParams (List [LSP.SomeRegistration registration])+          regParams    = LSP.RegistrationParams  [toUntypedRegistration registration]           -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't).           -- We could also use something like a random UUID, as some other servers do, but this works for           -- our purposes.-          registration = LSP.Registration "globalFileWatches"-                                           LSP.SWorkspaceDidChangeWatchedFiles-                                           regOptions+          registration = LSP.TRegistration { _id ="globalFileWatches"+                                           , _method = LSP.SMethod_WorkspaceDidChangeWatchedFiles+                                           , _registerOptions = Just regOptions}           regOptions =-            DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers }+            DidChangeWatchedFilesRegistrationOptions { _watchers = watchers }           -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind-          watchKind = WatchKind { _watchCreate = True, _watchChange = True, _watchDelete = True}+          -- WatchKind_Custom 7 is for create, change, and delete+          watchKind = LSP.WatchKind_Custom 7           -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is           -- The patterns will be something like "**/.hs", i.e. "any number of directory segments,           -- followed by a file with an extension 'hs'.           watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind }           -- We use multiple watchers instead of one using '{}' because lsp-test doesn't           -- support that: https://github.com/bubba/lsp-test/issues/77-          watchers = [ watcher (Text.pack glob) | glob <- globs ]+          watchers = [ watcher (LSP.GlobPattern (LSP.InL (LSP.Pattern (Text.pack glob)))) | glob <- globs ] -        void $ LSP.sendRequest LSP.SClientRegisterCapability regParams (const $ pure ()) -- TODO handle response+        void $ LSP.sendRequest LSP.SMethod_ClientRegisterCapability regParams (const $ pure ()) -- TODO handle response         return True       else return False @@ -305,3 +347,16 @@               , Just True <- _dynamicRegistration                 -> True               | otherwise -> False++filePathMap :: IORef (HashMap.HashMap FilePath FilePath)+filePathMap = unsafePerformIO $ newIORef HashMap.empty+{-# NOINLINE filePathMap #-}++shareFilePath :: FilePath -> FilePath+shareFilePath k = unsafePerformIO $ do+  atomicModifyIORef' filePathMap $ \km ->+    let new_key = HashMap.lookup k km+    in case new_key of+          Just v  -> (km, v)+          Nothing -> (HashMap.insert k k km, k)+{-# NOINLINE shareFilePath  #-}
src/Development/IDE/Core/FileUtils.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP          #-}+{-# LANGUAGE CPP #-}  module Development.IDE.Core.FileUtils(     getModTime,@@ -6,11 +6,11 @@   import           Data.Time.Clock.POSIX+ #ifdef mingw32_HOST_OS-import qualified System.Directory                             as Dir+import qualified System.Directory      as Dir #else-import           System.Posix.Files                           (getFileStatus,-                                                               modificationTimeHiRes)+import           System.Posix.Files    (getFileStatus, modificationTimeHiRes) #endif  -- Dir.getModificationTime is surprisingly slow since it performs
src/Development/IDE/Core/IdeConfiguration.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DuplicateRecordFields #-} module Development.IDE.Core.IdeConfiguration   ( IdeConfiguration(..)   , registerIdeConfiguration@@ -13,16 +12,17 @@ where  import           Control.Concurrent.Strict+ import           Control.Monad import           Control.Monad.IO.Class import           Data.Aeson.Types               (Value)-import           Data.HashSet                   (HashSet, singleton) import           Data.Hashable                  (Hashed, hashed, unhashed)-import           Data.Text                      (Text, isPrefixOf)+import           Data.HashSet                   (HashSet, singleton)+import           Data.Text                      (isPrefixOf) import           Development.IDE.Core.Shake import           Development.IDE.Graph import           Development.IDE.Types.Location-import           Language.LSP.Types+import           Language.LSP.Protocol.Types import           System.FilePath                (isRelative)  -- | Lsp client relevant configuration details@@ -49,15 +49,15 @@   IdeConfiguration {..}  where   workspaceFolders =-    foldMap (singleton . toNormalizedUri) _rootUri+    foldMap (singleton . toNormalizedUri) (nullToMaybe _rootUri)       <> (foldMap . foldMap)            (singleton . parseWorkspaceFolder)-           _workspaceFolders+           (nullToMaybe =<< _workspaceFolders)   clientSettings = hashed _initializationOptions  parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri-parseWorkspaceFolder =-  toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text)+parseWorkspaceFolder WorkspaceFolder{_uri} =+  toNormalizedUri _uri  modifyWorkspaceFolders   :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()
+ 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'@@ -24,7 +23,7 @@ import           Control.Monad.IO.Class import           Data.HashMap.Strict                      (HashMap) import qualified Data.HashMap.Strict                      as HashMap-import qualified Data.Text                                as T+import           Data.Proxy import           Development.IDE.Graph  import           Control.Concurrent.STM.Stats             (atomically,@@ -39,21 +38,24 @@ import           Development.IDE.Plugin.Completions.Types import           Development.IDE.Types.Exports import           Development.IDE.Types.Location-import           Development.IDE.Types.Logger             (Pretty (pretty),+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)-import           Development.IDE.Types.Options            (IdeTesting (..))+                                                           logWith)+import qualified Language.LSP.Protocol.Message            as LSP import qualified Language.LSP.Server                      as LSP-import qualified Language.LSP.Types                       as LSP  data Log = LogShake Shake.Log   deriving Show  instance Pretty Log where   pretty = \case-    LogShake log -> pretty log+    LogShake msg -> pretty msg  newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) @@ -101,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) $-        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@@ -130,13 +134,14 @@ kick = do     files <- HashMap.keys <$> getFilesOfInterestUntracked     ShakeExtras{exportsMap, ideTesting = IdeTesting testing, lspEnv, progress} <- getShakeExtras-    let signal msg = when testing $ liftIO $+    let signal :: KnownSymbol s => Proxy s -> Action ()+        signal msg = when testing $ liftIO $             mRunLspT lspEnv $-                LSP.sendNotification (LSP.SCustomMethod msg) $+                LSP.sendNotification (LSP.SMethod_CustomMethod msg) $                 toJSON $ map fromNormalizedFilePath files -    signal "kick/start"-    liftIO $ progressUpdate progress KickStarted+    signal (Proxy @"kick/start")+    liftIO $ progressUpdate progress ProgressNewStarted      -- Update the exports map     results <- uses GenerateCore files@@ -147,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@@ -155,4 +160,4 @@         void garbageCollectDirtyKeys         liftIO $ writeVar var False -    signal "kick/done"+    signal (Proxy @"kick/done")
+ src/Development/IDE/Core/PluginUtils.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE GADTs #-}+module Development.IDE.Core.PluginUtils+(-- * Wrapped Action functions+  runActionE+, runActionMT+, useE+, useMT+, usesE+, usesMT+, useWithStaleE+, useWithStaleMT+-- * Wrapped IdeAction functions+, runIdeActionE+, runIdeActionMT+, useWithStaleFastE+, useWithStaleFastMT+, uriToFilePathE+-- * Wrapped PositionMapping functions+, toCurrentPositionE+, toCurrentPositionMT+, fromCurrentPositionE+, fromCurrentPositionMT+, toCurrentRangeE+, toCurrentRangeMT+, fromCurrentRangeE+, 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 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,+                                                       shakeEnqueue)+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+-- ----------------------------------------------------------------------------++-- |ExceptT version of `runAction`, takes a ExceptT Action+runActionE :: MonadIO m => String -> IdeState -> ExceptT e Action a -> ExceptT e m a+runActionE herald ide act =+  mapExceptT liftIO . ExceptT $+    join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runExceptT act)++-- |MaybeT version of `runAction`, takes a MaybeT Action+runActionMT :: MonadIO m => String -> IdeState -> MaybeT Action a -> MaybeT m a+runActionMT herald ide act =+  mapMaybeT liftIO . MaybeT $+    join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runMaybeT act)++-- |ExceptT version of `use` that throws a PluginRuleFailed upon failure+useE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError Action v+useE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useMT k++-- |MaybeT version of `use`+useMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v+useMT k = MaybeT . Shake.use k++-- |ExceptT version of `uses` that throws a PluginRuleFailed upon failure+usesE :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> ExceptT PluginError Action (f v)+usesE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . usesMT k++-- |MaybeT version of `uses`+usesMT :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> MaybeT Action (f v)+usesMT k xs = MaybeT $ sequence <$> Shake.uses k xs++-- |ExceptT version of `useWithStale` that throws a PluginRuleFailed upon+-- failure+useWithStaleE :: IdeRule k v+    => k -> NormalizedFilePath -> ExceptT PluginError Action (v, PositionMapping)+useWithStaleE key = maybeToExceptT (PluginRuleFailed (T.pack $ show key)) . useWithStaleMT key++-- |MaybeT version of `useWithStale`+useWithStaleMT :: IdeRule k v+    => k -> NormalizedFilePath -> MaybeT Action (v, PositionMapping)+useWithStaleMT key file = MaybeT $ runIdentity <$> Shake.usesWithStale key (Identity file)++-- ----------------------------------------------------------------------------+-- IdeAction wrappers+-- ----------------------------------------------------------------------------++-- |ExceptT version of `runIdeAction`, takes a ExceptT IdeAction+runIdeActionE :: MonadIO m => String -> Shake.ShakeExtras -> ExceptT e IdeAction a -> ExceptT e m a+runIdeActionE _herald s i = ExceptT $ liftIO $ runReaderT (Shake.runIdeActionT $ runExceptT i) s++-- |MaybeT version of `runIdeAction`, takes a MaybeT IdeAction+runIdeActionMT :: MonadIO m => String -> Shake.ShakeExtras -> MaybeT IdeAction a -> MaybeT m a+runIdeActionMT _herald s i = MaybeT $ liftIO $ runReaderT (Shake.runIdeActionT $ runMaybeT i) s++-- |ExceptT version of `useWithStaleFast` that throws a PluginRuleFailed upon+-- failure+useWithStaleFastE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError IdeAction (v, PositionMapping)+useWithStaleFastE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useWithStaleFastMT k++-- |MaybeT version of `useWithStaleFast`+useWithStaleFastMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping)+useWithStaleFastMT k = MaybeT . Shake.useWithStaleFast k++-- ----------------------------------------------------------------------------+-- Location wrappers+-- ----------------------------------------------------------------------------++-- |ExceptT version of `uriToFilePath` that throws a PluginInvalidParams upon+-- failure+uriToFilePathE :: Monad m => LSP.Uri -> ExceptT PluginError m FilePath+uriToFilePathE uri = maybeToExceptT (PluginInvalidParams (T.pack $ "uriToFilePath' failed. Uri:" <>  show uri)) $ uriToFilePathMT uri++-- |MaybeT version of `uriToFilePath`+uriToFilePathMT :: Monad m => LSP.Uri -> MaybeT m FilePath+uriToFilePathMT = MaybeT . pure . Location.uriToFilePath'++-- ----------------------------------------------------------------------------+-- PositionMapping wrappers+-- ----------------------------------------------------------------------------++-- |ExceptT version of `toCurrentPosition` that throws a PluginInvalidUserState+-- upon failure+toCurrentPositionE :: Monad m => PositionMapping -> LSP.Position -> ExceptT PluginError m LSP.Position+toCurrentPositionE mapping = maybeToExceptT (PluginInvalidUserState "toCurrentPosition"). toCurrentPositionMT mapping++-- |MaybeT version of `toCurrentPosition`+toCurrentPositionMT :: Monad m => PositionMapping -> LSP.Position -> MaybeT m LSP.Position+toCurrentPositionMT mapping = MaybeT . pure . toCurrentPosition mapping++-- |ExceptT version of `fromCurrentPosition` that throws a+-- PluginInvalidUserState upon failure+fromCurrentPositionE :: Monad m => PositionMapping -> LSP.Position -> ExceptT PluginError m LSP.Position+fromCurrentPositionE mapping = maybeToExceptT (PluginInvalidUserState "fromCurrentPosition") . fromCurrentPositionMT mapping++-- |MaybeT version of `fromCurrentPosition`+fromCurrentPositionMT :: Monad m => PositionMapping -> LSP.Position -> MaybeT m LSP.Position+fromCurrentPositionMT mapping = MaybeT . pure . fromCurrentPosition mapping++-- |ExceptT version of `toCurrentRange` that throws a PluginInvalidUserState+-- upon failure+toCurrentRangeE :: Monad m => PositionMapping -> LSP.Range -> ExceptT PluginError m LSP.Range+toCurrentRangeE mapping = maybeToExceptT (PluginInvalidUserState "toCurrentRange") . toCurrentRangeMT mapping++-- |MaybeT version of `toCurrentRange`+toCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range+toCurrentRangeMT mapping = MaybeT . pure . toCurrentRange mapping++-- |ExceptT version of `fromCurrentRange` that throws a PluginInvalidUserState+-- upon failure+fromCurrentRangeE :: Monad m => PositionMapping -> LSP.Range -> ExceptT PluginError m LSP.Range+fromCurrentRangeE mapping = maybeToExceptT (PluginInvalidUserState "fromCurrentRange") . fromCurrentRangeMT mapping++-- |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
@@ -9,7 +9,7 @@   , fromCurrentPosition   , toCurrentPosition   , PositionDelta(..)-  , addDelta+  , addOldDelta   , idDelta   , composeDelta   , mkDelta@@ -24,15 +24,18 @@   ) where  import           Control.DeepSeq+import           Control.Lens                ((^.)) import           Control.Monad import           Data.Algorithm.Diff import           Data.Bifunctor import           Data.List-import qualified Data.Text           as T-import qualified Data.Vector.Unboxed as V-import           Language.LSP.Types  (Position (Position), Range (Range),-                                      TextDocumentContentChangeEvent (TextDocumentContentChangeEvent),-                                      UInt)+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),+                                              UInt, type (|?) (InL))  -- | Either an exact position, or the range of text that was substituted data PositionResult a@@ -101,7 +104,7 @@ zeroMapping = PositionMapping idDelta  -- | Compose two position mappings. Composes in the same way as function--- composition (ie the second argument is applyed to the position first).+-- composition (ie the second argument is applied to the position first). composeDelta :: PositionDelta                 -> PositionDelta                 -> PositionDelta@@ -116,14 +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 (Just r) _ t) = PositionDelta-    { toDelta = toCurrent r t <=< toDelta-    , fromDelta = fromDelta <=< fromCurrent r t+applyChange PositionDelta{..} (TextDocumentContentChangeEvent (InL x)) = PositionDelta+    { toDelta = toCurrent (x ^. L.range) (x ^. L.text) <=< toDelta+    , fromDelta = fromDelta <=< fromCurrent (x ^. L.range) (x ^. L.text)     } applyChange posMapping _ = posMapping @@ -214,9 +223,9 @@           line' -> PositionExact (Position (fromIntegral line') col)      -- Construct a mapping between lines in the diff-    -- -1 for unsucessful mapping+    -- -1 for unsuccessful mapping     go :: [Diff T.Text] -> Int -> Int -> ([Int], [Int])     go [] _ _ = ([],[])-    go (Both _ _ : xs) !lold !lnew = bimap  (lnew :) (lold :) $ go xs (lold+1) (lnew+1)-    go (First _  : xs) !lold !lnew = first  (-1   :)          $ go xs (lold+1) lnew-    go (Second _ : xs) !lold !lnew = second          (-1   :) $ go xs lold     (lnew+1)+    go (Both _ _ : xs) !glold !glnew = bimap  (glnew :) (glold :) $ go xs (glold+1) (glnew+1)+    go (First _  : xs) !glold !glnew = first  (-1   :)          $ go xs (glold+1) glnew+    go (Second _ : xs) !glold !glnew = second          (-1   :) $ go xs glold     (glnew+1)
src/Development/IDE/Core/Preprocessor.hs view
@@ -1,14 +1,16 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0+{-# LANGUAGE CPP #-}  module Development.IDE.Core.Preprocessor   ( preprocessor   ) where -import           Development.IDE.GHC.CPP import           Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat.Util   as Util+import           Development.IDE.GHC.CPP import           Development.IDE.GHC.Orphans       ()+import qualified Development.IDE.GHC.Util          as Util  import           Control.DeepSeq                   (NFData (rnf)) import           Control.Exception                 (evaluate)@@ -26,35 +28,44 @@ import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Location import qualified GHC.LanguageExtensions            as LangExt+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.-preprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> ExceptT [FileDiagnostic] IO (Util.StringBuffer, [String], DynFlags)-preprocessor env0 filename mbContents = do+preprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> ExceptT [FileDiagnostic] IO (Util.StringBuffer, [String], HscEnv, Util.Fingerprint)+preprocessor env filename mbContents = do     -- Perform unlit     (isOnDisk, contents) <-         if isLiterate filename then do-            newcontent <- liftIO $ runLhs env0 filename mbContents+            newcontent <- liftIO $ runLhs env filename mbContents             return (False, newcontent)         else do             contents <- liftIO $ maybe (Util.hGetStringBuffer filename) return mbContents             let isOnDisk = isNothing mbContents             return (isOnDisk, contents) +    -- Compute the source hash before the preprocessor because this is+    -- how GHC does it.+    !src_hash <- liftIO $ Util.fingerprintFromStringBuffer contents+     -- Perform cpp-    (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env0 filename contents-    let env1 = hscSetFlags dflags env0-    let logger = hsc_logger env1-    (isOnDisk, contents, opts, dflags) <-+    (opts, pEnv) <- ExceptT $ parsePragmasIntoHscEnv env filename contents+    let dflags = hsc_dflags pEnv+    let logger = hsc_logger pEnv+    (newIsOnDisk, newContents, newOpts, newEnv) <-         if not $ xopt LangExt.Cpp dflags then-            return (isOnDisk, contents, opts, dflags)+            return (isOnDisk, contents, opts, pEnv)         else do             cppLogs <- liftIO $ newIORef []             let newLogger = pushLogHook (const (logActionCompat $ logAction cppLogs)) logger-            contents <- ExceptT-                        $ (Right <$> (runCpp (putLogHook newLogger env1) filename+            con <- ExceptT+                        $ (Right <$> (runCpp (putLogHook newLogger pEnv) filename                                        $ if isOnDisk then Nothing else Just contents))                             `catch`                             ( \(e :: Util.GhcException) -> do@@ -63,23 +74,24 @@                                   []    -> throw e                                   diags -> return $ Left diags                             )-            (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env1 filename contents-            return (False, contents, opts, dflags)+            (options, hscEnv) <- ExceptT $ parsePragmasIntoHscEnv pEnv filename con+            return (False, con, options, hscEnv)      -- Perform preprocessor     if not $ gopt Opt_Pp dflags then-        return (contents, opts, dflags)+        return (newContents, newOpts, newEnv, src_hash)     else do-        contents <- liftIO $ runPreprocessor env1 filename $ if isOnDisk then Nothing else Just contents-        (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env1 filename contents-        return (contents, opts, dflags)+        con <- liftIO $ runPreprocessor newEnv filename $ if newIsOnDisk then Nothing else Just newContents+        (options, hscEnv) <- ExceptT $ parsePragmasIntoHscEnv newEnv filename con+        return (con, options, hscEnv, src_hash)   where     logAction :: IORef [CPPLog] -> LogActionCompat     logAction cppLogs dflags _reason severity srcSpan _style msg = do-      let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg-      modifyIORef cppLogs (log :)+      let cppLog = CPPLog (fromMaybe SevWarning severity) srcSpan $ T.pack $ renderWithContext (log_default_user_context dflags) msg+      modifyIORef cppLogs (cppLog :)  + data CPPLog = CPPLog Severity SrcSpan Text   deriving (Show) @@ -95,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@@ -103,12 +115,12 @@     -- informational log messages and attaches them to the initial log message.     go :: [CPPDiag] -> [CPPLog] -> [CPPDiag]     go acc [] = reverse $ map (\d -> d {cdMessage = reverse $ cdMessage d}) acc-    go acc (CPPLog sev (RealSrcSpan span _) msg : logs) =-      let diag = CPPDiag (realSrcSpanToRange span) (toDSeverity sev) [msg]-       in go (diag : acc) logs-    go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) =-      go (diag {cdMessage = msg : cdMessage diag} : diags) logs-    go [] (CPPLog _sev (UnhelpfulSpan _) _msg : logs) = go [] logs+    go acc (CPPLog sev (RealSrcSpan rSpan _) msg : gLogs) =+      let diag = CPPDiag (realSrcSpanToRange rSpan) (toDSeverity sev) [msg]+       in go (diag : acc) gLogs+    go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : gLogs) =+      go (diag {cdMessage = msg : cdMessage diag} : diags) gLogs+    go [] (CPPLog _sev (UnhelpfulSpan _) _msg : gLogs) = go [] gLogs     cppDiagToDiagnostic :: CPPDiag -> Diagnostic     cppDiagToDiagnostic d =       Diagnostic@@ -118,7 +130,9 @@           _source = Just "CPP",           _message = T.unlines $ cdMessage d,           _relatedInformation = Nothing,-          _tags = Nothing+          _tags = Nothing,+          _codeDescription = Nothing,+          _data_ = Nothing         }  @@ -127,20 +141,29 @@   -- | This reads the pragma information directly from the provided buffer.-parsePragmasIntoDynFlags+parsePragmasIntoHscEnv     :: HscEnv     -> FilePath     -> Util.StringBuffer-    -> IO (Either [FileDiagnostic] ([String], DynFlags))-parsePragmasIntoDynFlags env fp contents = catchSrcErrors dflags0 "pragmas" $ do-    let opts = getOptions dflags0 contents fp+    -> IO (Either [FileDiagnostic] ([String], HscEnv))+parsePragmasIntoHscEnv env fp contents = catchSrcErrors dflags0 "pragmas" $ do+#if MIN_VERSION_ghc(9,13,0)+    let supportedExts = supportedLanguagePragmas dflags0+    let (_warns,opts) = getOptions (initParserOpts dflags0) supportedExts contents fp+#else+    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)-    return (map unLoc opts, disableWarningsAsErrors (hsc_dflags hsc_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  -- | Run (unlit) literate haskell preprocessor on a file, or buffer if set@@ -175,17 +198,17 @@  -- | Run CPP on a file runCpp :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer-runCpp env0 filename contents = withTempDir $ \dir -> do+runCpp env0 filename mbContents = withTempDir $ \dir -> do     let out = dir </> takeFileName filename <.> "out"     let dflags1 = addOptP "-D__GHCIDE__" (hsc_dflags env0)     let env1 = hscSetFlags dflags1 env0 -    case contents of+    case mbContents of         Nothing -> do             -- Happy case, file is not modified, so run CPP on it in-place             -- which also makes things like relative #include files work             -- and means location information is correct-            doCpp env1 True filename out+            doCpp env1 filename out             liftIO $ Util.hGetStringBuffer out          Just contents -> do@@ -199,26 +222,26 @@             let inp = dir </> "___GHCIDE_MAGIC___"             withBinaryFile inp WriteMode $ \h ->                 hPutStringBuffer h contents-            doCpp env2 True inp out+            doCpp env2 inp out              -- Fix up the filename in lines like:             -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___"             let tweak x-                    | Just x <- stripPrefix "# " x-                    , "___GHCIDE_MAGIC___" `isInfixOf` x-                    , let num = takeWhile (not . isSpace) x+                    | Just y <- stripPrefix "# " x+                    , "___GHCIDE_MAGIC___" `isInfixOf` y+                    , let num = takeWhile (not . isSpace) y                     -- important to use /, and never \ for paths, even on Windows, since then C escapes them                     -- and GHC gets all confused-                        = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""+                        = "# " <> num <> " \"" <> map (\z -> if isPathSeparator z then '/' else z) filename <> "\""                     | otherwise = x             Util.stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out   -- | Run a preprocessor on a file runPreprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer-runPreprocessor env filename contents = withTempDir $ \dir -> do+runPreprocessor env filename mbContents = withTempDir $ \dir -> do     let out = dir </> takeFileName filename <.> "out"-    inp <- case contents of+    inp <- case mbContents of         Nothing -> return filename         Just contents -> do             let inp = dir </> takeFileName filename <.> "hs"
src/Development/IDE/Core/ProgressReporting.hs view
@@ -1,201 +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.Monad.Extra+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.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.Types+import           Language.LSP.Server            (ProgressAmount (..),+                                                 ProgressCancellable (..),+                                                 withProgress) import qualified Language.LSP.Server            as LSP-import           Language.LSP.Types-import qualified Language.LSP.Types             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 () -> Transition -> State -> IO State-updateState _      _                    Stopped     = pure Stopped-updateState start (Event KickStarted)   NotStarted  = Running <$> async start-updateState start (Event KickStarted)   (Running a) = cancel a >> Running <$> async 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 _ _ 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 lspEnv optProgressStyle = do-    inProgressState <- newInProgress-    progressState <- newVar NotStarted-    let progressUpdate event = updateStateVar $ Event event-        progressStop   =  updateStateVar StopProgress-        updateStateVar = modifyVar_ progressState . updateState (mRunLspT lspEnv $ 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 <- ProgressTextToken . 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.sendRequest LSP.SWindowWorkDoneProgressCreate-                LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b-            ready <- liftIO $ waitBarrier b+-- | `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. -            for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0)-            where-                start id = LSP.sendNotification LSP.SProgress $-                    LSP.ProgressParams-                        { _token = id-                        , _value = LSP.Begin $ WorkDoneProgressBeginParams-                          { _title = "Processing"-                          , _cancellable = Nothing-                          , _message = Nothing-                          , _percentage = Nothing-                          }-                        }-                stop id = LSP.sendNotification LSP.SProgress-                    LSP.ProgressParams-                        { _token = id-                        , _value = LSP.End WorkDoneProgressEndParams-                          { _message = Nothing-                          }-                        }-                loop _ _ | optProgressStyle == NoProgress =-                    forever $ liftIO $ threadDelay maxBound-                loop id prevPct = do-                    done <- liftIO $ readTVarIO doneVar-                    todo <- liftIO $ readTVarIO todoVar-                    liftIO $ sleep after-                    if todo == 0 then loop id 0 else do-                        let-                            nextFrac :: Double-                            nextFrac = fromIntegral done / fromIntegral todo-                            nextPct :: UInt-                            nextPct = floor $ 100 * nextFrac-                        when (nextPct /= prevPct) $-                          LSP.sendNotification LSP.SProgress $-                          LSP.ProgressParams-                              { _token = id-                              , _value = LSP.Report $ case optProgressStyle of-                                  Explicit -> LSP.WorkDoneProgressReportParams-                                    { _cancellable = Nothing-                                    , _message = Just $ T.pack $ show done <> "/" <> show todo-                                    , _percentage = Nothing-                                    }-                                  Percentage -> LSP.WorkDoneProgressReportParams-                                    { _cancellable = Nothing-                                    , _message = Nothing-                                    , _percentage = Just nextPct-                                    }-                                  NoProgress -> error "unreachable"-                              }-                        loop id nextPct+        f = recordProgress inProgress file -        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+-- 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) -mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m ()+      _ <- 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,6 +17,7 @@     ) where  import           Control.DeepSeq+import qualified Control.Exception                            as E import           Control.Lens import           Data.Aeson.Types                             (Value) import           Data.Hashable@@ -26,24 +27,28 @@ import           Development.IDE.GHC.Compat                   hiding                                                               (HieFileResult) import           Development.IDE.GHC.Compat.Util+import           Development.IDE.GHC.CoreFile import           Development.IDE.GHC.Util import           Development.IDE.Graph import           Development.IDE.Import.DependencyInformation 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 qualified Data.Binary                                  as B import           Data.ByteString                              (ByteString)-import qualified Data.ByteString.Lazy                         as LBS-import           Data.Text                                    (Text)-import           Data.Time+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           Language.LSP.Types                           (Int32,+import           Ide.Logger                                   (Pretty (..),+                                                               viaShow)+import           Language.LSP.Protocol.Types                  (Int32,                                                                NormalizedFilePath)  data LinkableType = ObjectLinkable | BCOLinkable@@ -70,13 +75,14 @@ -- all comments included using Opt_KeepRawTokenStream type instance RuleResult GetParsedModuleWithComments = ParsedModule --- | The dependency information produced by following the imports recursively.--- This rule will succeed even if there is an error, e.g., a module could not be located,--- a module could not be parsed or an import cycle.-type instance RuleResult GetDependencyInformation = DependencyInformation- 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@@ -87,12 +93,32 @@ type instance RuleResult GenerateCore = ModGuts  data GenerateCore = GenerateCore-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GenerateCore instance NFData   GenerateCore +type instance RuleResult GetLinkable = LinkableResult++data LinkableResult+  = LinkableResult+  { linkableHomeMod :: !HomeModInfo+  , linkableHash    :: !ByteString+  -- ^ The hash of the core file+  }++instance Show LinkableResult where+    show = show . mi_module . hm_iface . linkableHomeMod++instance NFData LinkableResult where+    rnf = rwhnf++data GetLinkable = GetLinkable+    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 @@ -136,11 +162,14 @@     , tmrTypechecked     :: TcGblEnv     , tmrTopLevelSplices :: Splices     -- ^ Typechecked splice information-    , tmrDeferedError    :: !Bool+    , tmrDeferredError   :: !Bool     -- ^ Did we defer any type errors for this module?-    , tmrRuntimeModules  :: !(ModuleEnv UTCTime)+    , tmrRuntimeModules  :: !(ModuleEnv ByteString)         -- ^ 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@@ -152,33 +181,32 @@ tmrModSummary = pm_mod_summary . tmrParsed  data HiFileResult = HiFileResult-    { hirModSummary :: !ModSummary+    { hirModSummary     :: !ModSummary     -- Bang patterns here are important to stop the result retaining     -- a reference to a typechecked module-    , hirHomeMod    :: !HomeModInfo-    -- ^ Includes the Linkable iff we need object files-    , hirIfaceFp    :: ByteString+    , hirModIface       :: !ModIface+    , hirModDetails     :: ModDetails+    -- ^ Populated lazily+    , hirIfaceFp        :: !ByteString     -- ^ Fingerprint for the ModIface-    , hirLinkableFp :: ByteString-    -- ^ Fingerprint for the Linkable-    , hirRuntimeModules :: !(ModuleEnv UTCTime)+    , hirRuntimeModules :: !(ModuleEnv ByteString)     -- ^ same as tmrRuntimeModules+    , hirCoreFp         :: !(Maybe (CoreFile, ByteString))+    -- ^ If we wrote a core file for this module, then its contents (lazily deserialised)+    -- along with its hash     }  hiFileFingerPrint :: HiFileResult -> ByteString-hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> hirLinkableFp+hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> maybe "" snd hirCoreFp -mkHiFileResult :: ModSummary -> HomeModInfo -> ModuleEnv UTCTime -> HiFileResult-mkHiFileResult hirModSummary hirHomeMod hirRuntimeModules = HiFileResult{..}+mkHiFileResult :: ModSummary -> ModIface -> ModDetails -> ModuleEnv ByteString -> Maybe (CoreFile, ByteString) -> HiFileResult+mkHiFileResult hirModSummary hirModIface hirModDetails hirRuntimeModules hirCoreFp =+    E.assert (case hirCoreFp of+                   Just (CoreFile{cf_iface_hash}, _) -> getModuleHash hirModIface == cf_iface_hash+                   _ -> True)+    HiFileResult{..}   where-    hirIfaceFp = fingerprintToBS . getModuleHash . hm_iface $ hirHomeMod -- will always be two bytes-    hirLinkableFp = case hm_linkable hirHomeMod of-      Nothing -> ""-      Just (linkableTime -> l)  -> LBS.toStrict $-        B.encode (fromEnum $ utctDay l, fromEnum $ utctDayTime l)--hirModIface :: HiFileResult -> ModIface-hirModIface = hm_iface . hirHomeMod+    hirIfaceFp = fingerprintToBS . getModuleHash $ hirModIface -- will always be two bytes  instance NFData HiFileResult where     rnf = rwhnf@@ -188,7 +216,7 @@  -- | Save the uncompressed AST here, we compress it just before writing to disk data HieAstResult-  = forall a. HAR+  = forall a . (Typeable a) =>  HAR   { hieModule :: Module   , hieAst    :: !(HieASTs a)   , refMap    :: RefMap a@@ -224,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@@ -243,8 +277,8 @@ -- | Resolve the imports in a module to the file path of a module in the same package type instance RuleResult GetLocatedImports = [(Located ModuleName, Maybe ArtifactsLocation)] --- | This rule is used to report import cycles. It depends on GetDependencyInformation.--- We cannot report the cycles directly from GetDependencyInformation since+-- | This rule is used to report import cycles. It depends on GetModuleGraph.+-- We cannot report the cycles directly from GetModuleGraph since -- we can only report diagnostics for the current file. type instance RuleResult ReportImportCycles = () @@ -260,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  @@ -289,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} @@ -314,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 @@ -338,6 +390,12 @@   { msrModSummary  :: !ModSummary   , msrImports     :: [LImportDecl GhcPs]   , msrFingerprint :: !Fingerprint+  , msrHscEnv      :: !HscEnv+  -- ^ HscEnv for this particular ModSummary.+  -- Contains initialised plugins, parsed options, etc...+  --+  -- Implicit assumption: DynFlags in 'msrModSummary' are the same as+  -- the DynFlags in 'msrHscEnv'.   }  instance Show ModSummaryResult where@@ -354,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 @@ -372,47 +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 GetDependencyInformation = GetDependencyInformation-    deriving (Eq, Show, Typeable, Generic)-instance Hashable GetDependencyInformation-instance NFData   GetDependencyInformation- 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 @@ -421,54 +489,55 @@         -- 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"-    show (GhcSessionDeps_ True) = "GhcSessionDepsFull"+    show (GhcSessionDeps_ True)  = "GhcSessionDepsFull"  pattern GhcSessionDeps :: GhcSessionDeps 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 --- | Get the vscode client settings stored in the ide state+-- 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 @@ -488,10 +557,41 @@ 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  makeLensesWith     (lensRules & lensField .~ mappingNamer (pure . (++ "L")))     ''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.++This is all well and good, but what if we want to write a Rule that depends+on the configuration? For example, we might have a plugin that provides+diagnostics - if the configuration changes to turn off that plugin, then+we need to invalidate the Rule producing the diagnostics so that they go+away. More broadly, any time we define a Rule that really depends on the+configuration, such that the dependency needs to be tracked and the Rule+invalidated when the configuration changes, we have a problem.++The solution is that we have to mirror the configuration into the state+that our build system knows about. That means that:+- We have a parallel record of the state in 'IdeConfiguration'+- We install a callback so that when the config changes we can update the+'IdeConfiguration' and mark the rule as dirty.++Then we can define a Rule that gets the configuration, and build Actions+on top of that that behave properly. However, these should really only+be used if you need the dependency tracking - for normal usage in handlers+the config can simply be accessed directly from LspT.++TODO(michaelpj): this is me writing down what I think the logic is, but+it doesn't make much sense to me. In particular, we *can* get the LspT+in an Action. So I don't know why we need to store it twice. We would+still need to invalidate the Rule otherwise we won't know it's changed,+though. See https://github.com/haskell/ghcide/pull/731 for some context.+-}
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,28 +11,25 @@ module Development.IDE.Core.Rules(     -- * Types     IdeState, GetParsedModule(..), TransitiveDependencies(..),-    Priority(..), GhcSessionIO(..), GetClientSettings(..),+    GhcSessionIO(..), GetClientSettings(..),     -- * Functions-    priorityTypeCheck,-    priorityGenerateCore,-    priorityFilesOfInterest,     runAction,     toIdeResult,     defineNoFile,     defineEarlyCutOffNoFile,     mainRule,     RulesConfig(..),-    getDependencies,     getParsedModule,     getParsedModuleWithComments,     getClientConfigAction,     usePropertyAction,+    usePropertyByPathAction,+    getHieFile,     -- * Rules     CompiledLinkables(..),     getParsedModuleRule,     getParsedModuleWithCommentsRule,     getLocatedImportsRule,-    getDependencyInformationRule,     reportImportCyclesRule,     typeCheckRule,     getDocMapRule,@@ -47,7 +43,6 @@     getHieAstsRule,     getBindingsRule,     needsCompilationRule,-    computeLinkableTypeForDynFlags,     generateCoreRule,     getImportMapRule,     regenerateHiFile,@@ -55,68 +50,80 @@     getParsedModuleDefinition,     typeCheckRuleDefinition,     getRebuildCount,+    getSourceFileSource,+    currentLinkables,     GhcSessionDepsConfig(..),     Log(..),     DisplayTHWarning(..),     ) where -#if !MIN_VERSION_ghc(8,8,0)-import           Control.Applicative                          (liftA2)-#endif-import           Control.Concurrent.Async                     (concurrently)+import           Control.Applicative+import           Control.Concurrent.STM.Stats                 (atomically)+import           Control.Concurrent.STM.TVar import           Control.Concurrent.Strict+import           Control.DeepSeq+import           Control.Exception                            (evaluate) 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-import           Data.Aeson                                   (Result (Success),-                                                               toJSON)-import qualified Data.Aeson.Types                             as A+import           Data.Aeson                                   (toJSON) import qualified Data.Binary                                  as B import qualified Data.ByteString                              as BS import qualified Data.ByteString.Lazy                         as LBS import           Data.Coerce+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                              (nubOrd, nubOrdOn) import qualified Data.Map                                     as M import           Data.Maybe-import qualified Data.Rope.UTF16                              as Rope-import qualified Data.Set                                     as Set+import           Data.Proxy 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,-                                                               resetInterfaceStore)+                                                               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,+                                                               loadInterface,+                                                               nest,+                                                               parseModule,+                                                               settings, vcat,                                                                (<+>))-import qualified Development.IDE.GHC.Compat                   as Compat hiding (vcat, nest)+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.ExactPrint hiding (LogShake, Log) import           Development.IDE.GHC.Util                     hiding                                                               (modifyDynFlags) import           Development.IDE.Graph@@ -129,44 +136,64 @@ 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.Types                           (SMethod (SCustomMethod, SWindowShowMessage), ShowMessageParams (ShowMessageParams), MessageType (MtInfo))-import           Language.LSP.VFS-import           System.Directory                             (makeAbsolute)-import           Data.Default                                 (def, Default) import           Ide.Plugin.Properties                        (HasProperty,+                                                               HasPropertyByPath,+                                                               KeyNamePath,                                                                KeyNameProxy,                                                                Properties,                                                                ToHsType,-                                                               useProperty)-import           Ide.PluginUtils                              (configForPlugin)+                                                               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 Development.IDE.Types.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat)-import qualified Development.IDE.Core.Shake as Shake-import qualified Development.IDE.GHC.ExactPrint as ExactPrint hiding (LogShake)-import qualified Development.IDE.Types.Logger as Logger-import qualified Development.IDE.Types.Shake as Shake+                                                               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   | LogReindexingHieFile !NormalizedFilePath   | LogLoadingHieFile !NormalizedFilePath   | LogLoadingHieFileFail !FilePath !SomeException   | LogLoadingHieFileSuccess !FilePath-  | LogExactPrint ExactPrint.Log+  | LogTypecheckedFOI !NormalizedFilePath   deriving Show  instance Pretty Log where   pretty = \case-    LogShake log -> pretty log+    LogShake msg -> pretty msg     LogReindexingHieFile path ->       "Re-indexing hie file for" <+> pretty (fromNormalizedFilePath path)     LogLoadingHieFile path ->@@ -178,7 +205,14 @@           , pretty (displayException e) ]     LogLoadingHieFileSuccess path ->       "SUCCEEDED LOADING HIE FILE FOR" <+> pretty path-    LogExactPrint log -> pretty log+    LogTypecheckedFOI path -> vcat+      [ "Typechecked a file which is not currently open in the editor:" <+> pretty (fromNormalizedFilePath path)+      , "This can indicate a bug which results in excessive memory usage."+      , "This may be a spurious warning if you have recently closed the file."+      , "If you haven't opened this file recently, please file a report on the issue tracker mentioning"+        <+> "the HLS version being used, the plugins enabled, and if possible the codebase and file which"+        <+> "triggered this warning."+      ]  templateHaskellInstructions :: T.Text templateHaskellInstructions = "https://haskell-language-server.readthedocs.io/en/latest/troubleshooting.html#static-binaries"@@ -192,18 +226,15 @@ ------------------------------------------------------------ -- Exposed API --------------------------------------------------------------- | Get all transitive file dependencies of a given module.--- Does not include the file itself.-getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])-getDependencies file =-    fmap transitiveModuleDeps . (`transitiveDeps` file) <$> use_ GetDependencyInformation file +-- 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)@@ -218,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@@ -240,53 +262,16 @@ getParsedModuleRule recorder =   -- this rule does not have early cutoff since all its dependencies already have it   define (cmapWithPrio LogShake recorder) $ \GetParsedModule file -> do-    ModSummaryResult{msrModSummary = ms'} <- use_ GetModSummary file-    sess <- use_ GhcSession file-    let hsc = hscEnv sess+    ModSummaryResult{msrModSummary = ms', msrHscEnv = hsc} <- use_ GetModSummary file     opt <- getIdeOptions     modify_dflags <- getModifyDynFlags dynFlagsModifyParser     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}@@ -294,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 DsWarning, _message = fixMessage $ _message c})-    | (a,b,c) <- haddock, Diag._range c `Set.notMember` locations]-  where-    locations = Set.fromList $ map (Diag._range . thd3) normal--    fixMessage x | "parse error " `T.isPrefixOf` x = "Haddock " <> x-                 | otherwise = "Haddock: " <> x- -- | This rule provides a ParsedModule preserving all annotations, -- including keywords, punctuation and comments. -- So it is suitable for use cases where you need a perfect edit.@@ -314,21 +287,20 @@   -- The parse diagnostics are owned by the GetParsedModule rule   -- For this reason, this rule does not produce any diagnostics   defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetParsedModuleWithComments file -> do-    ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary file-    sess <- use_ GhcSession file+    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' }+    let ms'' = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' }         reset_ms pm = pm { pm_mod_summary = ms' } -    liftIO $ fmap (fmap reset_ms) $ snd <$> getParsedModuleDefinition (hscEnv sess) opt file ms+    liftIO $ fmap (fmap reset_ms) $ snd <$> getParsedModuleDefinition hsc opt file ms''  getModifyDynFlags :: (DynFlagsModifications -> a) -> Action a getModifyDynFlags f = do   opts <- getIdeOptions-  cfg <- getClientConfigAction def+  cfg <- getClientConfigAction   pure $ f $ optModifyDynFlags opts cfg  @@ -348,35 +320,36 @@ 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+#endif             diagOrImp <- locateModule (hscSetFlags dflags env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource             case diagOrImp of                 Left diags              -> pure (diags, Just (modName, Nothing))@@ -391,7 +364,7 @@         bootArtifact <- if boot == Just True               then do                 let modName = ms_mod_name ms-                loc <- liftIO $ mkHomeModLocation dflags modName (fromNormalizedFilePath bootPath)+                loc <- liftIO $ mkHomeModLocation dflags' modName (fromNormalizedFilePath bootPath)                 return $ Just (noLoc modName, Just (ArtifactsLocation bootPath (Just loc) True))               else pure Nothing         -}@@ -405,17 +378,17 @@ execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1) execRawDepM act =     execStateT act-        ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty IntMap.empty+        ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty         , IntMap.empty         )  -- | Given a target file path, construct the raw dependency results by following -- imports recursively.-rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation+rawDependencyInformation :: [NormalizedFilePath] -> Action (RawDependencyInformation, BootIdMap) rawDependencyInformation fs = do     (rdi, ss) <- execRawDepM (goPlural fs)     let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss-    return (rdi { rawBootMap = bm })+    return (rdi, bm)   where     goPlural ff = do         mss <- lift $ (fmap.fmap) msrModSummary <$> uses GetModSummaryWithoutTimestamps ff@@ -424,19 +397,19 @@     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 ->-            modifyRawDepInfo (\rd -> rd { rawModuleNameMap = IntMap.insert (getFilePathId fId)-                                                                           (ShowableModuleName (moduleName $ ms_mod ms))-                                                                           (rawModuleNameMap rd)})+          whenJust mbModSum $ \ms ->+            modifyRawDepInfo (\rd -> rd { rawModuleMap = IntMap.insert (getFilePathId fId)+                                                                           (ShowableModule $ ms_mod ms)+                                                                           (rawModuleMap rd)})           -- Adding an edge to the bootmap so we can make sure to           -- insert boot nodes before the real files.           addBootMap al fId@@ -508,39 +481,29 @@     dropBootSuffix :: FilePath -> FilePath     dropBootSuffix hs_src = reverse . drop (length @[] "-boot") . reverse $ hs_src -getDependencyInformationRule :: Recorder (WithPriority Log) -> Rules ()-getDependencyInformationRule recorder =-    define (cmapWithPrio LogShake recorder) $ \GetDependencyInformation file -> do-       rawDepInfo <- rawDependencyInformation [file]-       pure ([], Just $ processDependencyInformation rawDepInfo)- reportImportCyclesRule :: Recorder (WithPriority Log) -> Rules () reportImportCyclesRule recorder =-    define (cmapWithPrio LogShake recorder) $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do-        DependencyInformation{..} <- use_ GetDependencyInformation file-        let fileId = pathToId depPathIdMap file-        case IntMap.lookup (getFilePathId fileId) depErrorNodes of-            Nothing -> pure []-            Just errs -> do-                let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs)-                -- Convert cycles of files into cycles of module names-                forM cycles $ \(imp, files) -> do-                    modNames <- forM files $ \fileId -> do-                        let file = idToPath depPathIdMap fileId-                        getModuleName file-                    pure $ toDiag imp $ sort modNames+    defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \ReportImportCycles file -> fmap (\errs -> if null errs then (Just "1",([], Just ())) else (Nothing, (errs, Nothing))) $ do+        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 []+          Just fileId ->+            case IntMap.lookup (getFilePathId fileId) depErrorNodes of+              Nothing -> pure []+              Just errs -> do+                  let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs)+                  -- Convert cycles of files into cycles of module names+                  forM cycles $ \(imp, files) -> do+                      modNames <- forM files $+                          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 DsError-            , _source = Just "Import cycle detection"-            , _message = "Cyclic module dependency between " <> showCycle mods-            , _code = Nothing-            , _relatedInformation = Nothing-            , _tags = 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@@ -559,35 +522,40 @@ persistentHieFileRule recorder = addPersistentRule GetHieAst $ \file -> runMaybeT $ do   res <- readHieFileForSrcFromDisk recorder file   vfsRef <- asks vfsVar-  vfsData <- liftIO $ vfsMap <$> readTVarIO vfsRef-  (currentSource, ver) <- liftIO $ case M.lookup (filePathToUri' file) vfsData of+  vfsData <- liftIO $ _vfsMap <$> readTVarIO vfsRef+  (currentSource, ver) <- liftIO $ case getVirtualFileFromVFS (VFS vfsData) (filePathToUri' file) of     Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file)-    Just vf -> pure (Rope.toText $ _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   diagsWrite <- case isFoi of     IsFOI Modified{firstOpen = False} -> do       when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $-        LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $+        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 ()@@ -622,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@@ -636,10 +604,9 @@ readHieFileFromDisk recorder hie_loc = do   nc <- asks ideNc   res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) hie_loc-  let log = (liftIO .) . logWith recorder   case res of-    Left e -> log Logger.Debug $ LogLoadingHieFileFail hie_loc e-    Right _ -> log Logger.Debug $ LogLoadingHieFileSuccess hie_loc+    Left e -> liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFileFail hie_loc e+    Right _ -> liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFileSuccess hie_loc   except res  -- | Typechecks a module.@@ -647,7 +614,13 @@ typeCheckRule recorder = define (cmapWithPrio LogShake recorder) $ \TypeCheck file -> do     pm <- use_ GetParsedModule file     hsc  <- hscEnv <$> use_ GhcSessionDeps file-    typeCheckRuleDefinition hsc pm+    foi <- use_ IsFileOfInterest file+    -- We should only call the typecheck rule for files of interest.+    -- Keeping typechecked modules in memory for other files is+    -- very expensive.+    when (foi == NotFOI) $+      logWith recorder Logger.Warning $ LogTypecheckedFOI file+    typeCheckRuleDefinition hsc pm file  knownFilesRule :: Recorder (WithPriority Log) -> Rules () knownFilesRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetKnownTargets -> do@@ -655,12 +628,62 @@   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 = defineNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do+getModuleGraphRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do   fs <- toKnownFiles <$> useNoFile_ GetKnownTargets-  rawDepInfo <- rawDependencyInformation (HashSet.toList fs)-  pure $ processDependencyInformation rawDepInfo+  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+  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+  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 -- garbage collect all the intermediate typechecked modules rather than@@ -668,14 +691,18 @@ typeCheckRuleDefinition     :: HscEnv     -> ParsedModule+    -> NormalizedFilePath     -> Action (IdeResult TcModuleResult)-typeCheckRuleDefinition hsc pm = do-  setPriority priorityTypeCheck+typeCheckRuleDefinition hsc pm fp = do   IdeOptions { optDefer = defer } <- getIdeOptions -  linkables_to_keep <- currentLinkables+  unlift <- askUnliftIO+  let dets = TypecheckHelpers+           { getLinkables = unliftIO unlift . uses_ GetLinkable+           , getModuleGraph = unliftIO unlift $ useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph fp+           }   addUsageDependencies $ liftIO $-    typecheckModule defer hsc linkables_to_keep pm+    typecheckModule defer hsc dets pm   where     addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)     addUsageDependencies a = do@@ -699,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))@@ -726,36 +765,70 @@         ghcSessionDepsDefinition fullModSummary ghcSessionDepsConfig env file  newtype GhcSessionDepsConfig = GhcSessionDepsConfig-    { checkForImportCycles :: Bool+    { fullModuleGraph :: Bool     } instance Default GhcSessionDepsConfig where   def = GhcSessionDepsConfig-    { checkForImportCycles = True+    { fullModuleGraph = True     } +-- | 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.+-- 3. ModLocation's (in the FinderCache) all modules in the transitive closure of "Foo", including "Foo" itself. ghcSessionDepsDefinition     :: -- | 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 checkForImportCycles $ void $ uses_ ReportImportCycles deps-            mss <- map msrModSummary <$> if fullModSummary-                then uses_ GetModSummary deps-                else uses_ GetModSummaryWithoutTimestamps deps-+            when fullModuleGraph $ void $ use_ ReportImportCycles file+            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 hirHomeMod ifaces-            session' <- liftIO $ mergeEnvs hsc mss inLoadOrder depSessions+            let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails emptyHomeModInfoLinkable) ifaces+            de <- useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph file+            mg <- do+              if fullModuleGraph+              then return $ depModuleGraph de+              else do+                let mgs = map hsc_mod_graph depSessions+                -- 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_dep_edges (ModuleNodeCompile ms) : concatMap mgModSummaries' mgs)+#else+                let module_graph_nodes =+                      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 env mg de ms inLoadOrder depSessions -            Just <$> liftIO (newHscEnvEqWithImportPaths (envImportPaths env) session' [])+            -- 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 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.@@ -771,14 +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@@ -803,17 +879,17 @@   -- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db   let ms = hirModSummary x       hie_loc = Compat.ml_hie_file $ ms_location ms-  hash <- liftIO $ Util.getFileHash hie_loc+  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-      | hash == HieDb.modInfoHash (HieDb.hieModInfo row)+      | fileHash == HieDb.modInfoHash (HieDb.hieModInfo row)       && Just hie_loc == hie_loc'       -> do       -- All good, the db has indexed the file       when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $-        LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $+        LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $           toJSON $ fromNormalizedFilePath f     -- Not in db, must re-index     _ -> do@@ -825,7 +901,7 @@         -- can just re-index the file we read from disk         Right hf -> liftIO $ do           logWith recorder Logger.Debug $ LogReindexingHieFile f-          indexHieFile se ms f hash hf+          indexHieFile se ms f fileHash hf    return (Just x) @@ -835,37 +911,39 @@ getModSummaryRule :: LspT Config IO () -> Recorder (WithPriority Log) -> Rules () getModSummaryRule displayTHWarning recorder = do     menv <- lspEnv <$> getShakeExtrasRules-    forM_ menv $ \env -> do+    case menv of+      Just env -> do         displayItOnce <- liftIO $ once $ LSP.runLspT env displayTHWarning         addIdeGlobal (DisplayTHWarning displayItOnce)+      Nothing -> do+        logItOnce <- liftIO $ once $ putStrLn ""+        addIdeGlobal (DisplayTHWarning logItOnce)      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-                bufFingerPrint <- liftIO $-                    fingerprintFromStringBuffer $ fromJust $ ms_hspp_buf $ msrModSummary res+                let bufFingerPrint = ms_hs_hash (msrModSummary res)                 let fingerPrint = Util.fingerprintFingerprints                         [ msrFingerprint res, bufFingerPrint ]                 return ( Just (fingerprintToBS fingerPrint) , ([], Just res))             Left diags -> return (Nothing, (diags, Nothing))      defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetModSummaryWithoutTimestamps f -> do-        ms <- use GetModSummary f-        case ms of+        mbMs <- use GetModSummary f+        case mbMs of             Just res@ModSummaryResult{..} -> do                 let ms = msrModSummary {-                    ms_hs_date = error "use GetModSummary instead of GetModSummaryWithoutTimestamps",                     ms_hspp_buf = error "use GetModSummary instead of GetModSummaryWithoutTimestamps"                     }                     fp = fingerprintToBS msrFingerprint@@ -875,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 =@@ -886,30 +964,28 @@ getModIfaceRule :: Recorder (WithPriority Log) -> Rules () getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModIface f -> do   fileOfInterest <- use_ IsFileOfInterest f-  res@(_,(_,mhmi)) <- case fileOfInterest of+  res <- case fileOfInterest of     IsFOI status -> do       -- Never load from disk for files of interest       tmr <- use_ TypeCheck f       linkableType <- getLinkableType f       hsc <- hscEnv <$> use_ GhcSessionDeps f+      hsc' <- setFileCacheHook hsc       let compile = fmap ([],) $ use GenerateCore f-      (diags, !hiFile) <- compileToObjCodeIfNeeded hsc linkableType compile tmr-      let fp = hiFileFingerPrint <$> hiFile-      hiDiags <- case hiFile of+      se <- getShakeExtras+      (diags, !mbHiFile) <- writeCoreFileIfNeeded se hsc' linkableType compile tmr+      let fp = hiFileFingerPrint <$> mbHiFile+      hiDiags <- case mbHiFile of         Just hiFile           | OnDisk <- status-          , not (tmrDeferedError tmr) -> writeHiFileAction hsc hiFile+          , not (tmrDeferredError tmr) -> liftIO $ writeHiFile se hsc' hiFile         _ -> pure []-      return (fp, (diags++hiDiags, hiFile))+      return (fp, (diags++hiDiags, mbHiFile))     NotFOI -> do       hiFile <- use GetModIfaceFromDiskAndIndex f       let fp = hiFileFingerPrint <$> hiFile       return (fp, ([], hiFile)) -  -- Record the linkable so we know not to unload it-  whenJust (hm_linkable . hirHomeMod =<< mhmi) $ \(LM time mod _) -> do-      compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction-      liftIO $ void $ modifyVar' compiledLinkables $ \old -> extendModuleEnv old mod time   pure res  -- | Count of total times we asked GHC to recompile@@ -926,39 +1002,41 @@   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)+    -- 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)               Just tmr -> do -                -- compile writes .o file                 let compile = liftIO $ compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr +                se <- getShakeExtras+                 -- Bang pattern is important to avoid leaking 'tmr'-                (diags'', !res) <- compileToObjCodeIfNeeded hsc compNeeded compile tmr+                (diags'', !res) <- writeCoreFileIfNeeded se hsc compNeeded compile tmr                  -- Write hi file                 hiDiags <- case res of@@ -967,16 +1045,16 @@                     -- Write hie file. Do this before writing the .hi file to                     -- ensure that we always have a up2date .hie file if we have                     -- a .hi file-                    se <- getShakeExtras+                    se' <- getShakeExtras                     (gDiags, masts) <- liftIO $ generateHieAsts hsc tmr                     source <- getSourceFileSource f                     wDiags <- forM masts $ \asts ->-                      liftIO $ writeAndIndexHieFile hsc se (tmrModSummary tmr) f (tcg_exports $ tmrTypechecked tmr) asts source+                      liftIO $ writeAndIndexHieFile hsc se' (tmrModSummary tmr) f (tcg_exports $ tmrTypechecked tmr) asts source -                    -- We don't write the `.hi` file if there are defered errors, since we won't get+                    -- We don't write the `.hi` file if there are deferred errors, since we won't get                     -- accurate diagnostics next time if we do-                    hiDiags <- if not $ tmrDeferedError tmr-                               then writeHiFileAction hsc hiFile+                    hiDiags <- if not $ tmrDeferredError tmr+                               then liftIO $ writeHiFile se' hsc hiFile                                else pure []                      pure (hiDiags <> gDiags <> concat wDiags)@@ -986,36 +1064,29 @@   -- | HscEnv should have deps included already-compileToObjCodeIfNeeded :: HscEnv -> Maybe LinkableType -> Action (IdeResult ModGuts) -> TcModuleResult -> Action (IdeResult HiFileResult)-compileToObjCodeIfNeeded hsc Nothing _ tmr = do+-- This writes the core file if a linkable is required+-- The actual linkable will be generated on demand when required by `GetLinkable`+writeCoreFileIfNeeded :: ShakeExtras -> HscEnv -> Maybe LinkableType -> Action (IdeResult ModGuts) -> TcModuleResult -> Action (IdeResult HiFileResult)+writeCoreFileIfNeeded _ hsc Nothing _ tmr = do   incrementRebuildCount   res <- liftIO $ mkHiFileResultNoCompile hsc tmr   pure ([], Just $! res)-compileToObjCodeIfNeeded hsc (Just linkableType) getGuts tmr = do+writeCoreFileIfNeeded se hsc (Just _) getGuts tmr = do   incrementRebuildCount   (diags, mguts) <- getGuts   case mguts of     Nothing -> pure (diags, Nothing)     Just guts -> do-      (diags', !res) <- liftIO $ mkHiFileResultCompile hsc tmr guts linkableType+      (diags', !res) <- liftIO $ mkHiFileResultCompile se hsc tmr guts       pure (diags++diags', res) +-- See Note [Client configuration in Rules] getClientSettingsRule :: Recorder (WithPriority Log) -> Rules () getClientSettingsRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetClientSettings -> do   alwaysRerun   settings <- clientSettings <$> getIdeConfiguration   return (LBS.toStrict $ B.encode $ hash settings, settings) --- | Returns the client configurarion stored in the IdeState.--- You can use this function to access it from shake Rules-getClientConfigAction :: Config -- ^ default value-                      -> Action Config-getClientConfigAction defValue = do-  mbVal <- unhashed <$> useNoFile_ GetClientSettings-  case A.parse (parseConfig defValue) <$> mbVal of-    Just (Success c) -> return c-    _                -> return defValue- usePropertyAction ::   (HasProperty s k t r) =>   KeyNameProxy s ->@@ -1023,20 +1094,97 @@   Properties r ->   Action (ToHsType t) usePropertyAction kn plId p = do-  config <- getClientConfigAction def-  let pluginConfig = configForPlugin config plId+  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+    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: " ++ 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: " ++ 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) 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+            -- Can't use a rule like 'GetModificationTime' or 'GetFileExists' because 'coreFileToLinkable' will write the object file, and+            -- thus bump its modification time, forcing this rule to be rerun every time.+            exists <- liftIO $ doesFileExist obj_file+            mobj_time <- liftIO $+              if exists+              then Just <$> getModTime obj_file+              else pure Nothing+            case mobj_time of+              Just obj_t+                | 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))+#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+              --We need to unload old linkables before we can load in new linkables. However,+              --the unload function in the GHC API takes a list of linkables to keep (i.e.+              --not unload). Earlier we unloaded right before loading in new linkables, which+              --is effectively once per splice. This can be slow as unload needs to walk over+              --the list of all loaded linkables, for each splice.+              --+              --Solution: now we unload old linkables right after we generate a new linkable and+              --just before returning it to be loaded. This has a substantial effect on recompile+              --times as the number of loaded modules and splices increases.+              --+              --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))+ -- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) getLinkableType f = use_ NeedsCompilation f --- needsCompilationRule :: Rules () needsCompilationRule :: NormalizedFilePath  -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType))+needsCompilationRule 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@@ -1053,60 +1201,40 @@         -- 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-#if defined(GHC_PATCHED_UNBOXED_BYTECODE)-          = BCOLinkable-#else-          | unboxed_tuples_or_sums = ObjectLinkable-          | otherwise              = BCOLinkable-#endif-  where-        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 --writeHiFileAction :: HscEnv -> HiFileResult -> Action [FileDiagnostic]-writeHiFileAction hsc hiFile = do-    extras <- getShakeExtras-    let targetPath = Compat.ml_hi_file $ ms_location $ hirModSummary hiFile-    liftIO $ do-        atomically $ resetInterfaceStore extras $ toNormalizedFilePath' targetPath-        writeHiFile hsc hiFile- data RulesConfig = RulesConfig-    { -- | Disable import cycle checking for improved performance in large codebases-      checkForImportCycles :: Bool+    { -- | Share the computation for the entire module graph+      -- We usually compute the full module graph for the project+      -- and share it for all files.+      -- However, in large projects it might not be desirable to wait+      -- for computing the entire module graph before starting to+      -- typecheck a particular file.+      -- 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     -- | 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 ()     }@@ -1117,14 +1245,17 @@         displayTHWarning :: LspT c IO ()         displayTHWarning             | not isWindows && not hostIsDynamic = do-                LSP.sendNotification SWindowShowMessage $-                    ShowMessageParams MtInfo $ T.unwords-                    [ "This HLS binary does not support Template Haskell."-                    , "Follow the [instructions](" <> templateHaskellInstructions <> ")"-                    , "to build an HLS binary with support for Template Haskell."-                    ]+                LSP.sendNotification SMethod_WindowShowMessage $+                    ShowMessageParams MessageType_Info thWarningMessage             | otherwise = return () +thWarningMessage :: T.Text+thWarningMessage = T.unwords+  [ "This HLS binary does not support Template Haskell."+  , "Follow the [instructions](" <> templateHaskellInstructions <> ")"+  , "to build an HLS binary with support for Template Haskell."+  ]+ -- | A rule that wires per-file rules together mainRule :: Recorder (WithPriority Log) -> RulesConfig -> Rules () mainRule recorder RulesConfig{..} = do@@ -1135,16 +1266,16 @@     getParsedModuleRule recorder     getParsedModuleWithCommentsRule recorder     getLocatedImportsRule recorder-    getDependencyInformationRule recorder     reportImportCyclesRule recorder     typeCheckRule recorder     getDocMapRule recorder-    loadGhcSession recorder def{checkForImportCycles}+    loadGhcSession recorder def{fullModuleGraph}     getModIfaceFromDiskRule recorder     getModIfaceFromDiskAndIndexRule recorder     getModIfaceRule recorder     getModSummaryRule templateHaskellWarning recorder     getModuleGraphRule recorder+    getFileHashRule recorder     knownFilesRule recorder     getClientSettingsRule recorder     getHieAstsRule recorder@@ -1161,7 +1292,32 @@       else defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \NeedsCompilation _ -> return $ Just Nothing     generateCoreRule recorder     getImportMapRule recorder-    getAnnotatedParsedSourceRule (cmapWithPrio LogExactPrint recorder)     persistentHieFileRule recorder     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)+getHieFile nfp = runMaybeT $ do+  HAR {hieAst} <- MaybeT $ use GetHieAst nfp+  tmr <- MaybeT $ use TypeCheck nfp+  ghc <- MaybeT $ use GhcSession nfp+  msr <- MaybeT $ use GetModSummaryWithoutTimestamps nfp+  source <- lift $ getSourceFileSource nfp+  let exports = tcg_exports $ tmrTypechecked tmr+  typedAst <- MaybeT $ pure $ cast hieAst+  liftIO $ runHsc (hscEnv ghc) $ mkHieFile' (msrModSummary msr) exports typedAst source
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.@@ -18,30 +16,33 @@     Log(..),     ) where -import           Control.Applicative             ((<|>))+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.Core.FileExists  (fileExistsRules)+import           Development.IDE.Core.OfInterest  hiding (Log, LogShake) import           Development.IDE.Graph-import           Development.IDE.Types.Logger    as Logger (Logger,-                                                            Pretty (pretty),-                                                            Priority (Debug),-                                                            Recorder,-                                                            WithPriority,-                                                            cmapWithPrio)-import           Development.IDE.Types.Options   (IdeOptions (..))+import           Development.IDE.Session          (SessionLoaderPendingBarrierVar (..))+import           Development.IDE.Types.Options    (IdeOptions (..))+import           Ide.Logger                       as Logger (Pretty (pretty),+                                                             Priority (Debug),+                                                             Recorder,+                                                             WithPriority,+                                                             cmapWithPrio) import           Ide.Plugin.Config-import qualified Language.LSP.Server             as LSP-import qualified Language.LSP.Types              as LSP+import qualified Language.LSP.Protocol.Types      as LSP+import qualified Language.LSP.Server              as LSP  import           Control.Monad-import qualified Development.IDE.Core.FileExists as FileExists-import qualified Development.IDE.Core.OfInterest as OfInterest-import           Development.IDE.Core.Shake      hiding (Log)-import qualified Development.IDE.Core.Shake      as Shake-import           Development.IDE.Types.Shake     (WithHieDb)-import           System.Environment              (lookupEnv)-+import qualified Development.IDE.Core.FileExists  as FileExists+import qualified Development.IDE.Core.OfInterest  as OfInterest+import           Development.IDE.Core.Shake       hiding (Log)+import qualified Development.IDE.Core.Shake       as Shake+import           Development.IDE.Types.Monitoring (Monitoring)+import           Development.IDE.Types.Shake      (WithHieDb)+import           Ide.Types                        (IdePlugins)+import           System.Environment               (lookupEnv)  data Log   = LogShake Shake.Log@@ -51,25 +52,28 @@  instance Pretty Log where   pretty = \case-    LogShake log      -> pretty log-    LogOfInterest log -> pretty log-    LogFileExists log -> pretty log+    LogShake msg      -> pretty msg+    LogOfInterest msg -> pretty msg+    LogFileExists msg -> pretty msg + ------------------------------------------------------------ -- Exposed API  -- | Initialise the Compiler Service. initialise :: Recorder (WithPriority Log)            -> Config+           -> 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 mainRule lspEnv logger debouncer options withHieDb hiedbChan = 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"@@ -78,7 +82,7 @@         (cmapWithPrio LogShake recorder)         lspEnv         defaultConfig-        logger+        plugins         debouncer         shakeProfiling         (optReportProgress options)@@ -86,11 +90,15 @@         withHieDb         hiedbChan         (optShakeOptions options)-          $ do+        metrics+        (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,15 +1,12 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# 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. --@@ -25,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,@@ -52,16 +51,15 @@     getIdeOptionsIO,     GlobalIdeOptions(..),     HLS.getClientConfig,-    getPluginConfig,+    getPluginConfigAction,     knownTargets,-    setPriority,     ideLogger,     actionLogger,     getVirtualFile,     FileVersion(..),-    Priority(..),     updatePositionMapping,-    deleteValue, recordDirtyKeys,+    updatePositionMappingHelper,+    deleteValue,     WithProgressFunc, WithIndefiniteProgressFunc,     ProgressEvent(..),     DelayedAction, mkDelayedAction,@@ -76,7 +74,10 @@     garbageCollectDirtyKeys,     garbageCollectDirtyKeysOlderThan,     Log(..),-    VFSModified(..)+    VFSModified(..), getClientConfigAction,+    ThreadQueue(..),+    runWithSignal,+    askShake     ) where  import           Control.Concurrent.Async@@ -85,11 +86,14 @@ import           Control.Concurrent.Strict import           Control.DeepSeq import           Control.Exception.Extra                hiding (bracket_)+import           Control.Lens                           ((%~), (&), (?~)) import           Control.Monad.Extra import           Control.Monad.IO.Class import           Control.Monad.Reader import           Control.Monad.Trans.Maybe-import           Data.Aeson                             (toJSON)+import           Data.Aeson                             (Result (Success),+                                                         toJSON)+import qualified Data.Aeson.Types                       as A import qualified Data.ByteString.Char8                  as BS import qualified Data.ByteString.Char8                  as BS8 import           Data.Coerce                            (coerce)@@ -97,13 +101,13 @@ import           Data.Dynamic import           Data.EnumMap.Strict                    (EnumMap) import qualified Data.EnumMap.Strict                    as EM-import           Data.Foldable                          (for_, toList)+import           Data.Foldable                          (find, for_) import           Data.Functor                           ((<&>))+import           Data.Functor.Identity+import           Data.Hashable import qualified Data.HashMap.Strict                    as HMap import           Data.HashSet                           (HashSet) import qualified Data.HashSet                           as HSet-import           Data.Hashable-import           Data.IORef import           Data.List.Extra                        (foldl', partition,                                                          takeEnd) import qualified Data.Map.Strict                        as Map@@ -118,67 +122,87 @@ import           Data.Unique import           Data.Vector                            (Vector) import qualified Data.Vector                            as Vector-import           Debug.Trace.Flags                      (userTracingEnabled) import           Development.IDE.Core.Debouncer import           Development.IDE.Core.FileUtils         (getModTime) 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,-                                                         mkSplitUniqSupply,-                                                         upNameCache)+                                                         knownKeyNames)+#endif import           Development.IDE.GHC.Orphans            ()-import           Development.IDE.Graph                  hiding (ShakeValue)+import           Development.IDE.Graph                  hiding (ShakeValue,+                                                         action) import qualified Development.IDE.Graph                  as Shake import           Development.IDE.Graph.Database         (ShakeDatabase,                                                          shakeGetBuildStep,+                                                         shakeGetDatabaseKeys,                                                          shakeNewDatabase,                                                          shakeProfileDatabase,                                                          shakeRunDatabaseForKeys) import           Development.IDE.Graph.Rule import           Development.IDE.Types.Action import           Development.IDE.Types.Diagnostics-import           Development.IDE.Types.Exports+import           Development.IDE.Types.Exports          hiding (exportsMapSize) import qualified Development.IDE.Types.Exports          as ExportsMap import           Development.IDE.Types.KnownTargets import           Development.IDE.Types.Location-import           Development.IDE.Types.Logger           hiding (Priority)-import qualified Development.IDE.Types.Logger           as Logger-import           Development.IDE.Types.Options+import           Development.IDE.Types.Monitoring       (Monitoring (..)) 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                              (PluginId)-import           Language.LSP.Diagnostics-import qualified Language.LSP.Server                    as LSP-import           Language.LSP.Types-import qualified Language.LSP.Types                     as LSP-import           Language.LSP.Types.Capabilities-import           Language.LSP.VFS+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           Language.LSP.VFS                       hiding (start) import qualified "list-t" ListT-import           OpenTelemetry.Eventlog+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.IO.Unsafe                       (unsafePerformIO) import           System.Time.Extra+import           UnliftIO                               (MonadUnliftIO (withRunInIO)) + data Log   = LogCreateHieDbExportsMapStart   | LogCreateHieDbExportsMapFinish !Int-  | LogBuildSessionRestart !String ![DelayedActionInternal] !(HashSet Key) !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@@ -191,14 +215,14 @@       vcat         [ "Restarting build session due to" <+> pretty reason         , "Action Queue:" <+> pretty (map actionName actionQueue)-        , "Keys:" <+> pretty (map show $ HSet.toList keyBackLog)+        , "Keys:" <+> pretty (map show $ toListKeySet keyBackLog)         , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ]     LogBuildSessionRestartTakingTooLong seconds ->         "Build restart is taking too long (" <> pretty seconds <> " seconds)"-    LogDelayedAction delayedAction duration ->+    LogDelayedAction delayedAct seconds ->       hsep-        [ "Finished:" <+> pretty (actionName delayedAction)-        , "Took:" <+> pretty (showDuration duration) ]+        [ "Finished:" <+> pretty (actionName delayedAct)+        , "Took:" <+> pretty (showDuration seconds) ]     LogBuildSessionFinish e ->       vcat         [ "Finished build session"@@ -212,53 +236,88 @@     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.       -- Small and immutable after startup, so not worth using an STM.Map.     ,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-    -- accumlation 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 ()-    ,ideNc :: IORef NameCache+    ,ideNc :: NameCache     -- | 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@@ -268,19 +327,23 @@     ,clientCapabilities :: ClientCapabilities     , withHieDb :: WithHieDb -- ^ Use only to read.     , hiedbWriter :: HieDbWriter -- ^ use to write-    , persistentKeys :: TVar (HMap.HashMap Key GetStalePersistent)-      -- ^ Registery for functions that compute/get "stale" results for the rule+    , persistentKeys :: TVar (KeyMap GetStalePersistent)+      -- ^ Registry for functions that compute/get "stale" results for the rule       -- (possibly from disk)     , vfsVar :: TVar VFS     -- ^ A snapshot of the current state of the virtual file system. Updated on shakeRestart     -- VFS state is managed by LSP. However, the state according to the lsp library may be newer than the state of the current session,-    -- leaving us vulnerable to suble race conditions. To avoid this, we take a snapshot of the state of the VFS on every+    -- leaving us vulnerable to subtle race conditions. To avoid this, we take a snapshot of the state of the VFS on every     -- restart, so that the whole session sees a single consistent view of the VFS.     -- We don't need a STM.Map because we never update individual keys ourselves.     , defaultConfig :: Config       -- ^ Default HLS config, only relevant if the client does not provide any Config-    , dirtyKeys :: TVar (HashSet Key)+    , 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.@@ -288,44 +351,65 @@ type WithIndefiniteProgressFunc = forall a.     T.Text -> LSP.ProgressCancellable -> IO a -> IO a -type GetStalePersistent = NormalizedFilePath -> IdeAction (Maybe (Dynamic,PositionDelta,TextDocumentVersion))+type GetStalePersistent = NormalizedFilePath -> IdeAction (Maybe (Dynamic,PositionDelta,Maybe Int32))  getShakeExtras :: Action ShakeExtras getShakeExtras = do+    -- Will fail the action with a pattern match failure, but be caught     Just x <- getShakeExtra @ShakeExtras     return x  getShakeExtrasRules :: Rules ShakeExtras getShakeExtrasRules = do-    Just x <- getShakeExtraRules @ShakeExtras-    return x+    mExtras <- getShakeExtraRules @ShakeExtras+    case mExtras of+      Just x  -> return x+      -- This will actually crash HLS+      Nothing -> liftIO $ fail "missing ShakeExtras" -getPluginConfig-    :: LSP.MonadLsp Config m => PluginId -> m PluginConfig-getPluginConfig plugin = do-    config <- HLS.getClientConfig+-- See Note [Client configuration in Rules]+-- | Returns the client configuration, creating a build dependency.+--   You should always use this function when accessing client configuration+--   from build rules.+getClientConfigAction :: Action Config+getClientConfigAction = do+  ShakeExtras{lspEnv, idePlugins} <- getShakeExtras+  currentConfig <- (`LSP.runLspT` LSP.getConfig) `traverse` lspEnv+  mbVal <- unhashed <$> useNoFile_ GetClientSettings+  let defValue = fromMaybe def currentConfig+  case A.parse (parseConfig idePlugins defValue) <$> mbVal of+    Just (Success c) -> return c+    _                -> return defValue++getPluginConfigAction :: PluginId -> Action PluginConfig+getPluginConfigAction plId = do+    config <- getClientConfigAction+    ShakeExtras{idePlugins = IdePlugins plugins} <- getShakeExtras+    let plugin = fromMaybe (error $ "Plugin not found: " <> show plId) $+                    find (\p -> pluginId p == plId) plugins     return $ HLS.configForPlugin config plugin  -- | Register a function that will be called to get the "stale" result of a rule, possibly from disk -- This is called when we don't already have a result, or computing the rule failed. -- The result of this function will always be marked as 'stale', and a 'proper' rebuild of the rule will -- be queued if the rule hasn't run before.-addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,TextDocumentVersion))) -> Rules ()+addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,Maybe Int32))) -> Rules () addPersistentRule k getVal = do   ShakeExtras{persistentKeys} <- getShakeExtrasRules-  void $ liftIO $ atomically $ modifyTVar' persistentKeys $ HMap.insert (Key k) (fmap (fmap (first3 toDyn)) . getVal)+  void $ liftIO $ atomically $ modifyTVar' persistentKeys $ insertKeyMap (newKey k) (fmap (fmap (first3 toDyn)) . getVal)  class Typeable a => IsIdeGlobal a where  -- | Read a virtual file from the current snapshot 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+  vfs <- fmap _vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras+  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-vfsSnapshot Nothing       = pure $ VFS mempty ""+vfsSnapshot Nothing       = pure $ VFS mempty vfsSnapshot (Just lspEnv) = LSP.runLspT lspEnv LSP.getVirtualFiles  @@ -340,31 +424,30 @@         Just _ -> error $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty         Nothing -> HMap.insert ty (toDyn x) mp -getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a+getIdeGlobalExtras :: forall a . (HasCallStack, IsIdeGlobal a) => ShakeExtras -> IO a getIdeGlobalExtras ShakeExtras{globals} = do     let typ = typeRep (Proxy :: Proxy a)     x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readTVarIO globals     case x of-        Just x-            | Just x <- fromDynamic x -> pure x-            | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")"+        Just y+            | Just z <- fromDynamic y -> pure z+            | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep y) ++ ")"         Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ -getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a+getIdeGlobalAction :: forall a . (HasCallStack, IsIdeGlobal a) => Action a getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras  getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a getIdeGlobalState = getIdeGlobalExtras . shakeExtras - newtype GlobalIdeOptions = GlobalIdeOptions IdeOptions instance IsIdeGlobal GlobalIdeOptions  getIdeOptions :: Action IdeOptions getIdeOptions = do     GlobalIdeOptions x <- getIdeGlobalAction-    env <- lspEnv <$> getShakeExtras-    case env of+    mbEnv <- lspEnv <$> getShakeExtras+    case mbEnv of         Nothing -> return x         Just env -> do             config <- liftIO $ LSP.runLspT env HLS.getClientConfig@@ -388,22 +471,22 @@           | otherwise = do           pmap <- readTVarIO persistentKeys           mv <- runMaybeT $ do-            liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP UP PERSISTENT FOR: " ++ show k-            f <- MaybeT $ pure $ HMap.lookup (Key k) pmap+            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           case mv of             Nothing -> atomicallyNamed "lastValueIO 1" $ do                 STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) state                 return Nothing-            Just (v,del,ver) -> do-                actual_version <- case ver of+            Just (v,del,mbVer) -> do+                actual_version <- case mbVer of                   Just ver -> pure (Just $ VFSVersion ver)                   Nothing -> (Just . ModificationTime <$> getModTime (fromNormalizedFilePath file))                               `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@@ -415,11 +498,11 @@      atomicallyNamed "lastValueIO 4"  (STM.lookup (toKey k file) state) >>= \case       Nothing -> readPersistent-      Just (ValueWithDiagnostics v _) -> case v of+      Just (ValueWithDiagnostics value _) -> case value of         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 @@ -455,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@@ -462,6 +572,9 @@     ,shakeSession         :: MVar ShakeSession     ,shakeExtras          :: ShakeExtras     ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath)+    ,stopMonitoring       :: IO ()+    -- | See Note [Root Directory]+    ,rootDir              :: FilePath     }  @@ -490,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 $ HSet.insert (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 HSet.insert) 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 ::@@ -549,105 +653,120 @@ shakeOpen :: Recorder (WithPriority Log)           -> Maybe (LSP.LanguageContextEnv Config)           -> Config-          -> Logger+          -> IdePlugins IdeState           -> 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 logger debouncer-  shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue opts rules = mdo-    let log :: Logger.Priority -> Log -> IO ()-        log = logWith recorder+shakeOpen recorder lspEnv defaultConfig idePlugins debouncer+  shakeProfileDir (IdeReportProgress reportProgress)+  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 -    us <- mkSplitUniqSupply 'r'-    ideNc <- newIORef (initNameCache us knownKeyNames)+#if MIN_VERSION_ghc(9,13,0)+    ideNc <- newNameCache+#else+    ideNc <- initNameCache 'r' knownKeyNames+#endif     shakeExtras <- do         globals <- newTVarIO HMap.empty         state <- STM.newIO         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 HMap.empty+        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         -- TODO: exceptions can be swallowed here?         _ <- async $ do-            log Debug LogCreateHieDbExportsMapStart+            logWith recorder Debug LogCreateHieDbExportsMapStart             em <- createExportsMapHieDb withHieDb             atomically $ modifyTVar' exportsMap (<> em)-            log Debug $ LogCreateHieDbExportsMapFinish (ExportsMap.size 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 }             rules     shakeSession <- newEmptyMVar     shakeDatabaseProfile <- shakeDatabaseProfileIO shakeProfileDir-    let ideState = IdeState{..}      IdeOptions-        { optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled-        , optProgressStyle+        { optProgressStyle+        , optCheckParents         } <- getIdeOptionsIO shakeExtras -    void $ startTelemetry shakeDb shakeExtras-    startProfilingTelemetry otProfilingEnabled logger $ state shakeExtras+    checkParents <- optCheckParents -    return ideState+    -- monitoring+    let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras+        readDirtyKeys = fromIntegral . countRelevantKeys checkParents . toListKeySet <$> readTVarIO(dirtyKeys shakeExtras)+        readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras)+        readExportsMap = fromIntegral . ExportsMap.exportsMapSize <$> readTVarIO (exportsMap shakeExtras)+        readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb+        readDatabaseStep =  fromIntegral <$> shakeGetBuildStep shakeDb -startTelemetry :: ShakeDatabase -> ShakeExtras -> IO (Async ())-startTelemetry db extras@ShakeExtras{..}-  | userTracingEnabled = do-    countKeys <- mkValueObserver "cached keys count"-    countDirty <- mkValueObserver "dirty keys count"-    countBuilds <- mkValueObserver "builds count"-    IdeOptions{optCheckParents} <- getIdeOptionsIO extras-    checkParents <- optCheckParents-    regularly 1 $ do-        observe countKeys . countRelevantKeys checkParents . map fst =<< (atomically . ListT.toList . STM.listT) state-        readTVarIO dirtyKeys >>= observe countDirty . countRelevantKeys checkParents . HSet.toList-        shakeGetBuildStep db >>= observe countBuilds+    registerGauge monitoring "ghcide.values_count" readValuesCounter+    registerGauge monitoring "ghcide.dirty_keys_count" readDirtyKeys+    registerGauge monitoring "ghcide.indexing_pending_count" readIndexPending+    registerGauge monitoring "ghcide.exports_map_count" readExportsMap+    registerGauge monitoring "ghcide.database_count" readDatabaseCount+    registerCounter monitoring "ghcide.num_builds" readDatabaseStep -  | otherwise = async (pure ())-    where-        regularly :: Seconds -> IO () -> IO (Async ())-        regularly delay act = async $ forever (act >> sleep delay)+    stopMonitoring <- start monitoring +    let ideState = IdeState{..}+    return ideState ++getStateKeys :: ShakeExtras -> IO [Key]+getStateKeys = (fmap.fmap) fst . atomically . ListT.toList . STM.listT . state+ -- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO ()-shakeSessionInit recorder ide@IdeState{..} = do-    -- Take a snapshot of the VFS - it should be empty as we've recieved no notifications+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@@ -657,6 +776,8 @@     for_ runner cancelShakeSession     void $ shakeDatabaseProfile shakeDb     progressStop $ progress shakeExtras+    progressStop $ indexProgressReporting $ hiedbWriter shakeExtras+    stopMonitoring   -- | This is a variant of withMVar where the first argument is run unmasked and if it throws@@ -681,67 +802,55 @@   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-              let log = logWith recorder-              (stopTime,()) <- duration $ logErrorAfter 10 recorder $ cancelShakeSession runner-              res <- shakeDatabaseProfile shakeDb-              backlog <- readTVarIO $ dirtyKeys shakeExtras-              queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras--              log Debug $ LogBuildSessionRestart reason queue backlog stopTime res+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 -              let profile = case res of-                      Just fp -> ", profile saved at " <> fp-                      _       -> ""-              -- TODO: should replace with logging using a logger that sends lsp message-              let msg = T.pack $ "Restarting build session " ++ reason' ++ queueMsg ++ keysMsg ++ abortMsg-                  reason' = "due to " ++ reason-                  queueMsg = " with queue " ++ show (map actionName queue)-                  keysMsg = " for keys " ++ show (HSet.toList backlog) ++ " "-                  abortMsg = "(aborting the previous one took " ++ showDuration stopTime ++ profile ++ ")"-              notifyTestingLogMessage shakeExtras msg-        )-        -- It is crucial to be masked here, otherwise we can get killed-        -- between spawning the new thread and updating shakeSession.-        -- See https://github.com/haskell/ghcide/issues/79-        (\() -> do-          (,()) <$> newSession 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 -> Recorder (WithPriority Log) -> IO () -> IO ()-        logErrorAfter seconds recorder action = flip withAsync (const action) $ do+        logErrorAfter :: Seconds -> IO () -> IO ()+        logErrorAfter seconds action = flip withAsync (const action) $ do             sleep seconds             logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds) -notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO ()-notifyTestingLogMessage extras msg = do-    (IdeTesting isTestMode) <- optTesting <$> getIdeOptionsIO extras-    let notif = LSP.LogMessageParams LSP.MtLog msg-    when isTestMode $ mRunLspT (lspEnv extras) $ LSP.sendNotification LSP.SWindowLogMessage notif-- -- | Enqueue an action in the existing 'ShakeSession'. --   Returns a computation to block until the action is run, propagating exceptions. --   Assumes a 'ShakeSession' is available. -- --   Appropriate for user actions other than edits. shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a)-shakeEnqueue ShakeExtras{actionQueue, logger} act = do+shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do     (b, dai) <- instantiateDelayedAction act     atomicallyNamed "actionQueue - push" $ pushQueue dai actionQueue-    let wait' b =-            waitBarrier b `catches`+    let wait' barrier =+            waitBarrier barrier `catches`               [ Handler(\BlockedIndefinitelyOnMVar ->                     fail $ "internal bug: forever blocked on MVar for " <>                             actionName act)               , Handler (\e@AsyncCancelled -> do-                  logPriority logger Debug $ T.pack $ actionName act <> " was cancelled"+                  logWith shakeRecorder Debug $ LogCancelledAction (T.pack $ actionName act)                    atomicallyNamed "actionQueue - abort" $ abortQueue dai actionQueue                   throw e)@@ -764,7 +873,7 @@      -- Take a new VFS snapshot     case vfsMod of-      VFSUnmodified -> pure ()+      VFSUnmodified   -> pure ()       VFSModified vfs -> atomically $ writeTVar vfsVar vfs      IdeOptions{optRunSubset} <- getIdeOptionsIO extras@@ -793,21 +902,16 @@         workRun restore = withSpan "Shake session" $ \otSpan -> do           setTag otSpan "reason" (fromString reason)           setTag otSpan "queue" (fromString $ unlines $ map actionName reenqueued)-          whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toList kk)+          whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toListKeySet kk)           let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts)           res <- try @SomeException $-            restore $ shakeRunDatabaseForKeys (HSet.toList <$> allPendingKeys) shakeDb keysActs-          let res' = case res of-                      Left e  -> "exception: " <> displayException e-                      Right _ -> "completed"-          let msg = T.pack $ "Finishing build session(" ++ res' ++ ")"+            restore $ shakeRunDatabaseForKeys (toListKeySet <$> allPendingKeys) shakeDb keysActs           return $ do               let exception =                     case res of                       Left e -> Just e                       _      -> Nothing               logWith recorder Debug $ LogBuildSessionFinish exception-              notifyTestingLogMessage extras msg      -- Do the work in a background thread     workThread <- asyncWithUnmask workRun@@ -832,7 +936,7 @@   b <- newBarrier   let a' = do         -- work gets reenqueued when the Shake session is restarted-        -- it can happen that a work item finished just as it was reenqueud+        -- it can happen that a work item finished just as it was reenqueued         -- in that case, skipping the work is fine         alreadyDone <- liftIO $ isJust <$> waitBarrierMaybe b         unless alreadyDone $ do@@ -870,15 +974,14 @@ 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 (SCustomMethod "ghcide/GC")+        LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/GC"))                              (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage)     return garbage @@ -891,7 +994,7 @@             = atomicallyNamed "GC" $ do                 gotIt <- STM.focus (Focus.member <* Focus.delete) k values                 when gotIt $-                   modifyTVar' dk (HSet.insert k)+                   modifyTVar' dk (insertKeySet k)                 return $ if gotIt then (counter+1, k:keys) else st             | otherwise = pure st @@ -933,21 +1036,31 @@ -- | Request a Rule result if available use :: IdeRule k v     => k -> NormalizedFilePath -> Action (Maybe v)-use key file = head <$> uses key [file]+use key file = runIdentity <$> uses key (Identity file)  -- | Request a Rule result, it not available return the last computed result, if any, which may be stale useWithStale :: IdeRule k v     => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))-useWithStale key file = head <$> usesWithStale key [file]+useWithStale key file = runIdentity <$> usesWithStale key (Identity file) --- | Request a Rule result, it not available return the last computed result which may be stale.---   Errors out if none available.+-- |Request a Rule result, it not available return the last computed result+--  which may be stale.+--+-- Throws an `BadDependency` exception which is caught by the rule system if+-- none available.+--+-- WARNING: Not suitable for PluginHandlers. Use `useWithStaleE` instead. useWithStale_ :: IdeRule k v     => k -> NormalizedFilePath -> Action (v, PositionMapping)-useWithStale_ key file = head <$> usesWithStale_ key [file]+useWithStale_ key file = runIdentity <$> usesWithStale_ key (Identity file) --- | Plural version of 'useWithStale_'-usesWithStale_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [(v, PositionMapping)]+-- |Plural version of 'useWithStale_'+--+-- Throws an `BadDependency` exception which is caught by the rule system if+-- none available.+--+-- WARNING: Not suitable for PluginHandlers.+usesWithStale_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f (v, PositionMapping)) usesWithStale_ key files = do     res <- usesWithStale key files     case sequence res of@@ -960,7 +1073,7 @@ -- -- Run via 'runIdeAction'. newtype IdeAction a = IdeAction { runIdeActionT  :: (ReaderT ShakeExtras IO) a }-    deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad)+    deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad, Semigroup)  runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a runIdeAction _herald s i = runReaderT (runIdeActionT i) s@@ -968,9 +1081,10 @@ askShake :: IdeAction ShakeExtras askShake = ask -mkUpdater :: IORef NameCache -> NameCacheUpdater-mkUpdater ref = NCU (upNameCache ref) +mkUpdater :: NameCache -> NameCacheUpdater+mkUpdater = id+ -- | A (maybe) stale result now, and an up to date one later data FastResult a = FastResult { stale :: Maybe (a,PositionMapping), uptoDate :: IO (Maybe a)  } @@ -989,7 +1103,7 @@    -- Async trigger the key to be built anyway because we want to   -- keep updating the value in the key.-  wait <- delayedAction $ mkDelayedAction ("C:" ++ show key ++ ":" ++ fromNormalizedFilePath file) Debug $ use key file+  waitValue <- delayedAction $ mkDelayedAction ("C:" ++ show key ++ ":" ++ fromNormalizedFilePath file) Debug $ use key file    s@ShakeExtras{state} <- askShake   r <- liftIO $ atomicallyNamed "useStateFast" $ getValues state key file@@ -1000,24 +1114,36 @@       res <- lastValueIO s key file       case res of         Nothing -> do-          a <- wait+          a <- waitValue           pure $ FastResult ((,zeroMapping) <$> a) (pure a)-        Just _ -> pure $ FastResult res wait+        Just _ -> pure $ FastResult res waitValue     -- Otherwise, use the computed value even if it's out of date.     Just _ -> do       res <- lastValueIO s key file-      pure $ FastResult res wait+      pure $ FastResult res waitValue  useNoFile :: IdeRule k v => k -> Action (Maybe v) useNoFile key = use key emptyFilePath +-- Requests a rule if available.+--+-- Throws an `BadDependency` exception which is caught by the rule system if+-- none available.+--+-- WARNING: Not suitable for PluginHandlers. Use `useE` instead. use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v-use_ key file = head <$> uses_ key [file]+use_ key file = runIdentity <$> uses_ key (Identity file)  useNoFile_ :: IdeRule k v => k -> Action v useNoFile_ key = use_ key emptyFilePath -uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]+-- |Plural version of `use_`+--+-- Throws an `BadDependency` exception which is caught by the rule system if+-- none available.+--+-- WARNING: Not suitable for PluginHandlers. Use `usesE` instead.+uses_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f v) uses_ key files = do     res <- uses key files     case sequence res of@@ -1025,24 +1151,41 @@         Just v  -> return v  -- | Plural version of 'use'-uses :: IdeRule k v-    => k -> [NormalizedFilePath] -> Action [Maybe v]-uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files)+uses :: (Traversable f, IdeRule k v)+    => k -> f NormalizedFilePath -> Action (f (Maybe v))+uses key files = fmap (\(A value) -> currentValue value) <$> apply (fmap (Q . (key,)) files)  -- | Return the last computed result which might be stale.-usesWithStale :: IdeRule k v-    => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]+usesWithStale :: (Traversable f, IdeRule k v)+    => k -> f NormalizedFilePath -> Action (f (Maybe (v, PositionMapping))) usesWithStale key files = do-    _ <- apply (map (Q . (key,)) files)+    _ <- apply (fmap (Q . (key,)) files)     -- We don't look at the result of the 'apply' since 'lastValue' will     -- return the most recent successfully computed value regardless of     -- whether the rule succeeded or not.-    mapM (lastValue key) files+    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 =-    (\[A value] -> currentValue value) <$> applyWithoutDependency [Q (key, file)]+    (\(Identity (A value)) -> currentValue value) <$> applyWithoutDependency (Identity (Q (key, file)))  data RuleBody k v   = Rule (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))@@ -1063,7 +1206,7 @@     extras <- getShakeExtras     let diagnostics ver diags = do             traceDiagnostics diags-            updateFileDiagnostics recorder file ver (Key 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@@ -1082,7 +1225,7 @@     extras <- getShakeExtras     let diagnostics ver diags = do             traceDiagnostics diags-            updateFileDiagnostics recorder file ver (Key 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 ()@@ -1092,12 +1235,12 @@  defineEarlyCutOffNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action (BS.ByteString, v)) -> Rules () defineEarlyCutOffNoFile recorder f = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k file -> do-    if file == emptyFilePath then do (hash, res) <- f k; return (Just hash, Just res) else+    if file == emptyFilePath then do (hashString, res) <- f k; return (Just hashString, Just res) else         fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"  defineEarlyCutoff'     :: forall k v. IdeRule k v-    => (TextDocumentVersion -> [FileDiagnostic] -> Action ()) -- ^ update diagnostics+    => (Maybe Int32 -> [FileDiagnostic] -> Action ()) -- ^ update diagnostics     -- | compare current and previous for freshness     -> (BS.ByteString -> BS.ByteString -> Bool)     -> k@@ -1106,20 +1249,21 @@     -> RunMode     -> (Value v -> Action (Maybe BS.ByteString, IdeResult v))     -> Action (RunResult (A (RuleResult k)))-defineEarlyCutoff' doDiagnostics cmp key file old mode action = do+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-        val <- case old of+    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-                v <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key file-                case v of+                mbValue <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key file+                case mbValue of                     -- No changes in the dependencies and we have                     -- an existing successful result.                     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@@ -1133,19 +1277,18 @@                     Just (Succeeded ver v, _) -> Stale Nothing ver v                     Just (Stale d ver v, _)   -> Stale d ver v                     Just (Failed b, _)        -> Failed b-                (bs, (diags, res)) <- actionCatch+                (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 res file-                (bs, res) <- case res of+                ver <- estimateFileVersionUnsafely key mbRes file+                (bs, res) <- case mbRes of                     Nothing -> do-                        pure (toShakeValue ShakeStale bs, staleV)-                    Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded ver v)-                liftIO $ atomicallyNamed "define - write" $ setValues state key file res (Vector.fromList diags)+                        pure (toShakeValue ShakeStale mbBs, staleV)+                    Just v -> pure (maybe ShakeNoCutoff ShakeResult mbBs, Succeeded ver v)                 doDiagnostics (vfsVersion =<< ver) diags-                let eq = case (bs, fmap decodeShakeValue old) of+                let eq = case (bs, fmap decodeShakeValue mbOld) of                         (ShakeResult a, Just (ShakeResult b)) -> cmp a b                         (ShakeStale a, Just (ShakeStale b))   -> cmp a b                         -- If we do not have a previous result@@ -1153,18 +1296,19 @@                         _                                     -> False                 return $ RunResult                     (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)-                    (encodeShakeValue bs) $-                    A res-        liftIO $ atomicallyNamed "define - dirtyKeys" $ modifyTVar' dirtyKeys (HSet.delete $ 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     -- without creating a dependency on the GetModificationTime rule     -- (and without creating cycles in the build graph).     estimateFileVersionUnsafely-        :: forall k v-         . IdeRule k v-        => k+        :: k         -> Maybe v         -> NormalizedFilePath         -> Action (Maybe FileVersion)@@ -1181,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"@@ -1189,88 +1359,97 @@ updateFileDiagnostics :: MonadIO m   => Recorder (WithPriority Log)   -> NormalizedFilePath-  -> TextDocumentVersion+  -> Maybe Int32   -> Key   -> ShakeExtras-  -> [(ShowDiagnostic,Diagnostic)] -- ^ current results+  -> [FileDiagnostic] -- ^ current results   -> m ()-updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv} current =+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 addTagUnsafe new store = addTagUnsafe "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafe uri ver (T.pack $ show k) new store+        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 = 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-        let uri = filePathToUri' fp+        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+        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                         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 LSP.STextDocumentPublishDiagnostics $-                                LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) (List newDiags)-                 return action+                            LSP.sendNotification SMethod_TextDocumentPublishDiagnostics $+                                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+                            (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 ->-  TextDocumentVersion ->-  DiagnosticsBySource ->-  STM [LSP.Diagnostic]+  Maybe Int32 ->+  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 setStageDiagnostics     :: (forall a. String -> String -> a -> a)     -> NormalizedUri-    -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited+    -> 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@@ -1279,22 +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 -> List TextDocumentContentChangeEvent -> STM ()-updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) =+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 actual_version (shared_change, zeroMapping) mappingForUri)-        shared_change = mkDelta changes-        actual_version = case _version of-          Nothing -> error "Nothing version from server" -- This is a violation of the spec-          Just v  -> v+        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
@@ -1,85 +1,41 @@-{-# LANGUAGE CPP             #-}-{-# LANGUAGE PackageImports  #-}-{-# LANGUAGE PatternSynonyms #-}-{-# HLINT ignore #-}+ module Development.IDE.Core.Tracing     ( otTracedHandler     , otTracedAction-    , startProfilingTelemetry-    , measureMemory-    , getInstrumentCached     , otTracedProvider     , otSetUri     , otTracedGarbageCollection     , withTrace     , withEventTrace-    , withTelemetryLogger+    , withTelemetryRecorder     ) where -import           Control.Concurrent.Async          (Async, async)-import           Control.Concurrent.Extra          (modifyVar_, newVar, readVar,-                                                    threadDelay)-import           Control.Exception                 (evaluate)-import           Control.Exception.Safe            (SomeException, catch,-                                                    generalBracket)-import           Control.Monad                     (forM_, forever, void, when,-                                                    (>=>))+import           Control.Exception.Safe            (generalBracket) import           Control.Monad.Catch               (ExitCase (..), MonadMask)-import           Control.Monad.Extra               (whenJust) import           Control.Monad.IO.Unlift-import           Control.Monad.STM                 (atomically)-import           Control.Seq                       (r0, seqList, seqTuple2,-                                                    using) import           Data.ByteString                   (ByteString) import           Data.ByteString.Char8             (pack)-import qualified Data.HashMap.Strict               as HMap-import           Data.IORef                        (modifyIORef', newIORef,-                                                    readIORef, writeIORef) import           Data.String                       (IsString (fromString)) import qualified Data.Text                         as T import           Data.Text.Encoding                (encodeUtf8)-import           Data.Typeable                     (TypeRep, typeOf) import           Data.Word                         (Word16) import           Debug.Trace.Flags                 (userTracingEnabled)-import           Development.IDE.Core.RuleTypes    (GhcSession (GhcSession),-                                                    GhcSessionDeps (GhcSessionDeps),-                                                    GhcSessionIO (GhcSessionIO)) import           Development.IDE.Graph             (Action) import           Development.IDE.Graph.Rule import           Development.IDE.Types.Diagnostics (FileDiagnostic,                                                     showDiagnostics) import           Development.IDE.Types.Location    (Uri (..))-import           Development.IDE.Types.Logger      (Logger (Logger), logDebug,-                                                    logInfo)-import           Development.IDE.Types.Shake       (ValueWithDiagnostics (..),-                                                    Values, fromKeyType)-import           Foreign.Storable                  (Storable (sizeOf))-import           HeapSize                          (recursiveSize, runHeapsize)-import           Ide.PluginUtils                   (installSigUsr1Handler)+import           Ide.Logger import           Ide.Types                         (PluginId (..))-import           Language.LSP.Types                (NormalizedFilePath,+import           Language.LSP.Protocol.Types       (NormalizedFilePath,                                                     fromNormalizedFilePath)-import qualified "list-t" ListT-import           Numeric.Natural                   (Natural) import           OpenTelemetry.Eventlog            (SpanInFlight (..), addEvent,-                                                    beginSpan, endSpan,-                                                    mkValueObserver, observe,-                                                    setTag, withSpan, withSpan_)-import qualified StmContainers.Map                 as STM+                                                    beginSpan, endSpan, setTag,+                                                    withSpan) -#if MIN_VERSION_ghc(8,8,0)-otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a-otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => ByteString -> f [a] -> f [a]-withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> m ()) -> m a) -> m a-#else-otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a-otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => String -> f [a] -> f [a]-withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> m ()) -> m a) -> m a-#endif -withTrace :: (MonadMask m, MonadIO m) =>-    String -> ((String -> String -> m ()) -> m a) -> m a+withTrace :: (MonadMask m, MonadIO m) => String -> ((String -> String -> m ()) -> m a) -> m a withTrace name act   | userTracingEnabled   = withSpan (fromString name) $ \sp -> do@@ -87,6 +43,7 @@       act setSpan'   | otherwise = act (\_ _ -> pure ()) +withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> m ()) -> m a) -> m a withEventTrace name act   | userTracingEnabled   = withSpan (fromString name) $ \sp -> do@@ -94,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@@ -151,11 +112,12 @@             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 ()) +otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => ByteString -> f [a] -> f [a] otTracedGarbageCollection label act   | userTracingEnabled = fst <$>       generalBracket@@ -169,6 +131,7 @@         (const act)   | otherwise = act +otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a otTracedProvider (PluginId pluginName) provider act   | userTracingEnabled = do     runInIO <- askRunInIO@@ -176,128 +139,4 @@         setTag sp "plugin" (encodeUtf8 pluginName)         runInIO act   | otherwise = act---startProfilingTelemetry :: Bool -> Logger -> Values -> IO ()-startProfilingTelemetry allTheTime logger state = do-    instrumentFor <- getInstrumentCached--    installSigUsr1Handler $ do-        logInfo logger "SIGUSR1 received: performing memory measurement"-        performMeasurement logger state instrumentFor--    when allTheTime $ void $ regularly (1 * seconds) $-        performMeasurement logger state instrumentFor-  where-        seconds = 1000000--        regularly :: Int -> IO () -> IO (Async ())-        regularly delay act = async $ forever (act >> threadDelay delay)---performMeasurement ::-  Logger ->-  Values ->-  (Maybe String -> IO OurValueObserver) ->-  IO ()-performMeasurement logger values instrumentFor = do-    contents <- atomically $ ListT.toList $ STM.listT values-    let keys = typeOf GhcSession-             : typeOf GhcSessionDeps-             -- TODO restore-             : [ kty-                | (k,_) <- contents-                , Just (kty,_) <- [fromKeyType k]-                -- do GhcSessionIO last since it closes over stateRef itself-                , kty /= typeOf GhcSession-                , kty /= typeOf GhcSessionDeps-                , kty /= typeOf GhcSessionIO-             ]-             ++ [typeOf GhcSessionIO]-    groupedForSharing <- evaluate (keys `using` seqList r0)-    measureMemory logger [groupedForSharing] instrumentFor values-        `catch` \(e::SomeException) ->-        logInfo logger ("MEMORY PROFILING ERROR: " <> fromString (show e))---type OurValueObserver = Int -> IO ()--getInstrumentCached :: IO (Maybe String -> IO OurValueObserver)-getInstrumentCached = do-    instrumentMap <- newVar HMap.empty-    mapBytesInstrument <- mkValueObserver "value map size_bytes"--    let instrumentFor k = do-          mb_inst <- HMap.lookup k <$> readVar instrumentMap-          case mb_inst of-            Nothing -> do-                instrument <- mkValueObserver (fromString (show k ++ " size_bytes"))-                modifyVar_ instrumentMap (return . HMap.insert k instrument)-                return $ observe instrument-            Just v -> return $ observe v-    return $ maybe (return $ observe mapBytesInstrument) instrumentFor--whenNothing :: IO () -> IO (Maybe a) -> IO ()-whenNothing act mb = mb >>= f-  where f Nothing = act-        f Just{}  = return ()--measureMemory-    :: Logger-    -> [[TypeRep]]     -- ^ Grouping of keys for the sharing-aware analysis-    -> (Maybe String -> IO OurValueObserver)-    -> Values-    -> IO ()-measureMemory logger groups instrumentFor values = withSpan_ "Measure Memory" $ do-    contents <- atomically $ ListT.toList $ STM.listT values-    valuesSizeRef <- newIORef $ Just 0-    let !groupsOfGroupedValues = groupValues contents-    logDebug logger "STARTING MEMORY PROFILING"-    forM_ groupsOfGroupedValues $ \groupedValues -> do-        keepGoing <- readIORef valuesSizeRef-        whenJust keepGoing $ \_ ->-          whenNothing (writeIORef valuesSizeRef Nothing) $-          repeatUntilJust 3 $ do-          -- logDebug logger (fromString $ show $ map fst groupedValues)-          runHeapsize 25000000 $-              forM_ groupedValues $ \(k,v) -> withSpan ("Measure " <> fromString k) $ \sp -> do-              acc <- liftIO $ newIORef 0-              observe <- liftIO $ instrumentFor $ Just k-              mapM_ (recursiveSize >=> \x -> liftIO (modifyIORef' acc (+ x))) v-              size <- liftIO $ readIORef acc-              let !byteSize = sizeOf (undefined :: Word) * size-              setTag sp "size" (fromString (show byteSize ++ " bytes"))-              () <- liftIO $ observe byteSize-              liftIO $ modifyIORef' valuesSizeRef (fmap (+ byteSize))--    mbValuesSize <- readIORef valuesSizeRef-    case mbValuesSize of-        Just valuesSize -> do-            observe <- instrumentFor Nothing-            observe valuesSize-            logDebug logger "MEMORY PROFILING COMPLETED"-        Nothing ->-            logInfo logger "Memory profiling could not be completed: increase the size of your nursery (+RTS -Ax) and try again"--    where-        -- groupValues :: Values -> [ [(String, [Value Dynamic])] ]-        groupValues contents =-            let !groupedValues =-                    [ [ (show ty, vv)-                      | ty <- groupKeys-                      , let vv = [ v | (fromKeyType -> Just (kty,_), ValueWithDiagnostics v _) <- contents-                                     , kty == ty]-                      ]-                    | groupKeys <- groups-                    ]-                -- force the spine of the nested lists-            in groupedValues `using` seqList (seqList (seqTuple2 r0 (seqList r0)))--repeatUntilJust :: Monad m => Natural -> m (Maybe a) -> m (Maybe a)-repeatUntilJust 0 _ = return Nothing-repeatUntilJust nattempts action = do-    res <- action-    case res of-        Nothing -> repeatUntilJust (nattempts-1) action-        Just{}  -> return res
src/Development/IDE/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
@@ -16,48 +16,48 @@ where  import           Development.IDE.GHC.Compat      as Compat-import           GHC-#if !MIN_VERSION_ghc(8,10,0)-import qualified Development.IDE.GHC.Compat.CPP  as CPP-#else import           Development.IDE.GHC.Compat.Util-#endif--#if MIN_VERSION_ghc(9,0,0)-import qualified GHC.Driver.Pipeline             as Pipeline+import           GHC import           GHC.Settings-#else-#if MIN_VERSION_ghc (8,10,0)-import qualified DriverPipeline                  as Pipeline-import           ToolSettings-#else-import           DynFlags+import qualified GHC.SysTools.Cpp                as Pipeline++-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]+++#if MIN_VERSION_ghc(9,10,2)+import qualified GHC.SysTools.Tasks              as Pipeline #endif++#if MIN_VERSION_ghc(9,11,0)+import qualified GHC.SysTools.Tasks              as Pipeline #endif  addOptP :: String -> DynFlags -> DynFlags-#if MIN_VERSION_ghc (8,10,0) addOptP f = alterToolSettings $ \s -> s           { toolSettings_opt_P             = f : toolSettings_opt_P s           , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s)           }   where     fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss-    alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }-#else-addOptP opt = onSettings (onOptP (opt:))-  where-    onSettings f x = x{settings = f $ settings x}-    onOptP f x = x{sOpt_P = f $ sOpt_P x}-#endif+    alterToolSettings g dynFlags = dynFlags { toolSettings = g (toolSettings dynFlags) } -doCpp :: HscEnv -> Bool -> FilePath -> FilePath -> IO ()-doCpp env raw input_fn output_fn =-#if MIN_VERSION_ghc (9,2,0)-    Pipeline.doCpp (hsc_logger env) (hsc_tmpfs env) (hsc_dflags env) (hsc_unit_env env) raw input_fn output_fn-#elif MIN_VERSION_ghc (8,10,0)-    Pipeline.doCpp (hsc_dflags env) raw input_fn output_fn+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+    let cpp_opts = Pipeline.CppOpts+                 { cppLinePragmas = True++#if MIN_VERSION_ghc(9,10,2)+                 , sourceCodePreprocessor = Pipeline.SCPHsCpp+#elif MIN_VERSION_ghc(9,10,0)+                 , useHsCpp = True #else-    CPP.doCpp (hsc_dflags env) raw input_fn output_fn+                 , 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,44 +1,36 @@ -- 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(-    NameCacheUpdater(..),     hPutStringBuffer,     addIncludePathsQuote,     getModuleHash,     setUpTypedHoles,-    upNameCache,+    lookupNameCache,     disableWarningsAsErrors,     reLoc,     reLocA,-    getMessages',+    renderMessages,     pattern PFailedWithErrorMessages,-    isObjectLinkable,--#if !MIN_VERSION_ghc(9,0,1)-    RefMap,-#endif--#if MIN_VERSION_ghc(9,2,0)-    extendModSummaryNoDeps,-    emsModSummary,     myCoreToStgExpr,-#endif-+    Usage(..),+    FastStringCompat,+    bytesFS,+    mkFastStringByteString,     nodeInfo',     getNodeIds,-    nodeInfoFromSource,+    getSourceNodeIds,+    sourceNodeInfo,+    generatedNodeInfo,+    simpleNodeInfoCompat,     isAnnotationInNodeInfo,+    nodeAnnotations,     mkAstNode,     combineRealSrcSpans,-     isQualifiedImport,     GhcVersion(..),     ghcVersion,@@ -51,15 +43,11 @@     enrichHie,     writeHieFile,     readHieFile,-    supportsHieFiles,     setHieDir,     dontWriteHieFiles,-    module Compat.HieTypes,-    module Compat.HieUtils,     -- * Compat modules     module Development.IDE.GHC.Compat.Core,     module Development.IDE.GHC.Compat.Env,-    module Development.IDE.GHC.Compat.ExactPrint,     module Development.IDE.GHC.Compat.Iface,     module Development.IDE.GHC.Compat.Logger,     module Development.IDE.GHC.Compat.Outputable,@@ -78,12 +66,15 @@     simplifyExpr,     tidyExpr,     emptyTidyEnv,+    tidyOpenType,     corePrepExpr,+    corePrepPgm,     lintInteractiveExpr,     icInteractiveModule,     HomePackageTable,     lookupHpt,-    Dependencies(dep_mods),+    loadModulesHome,+    hugElts,     bcoFreeNames,     ModIfaceAnnotation,     pattern Annotation,@@ -93,22 +84,47 @@     module UniqSet,     module UniqDFM,     getDependentMods,-#if MIN_VERSION_ghc(9,2,0)+    flattenBinds,+    mkRnEnv2,+    emptyInScopeSet,+    Unfolding(..),+    noUnfolding,+#if !MIN_VERSION_ghc(9,13,0)     loadExpr,+#endif     byteCodeGen,     bc_bcos,     loadDecls,     hscInterp,     expectJust,-#else-    coreExprToBCOs,-    linkExpr,+    extract_cons,+    recDotDot,+++    Dependencies(dep_direct_mods),+    NameCacheUpdater,++    XModulePs(..),++#if !MIN_VERSION_ghc(9,7,0)+    liftZonkM,+    nonDetFoldOccEnv, #endif-    ) where +#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.ExactPrint import           Development.IDE.GHC.Compat.Iface import           Development.IDE.GHC.Compat.Logger import           Development.IDE.GHC.Compat.Outputable@@ -116,258 +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, getLoc,-                                                        lookupName, exprType)-#if MIN_VERSION_ghc(9,0,0)-import GHC.Driver.Hooks (hscCompileCoreExprHook)-import GHC.Core (CoreExpr, CoreProgram)-import qualified GHC.Core.Opt.Pipeline as GHC-import GHC.Core.Tidy (tidyExpr)-import GHC.Types.Var.Env (emptyTidyEnv)-import qualified GHC.CoreToStg.Prep as GHC-import GHC.Core.Lint (lintInteractiveExpr)-#if MIN_VERSION_ghc(9,2,0)-import GHC.Unit.Home.ModInfo (lookupHpt, HomePackageTable)-import GHC.Runtime.Context (icInteractiveModule)-import GHC.Unit.Module.Deps (Dependencies(dep_mods))-import GHC.Linker.Types (isObjectLinkable)-import GHC.Linker.Loader (loadExpr)-#else-import GHC.CoreToByteCode (coreExprToBCOs)-import GHC.Driver.Types (Dependencies(dep_mods), icInteractiveModule, lookupHpt, HomePackageTable)-import GHC.Runtime.Linker (linkExpr)-#endif-import GHC.ByteCode.Asm (bcoFreeNames)-import GHC.Types.Annotations (Annotation(..), AnnTarget(ModuleTarget), extendAnnEnvList)-import GHC.Types.Unique.DSet as UniqDSet-import GHC.Types.Unique.Set as UniqSet-import GHC.Types.Unique.DFM  as UniqDFM-#else-import Hooks (hscCompileCoreExprHook)-import CoreSyn (CoreExpr)-import qualified SimplCore as GHC-import CoreTidy (tidyExpr)-import VarEnv (emptyTidyEnv)-import CorePrep (corePrepExpr)-import CoreLint (lintInteractiveExpr)-import ByteCodeGen (coreExprToBCOs)-import HscTypes (icInteractiveModule, HomePackageTable, lookupHpt, Dependencies(dep_mods))-import Linker (linkExpr)-import ByteCodeAsm (bcoFreeNames)-import Annotations (Annotation(..), AnnTarget(ModuleTarget), extendAnnEnvList)-import UniqDSet-import UniqSet-import UniqDFM-#endif+import           GHC                                     hiding (ModLocation,+                                                          RealSrcSpan, exprType,+                                                          getLoc, lookupName)+import           Prelude                                 hiding (mod) -#if MIN_VERSION_ghc(9,0,0)+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.Core+import           GHC.Data.FastString import           GHC.Data.StringBuffer-import           GHC.Driver.Session                    hiding (ExposePackage)-import qualified GHC.Types.SrcLoc                      as SrcLoc-import           GHC.Utils.Error-#if MIN_VERSION_ghc(9,2,0)-import           Data.Bifunctor-import           GHC.Driver.Env                        as Env-import           GHC.Unit.Module.ModIface-import           GHC.Unit.Module.ModSummary-#else-import           GHC.Driver.Types-#endif+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.Builtin.Uniques+import           GHC.ByteCode.Types+import           GHC.Core.Lint.Interactive               (interactiveInScope)+import           GHC.CoreToStg+import           GHC.Data.Maybe+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.Iface.Make                        (mkIfaceExports)-import qualified GHC.SysTools.Tasks                    as SysTools-import qualified GHC.Types.Avail                       as Avail+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+import           GHC.Types.SrcLoc                        (combineRealSrcSpans)+#if MIN_VERSION_ghc(9,13,0)+import           GHC.Unit.Home.PackageTable              (HomePackageTable,+                                                          lookupHpt) #else-import qualified Avail-import           DynFlags                              hiding (ExposePackage)-import           HscTypes-import           MkIface                               hiding (writeIfaceFile)--#if MIN_VERSION_ghc(8,8,0)-import           StringBuffer                          (hPutStringBuffer)+import           GHC.Unit.Home.ModInfo                   (HomePackageTable,+                                                          lookupHpt) #endif-import qualified SysTools+import           GHC.Unit.Module.Deps                    (Dependencies (dep_direct_mods),+                                                          Usage (..))+import           GHC.Unit.Module.ModIface -#if !MIN_VERSION_ghc(8,8,0)-import qualified EnumSet-import           SrcLoc                                (RealLocated)+-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -import           Foreign.ForeignPtr-import           System.IO-#endif+#if MIN_VERSION_ghc(9,13,0)+import           GHC.Unit.Home.Graph                     (addHomeModInfoToHug, unitEnv_assocs) #endif -import           Compat.HieAst                         (enrichHie)-import           Compat.HieBin-import           Compat.HieTypes-import           Compat.HieUtils-import qualified Data.ByteString                       as BS-import           Data.IORef--import           Data.List                             (foldl')-import qualified Data.Map                              as Map-import qualified Data.Set                              as Set--#if MIN_VERSION_ghc(9,0,0)-import qualified Data.Set                              as S+#if MIN_VERSION_ghc(9,7,0)+import           GHC.Tc.Zonk.TcType                      (tcInitTidyEnv) #endif -#if !MIN_VERSION_ghc(8,10,0)-import           Bag                                   (unitBag)-#endif+#if !MIN_VERSION_ghc(9,7,0)+liftZonkM :: a -> a+liftZonkM = id -#if MIN_VERSION_ghc(9,2,0)-import GHC.Types.CostCentre-import GHC.Stg.Syntax-import GHC.Types.IPE-import GHC.Stg.Syntax-import GHC.Types.IPE-import GHC.Types.CostCentre-import GHC.Core-import GHC.Builtin.Uniques-import GHC.Runtime.Interpreter-import GHC.StgToByteCode-import GHC.Stg.Pipeline-import GHC.ByteCode.Types-import GHC.Linker.Loader (loadDecls)-import GHC.Data.Maybe-import GHC.CoreToStg+nonDetFoldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b+nonDetFoldOccEnv = foldOccEnv #endif + type ModIfaceAnnotation = Annotation -#if MIN_VERSION_ghc(9,2,0)+ myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext+            -> Bool                 -> Module -> ModLocation -> CoreExpr                 -> IO ( Id-                      , [StgTopBinding]+                      ,[CgStgTopBinding] -- output program                       , InfoTableProvMap                       , CollectedCCs )-myCoreToStgExpr logger dflags ictxt this_mod ml prepd_expr = do+myCoreToStgExpr logger dflags ictxt+                for_bytecode+                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)-                                Many+                                ManyTy                                 (exprType prepd_expr)     (stg_binds, prov_map, collected_ccs) <-        myCoreToStg logger                    dflags                    ictxt+                   for_bytecode                    this_mod                    ml                    [NonRec bco_tmp_id prepd_expr]     return (bco_tmp_id, stg_binds, prov_map, collected_ccs)  myCoreToStg :: Logger -> DynFlags -> InteractiveContext+            -> Bool             -> Module -> ModLocation -> CoreProgram-            -> IO ( [StgTopBinding] -- output program+            -> IO ( [CgStgTopBinding] -- output program                   , InfoTableProvMap                   , CollectedCCs )  -- CAF cost centre info (declared and used)-myCoreToStg logger dflags ictxt this_mod ml prepd_binds = do+myCoreToStg logger dflags ictxt+            for_bytecode+            this_mod ml prepd_binds = do     let (stg_binds, denv, cost_centre_info)          = {-# SCC "Core2Stg" #-}-           coreToStg dflags this_mod ml prepd_binds+           coreToStg+             (initCoreToStgOpts dflags)+             this_mod ml prepd_binds -    stg_binds2+#if MIN_VERSION_ghc(9,8,0)+    (unzip -> (stg_binds2,_),_)+#else+    (stg_binds2,_)+#endif         <- {-# SCC "Stg2Stg" #-}-           stg2stg logger dflags ictxt this_mod stg_binds+           stg2stg logger+                   (interactiveInScope ictxt)+                   (initStgPipelineOpts dflags for_bytecode) this_mod stg_binds      return (stg_binds2, denv, cost_centre_info)-#endif --#if !MIN_VERSION_ghc(9,2,0)-reLoc :: Located a -> Located a-reLoc = id--reLocA :: Located a -> Located a-reLocA = id+#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,0,0)-getDependentMods = map gwib_mod . dep_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 fst . 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,0,0)-simplifyExpr _ = GHC.simplifyExpr+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))  corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr-corePrepExpr _ = GHC.corePrepExpr-#else-simplifyExpr df _ = GHC.simplifyExpr df-#endif--#if !MIN_VERSION_ghc(8,8,0)-hPutStringBuffer :: Handle -> StringBuffer -> IO ()-hPutStringBuffer hdl (StringBuffer buf len cur)-    = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->-             hPutBuf hdl ptr len-#endif--#if MIN_VERSION_ghc(9,2,0)-type ErrMsg  = MsgEnvelope DecoratedSDoc-#endif+corePrepExpr _ env expr = do+  cfg <- initCorePrepConfig env+  GHC.corePrepExpr (Development.IDE.GHC.Compat.Env.hsc_logger env) cfg expr -getMessages' :: PState -> DynFlags -> (Bag WarnMsg, Bag ErrMsg)-getMessages' pst dflags =-#if MIN_VERSION_ghc(9,2,0)-                 bimap (fmap pprWarning) (fmap pprError) $-#endif-                 getMessages pst-#if !MIN_VERSION_ghc(9,2,0)-                   dflags-#endif+renderMessages :: PsMessages -> (Bag WarnMsg, Bag ErrMsg)+renderMessages msgs =+  let renderMsgs extractor = (fmap . fmap) GhcPsMessage . getMessages $ extractor msgs+  in (renderMsgs psWarnings, renderMsgs psErrors) -#if MIN_VERSION_ghc(9,2,0)-pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope DecoratedSDoc)) -> ParseResult a-pattern PFailedWithErrorMessages msgs-     <- PFailed (const . fmap pprError . getErrorMessages -> msgs)-#elif MIN_VERSION_ghc(8,10,0)-pattern PFailedWithErrorMessages :: (DynFlags -> ErrorMessages) -> ParseResult a-pattern PFailedWithErrorMessages msgs-     <- PFailed (getErrorMessages -> msgs)-#else-pattern PFailedWithErrorMessages :: (DynFlags -> ErrorMessages) -> ParseResult a+pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope GhcMessage)) -> ParseResult a pattern PFailedWithErrorMessages msgs-     <- ((fmap.fmap) unitBag . mkPlainErrMsgIfPFailed -> Just msgs)--mkPlainErrMsgIfPFailed (PFailed _ pst err) = Just (\dflags -> mkPlainErrMsg dflags pst err)-mkPlainErrMsgIfPFailed _ = Nothing-#endif-{-# COMPLETE PFailedWithErrorMessages #-}--supportsHieFiles :: Bool-supportsHieFiles = True+     <- PFailed (const . fmap (fmap GhcPsMessage) . getMessages . getPsErrorMessages -> msgs)+{-# COMPLETE POk, PFailedWithErrorMessages #-}  hieExportNames :: HieFile -> [(SrcSpan, Name)] hieExportNames = nameListFromAvails . hie_exports --upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c-#if MIN_VERSION_ghc(8,8,0)-upNameCache = updNameCache-#else-upNameCache ref upd_fn-  = atomicModifyIORef' ref upd_fn-#endif--#if !MIN_VERSION_ghc(9,0,1)-type RefMap a = Map.Map Identifier [(Span, IdentifierDetails a)]-#endif+type NameCacheUpdater = NameCache  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@@ -375,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@@ -385,27 +348,15 @@     where f i = i{includePathsQuote = path : includePathsQuote i}  setHieDir :: FilePath -> DynFlags -> DynFlags-setHieDir _f d =-#if MIN_VERSION_ghc(8,8,0)-    d { hieDir     = Just _f}-#else-    d-#endif+setHieDir _f d = d { hieDir = Just _f}  dontWriteHieFiles :: DynFlags -> DynFlags-dontWriteHieFiles d =-#if MIN_VERSION_ghc(8,8,0)-    gopt_unset d Opt_WriteHie-#else-    d-#endif+dontWriteHieFiles d = gopt_unset d Opt_WriteHie -setUpTypedHoles ::DynFlags -> DynFlags+setUpTypedHoles :: DynFlags -> DynFlags setUpTypedHoles df   = flip gopt_unset Opt_AbstractRefHoleFits    -- too spammy-#if MIN_VERSION_ghc(8,8,0)   $ flip gopt_unset Opt_ShowDocsOfHoleFits     -- not used-#endif   $ flip gopt_unset Opt_ShowMatchesOfHoleFits  -- nice but broken (forgets module qualifiers)   $ flip gopt_unset Opt_ShowProvOfHoleFits     -- not used   $ flip gopt_unset Opt_ShowTypeAppOfHoleFits  -- not used@@ -415,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   }  @@ -427,35 +382,26 @@   getModuleHash :: ModIface -> Fingerprint-#if MIN_VERSION_ghc(8,10,0)-getModuleHash = mi_mod_hash . mi_final_exts-#else+#if MIN_VERSION_ghc(9,13,0) getModuleHash = mi_mod_hash+#else+getModuleHash = mi_mod_hash . mi_final_exts #endif   disableWarningsAsErrors :: DynFlags -> DynFlags disableWarningsAsErrors df =-    flip gopt_unset Opt_WarnIsError $ foldl' wopt_unset_fatal df [toEnum 0 ..]--#if !MIN_VERSION_ghc(8,8,0)-wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags-wopt_unset_fatal dfs f-    = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) }-#endif+    flip gopt_unset Opt_WarnIsError $! foldl' wopt_unset_fatal df [toEnum 0 ..]  isQualifiedImport :: ImportDecl a -> Bool-#if MIN_VERSION_ghc(8,10,0) isQualifiedImport ImportDecl{ideclQualified = NotQualified} = False isQualifiedImport ImportDecl{}                              = True-#else-isQualifiedImport ImportDecl{ideclQualified}                = ideclQualified-#endif 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 -#if MIN_VERSION_ghc(9,0,0) getNodeIds :: HieAST a -> Map.Map Identifier (IdentifierDetails a) getNodeIds = Map.foldl' combineNodeIds Map.empty . getSourcedNodeInfo . sourcedNodeInfo @@ -473,100 +419,93 @@   NodeInfo (S.union as bs) (mergeSorted ai bi) (Map.unionWith (<>) ad bd)   where     mergeSorted :: Ord a => [a] -> [a] -> [a]-    mergeSorted la@(a:as) lb@(b:bs) = case compare a b of-                                        LT -> a : mergeSorted as lb-                                        EQ -> a : mergeSorted as bs-                                        GT -> b : mergeSorted la bs-    mergeSorted as [] = as-    mergeSorted [] bs = bs--#else--getNodeIds :: HieAST a -> NodeIdentifiers a-getNodeIds = nodeIdentifiers . nodeInfo--- import qualified FastString as FS+    mergeSorted la@(a:axs) lb@(b:bxs) = case compare a b of+                                        LT -> a : mergeSorted axs lb+                                        EQ -> a : mergeSorted axs bxs+                                        GT -> b : mergeSorted la bxs+    mergeSorted axs [] = axs+    mergeSorted [] bxs = bxs --- nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex-nodeInfo' :: Ord a => HieAST a -> NodeInfo a-nodeInfo' = nodeInfo--- type Unit = UnitId--- moduleUnit :: Module -> Unit--- moduleUnit = moduleUnitId--- unhelpfulSpanFS :: FS.FastString -> FS.FastString--- unhelpfulSpanFS = id-#endif+sourceNodeInfo :: HieAST a -> Maybe (NodeInfo a)+sourceNodeInfo = Map.lookup SourceInfo . getSourcedNodeInfo . sourcedNodeInfo -nodeInfoFromSource :: HieAST a -> Maybe (NodeInfo a)-#if MIN_VERSION_ghc(9,0,0)-nodeInfoFromSource = Map.lookup SourceInfo . getSourcedNodeInfo . sourcedNodeInfo-#else-nodeInfoFromSource = Just . nodeInfo-#endif+generatedNodeInfo :: HieAST a -> Maybe (NodeInfo a)+generatedNodeInfo = Map.lookup GeneratedInfo . getSourcedNodeInfo . sourcedNodeInfo  data GhcVersion-  = GHC86-  | GHC88-  | GHC810-  | GHC90-  | GHC92-  deriving (Eq, Ord, Show)+  = GHC96+  | GHC98+  | GHC910+  | GHC912+  | GHC914+  deriving (Eq, Ord, Show, Enum)  ghcVersionStr :: String ghcVersionStr = VERSION_ghc  ghcVersion :: GhcVersion-#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)-ghcVersion = GHC92-#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-ghcVersion = GHC90-#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)-ghcVersion = GHC810-#elif MIN_VERSION_GLASGOW_HASKELL(8,8,0,0)-ghcVersion = GHC88-#elif MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)-ghcVersion = GHC86-#endif--runUnlit :: Logger -> DynFlags -> [Option] -> IO ()-runUnlit =-#if MIN_VERSION_ghc(9,2,0)-    SysTools.runUnlit+#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 #else-    const SysTools.runUnlit+ghcVersion = GHC96 #endif -runPp :: Logger -> DynFlags -> [Option] -> IO ()-runPp =-#if MIN_VERSION_ghc(9,2,0)-    SysTools.runPp-#else-    const SysTools.runPp-#endif+simpleNodeInfoCompat :: FastStringCompat -> FastStringCompat -> NodeInfo a+simpleNodeInfoCompat ctor typ = simpleNodeInfo (coerce ctor) (coerce typ) -isAnnotationInNodeInfo :: (FastString, FastString) -> NodeInfo a -> Bool-#if MIN_VERSION_ghc(9,2,0)-isAnnotationInNodeInfo (ctor, typ) = Set.member (NodeAnnotation ctor typ) . nodeAnnotations-#else-isAnnotationInNodeInfo p = Set.member p . nodeAnnotations-#endif+isAnnotationInNodeInfo :: (FastStringCompat, FastStringCompat) -> NodeInfo a -> Bool+isAnnotationInNodeInfo p = S.member p . nodeAnnotations +nodeAnnotations :: NodeInfo a -> S.Set (FastStringCompat, FastStringCompat)+nodeAnnotations = S.map (\(NodeAnnotation ctor typ) -> (coerce ctor, coerce typ)) . GHC.nodeAnnotations++newtype FastStringCompat = FastStringCompat LexicalFastString+    deriving (Show, Eq, Ord)++instance IsString FastStringCompat where+    fromString = FastStringCompat . LexicalFastString . fromString+ mkAstNode :: NodeInfo a -> Span -> [HieAST a] -> HieAST a-#if MIN_VERSION_ghc(9,0,0) mkAstNode n = Node (SourcedNodeInfo $ Map.singleton GeneratedInfo n)++-- | Load modules, quickly. Input doesn't need to be desugared.+-- A module must be loaded before dependent modules can be typechecked.+-- This variant of loadModuleHome will *never* cause recompilation, it just+-- modifies the session.+-- The order modules are loaded is important when there are hs-boot files.+-- In particular you should make sure to load the .hs version of a file after the+-- .hs-boot version.+loadModulesHome+    :: [HomeModInfo]+    -> HscEnv+#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-mkAstNode = Node+    -> HscEnv+loadModulesHome mod_infos e =+  hscUpdateHUG (\hug -> foldl' (flip addHomeModInfoToHug) hug mod_infos) (e { hsc_type_env_vars = emptyKnotVars }) #endif -combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan-#if MIN_VERSION_ghc(9,2,0)-combineRealSrcSpans = SrcLoc.combineRealSrcSpans-#else-combineRealSrcSpans span1 span2-  = mkRealSrcSpan (mkRealSrcLoc file line_start col_start) (mkRealSrcLoc file line_end col_end)-  where-    (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1)-                                  (srcSpanStartLine span2, srcSpanStartCol span2)-    (line_end, col_end)     = max (srcSpanEndLine span1, srcSpanEndCol span1)-                                  (srcSpanEndLine span2, srcSpanEndCol span2)-    file = srcSpanFile span1+#if MIN_VERSION_ghc(9,13,0)+hugElts :: HomeUnitGraph -> [(UnitId, HomeUnitEnv)]+hugElts = unitEnv_assocs #endif++recDotDot :: HsRecFields (GhcPass p) arg -> Maybe Int+recDotDot x =+            unRecFieldsDotDot <$>+            unLoc <$> rec_dotdot x++extract_cons :: DataDefnCons a -> [a]+extract_cons (NewTypeCon x)      = [x]+extract_cons (DataTypeCons _ xs) = xs
− src/Development/IDE/GHC/Compat/CPP.hs 
@@ -1,204 +0,0 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.--- SPDX-License-Identifier: Apache-2.0---- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019--- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944.--- Update the above MR got merged to master on 31 May 2019. When it becomes avialable to ghc-lib, this file can be removed.--{- HLINT ignore -} -- since copied from upstream--{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--- | Re-export 'doCpp' for GHC < 8.10.------ Later versions export what we need.-module Development.IDE.GHC.Compat.CPP (-    doCpp-    ) where--import           FileCleanup-import           Packages-import           Panic-import           SysTools-#if MIN_VERSION_ghc(8,8,2)-import           LlvmCodeGen                (llvmVersionList)-#elif MIN_VERSION_ghc(8,8,0)-import           LlvmCodeGen                (LlvmVersion (..))-#endif-import           Control.Monad-import           Data.List                  (intercalate)-import           Data.Maybe-import           Data.Version-import           DynFlags-import           Module                     (rtsUnitId, toInstalledUnitId)-import           System.Directory-import           System.FilePath-import           System.Info--import           Development.IDE.GHC.Compat as Compat--doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()-doCpp dflags raw input_fn output_fn = do-    let hscpp_opts = picPOpts dflags-    let cmdline_include_paths = includePaths dflags--    pkg_include_dirs <- getPackageIncludePath dflags []-    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []-          (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)-    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []-          (includePathsQuote cmdline_include_paths)-    let include_paths = include_paths_quote ++ include_paths_global--    let verbFlags = getVerbFlags dflags--    let cpp_prog args | raw       = SysTools.runCpp dflags args-#if MIN_VERSION_ghc(8,10,0)-                      | otherwise = SysTools.runCc Nothing-#else-                      | otherwise = SysTools.runCc-#endif-                                          dflags (SysTools.Option "-E" : args)--    let target_defs =-          -- NEIL: Patched to use System.Info instead of constants from CPP-          [ "-D" ++ os     ++ "_BUILD_OS",-            "-D" ++ arch   ++ "_BUILD_ARCH",-            "-D" ++ os     ++ "_HOST_OS",-            "-D" ++ arch   ++ "_HOST_ARCH" ]-        -- remember, in code we *compile*, the HOST is the same our TARGET,-        -- and BUILD is the same as our HOST.--    let sse_defs =-          [ "-D__SSE__"      | isSseEnabled      dflags ] ++-          [ "-D__SSE2__"     | isSse2Enabled     dflags ] ++-          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]--    let avx_defs =-          [ "-D__AVX__"      | isAvxEnabled      dflags ] ++-          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] ++-          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++-          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++-          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] ++-          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]--    backend_defs <- getBackendDefs dflags--    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]-    -- Default CPP defines in Haskell source-    ghcVersionH <- getGhcVersionPathName dflags-    let hsSourceCppOpts = [ "-include", ghcVersionH ]--    -- MIN_VERSION macros-    let uids = explicitPackages (pkgState dflags)-        pkgs = catMaybes (map (lookupPackage dflags) uids)-    mb_macro_include <--        if not (null pkgs) && gopt Opt_VersionMacros dflags-            then do macro_stub <- newTempName dflags TFL_CurrentModule "h"-                    writeFile macro_stub (generatePackageVersionMacros pkgs)-                    -- Include version macros for every *exposed* package.-                    -- Without -hide-all-packages and with a package database-                    -- size of 1000 packages, it takes cpp an estimated 2-                    -- milliseconds to process this file. See #10970-                    -- comment 8.-                    return [SysTools.FileOption "-include" macro_stub]-            else return []--    cpp_prog       (   map SysTools.Option verbFlags-                    ++ map SysTools.Option include_paths-                    ++ map SysTools.Option hsSourceCppOpts-                    ++ map SysTools.Option target_defs-                    ++ map SysTools.Option backend_defs-                    ++ map SysTools.Option th_defs-                    ++ map SysTools.Option hscpp_opts-                    ++ map SysTools.Option sse_defs-                    ++ map SysTools.Option avx_defs-                    ++ mb_macro_include-        -- Set the language mode to assembler-with-cpp when preprocessing. This-        -- alleviates some of the C99 macro rules relating to whitespace and the hash-        -- operator, which we tend to abuse. Clang in particular is not very happy-        -- about this.-                    ++ [ SysTools.Option     "-x"-                       , SysTools.Option     "assembler-with-cpp"-                       , SysTools.Option     input_fn-        -- We hackily use Option instead of FileOption here, so that the file-        -- name is not back-slashed on Windows.  cpp is capable of-        -- dealing with / in filenames, so it works fine.  Furthermore-        -- if we put in backslashes, cpp outputs #line directives-        -- with *double* backslashes.   And that in turn means that-        -- our error messages get double backslashes in them.-        -- In due course we should arrange that the lexer deals-        -- with these \\ escapes properly.-                       , SysTools.Option     "-o"-                       , SysTools.FileOption "" output_fn-                       ])--getBackendDefs :: DynFlags -> IO [String]-getBackendDefs dflags | hscTarget dflags == HscLlvm = do-    llvmVer <- figureLlvmVersion dflags-    return $ case llvmVer of-#if MIN_VERSION_ghc(8,8,2)-               Just v-                 | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ]-                 | m:n:_   <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ]-#elif MIN_VERSION_ghc(8,8,0)-               Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]-               Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]-#else-               Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]-#endif-               _      -> []-  where-    format (major, minor)-      | minor >= 100 = error "getBackendDefs: Unsupported minor version"-      | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int--getBackendDefs _ =-    return []---- ------------------------------------------------------------------------------ Macros (cribbed from Cabal)--generatePackageVersionMacros :: [Compat.UnitInfo] -> String-generatePackageVersionMacros pkgs = concat-  -- Do not add any C-style comments. See #3389.-  [ generateMacros "" pkgname version-  | pkg <- pkgs-  , let version = packageVersion pkg-        pkgname = map fixchar (packageNameString pkg)-  ]--fixchar :: Char -> Char-fixchar '-' = '_'-fixchar c   = c--generateMacros :: String -> String -> Version -> String-generateMacros prefix name version =-  concat-  ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"-  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"-  ,"  (major1) <  ",major1," || \\\n"-  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"-  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"-  ,"\n\n"-  ]-  where-    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)----- | Find out path to @ghcversion.h@ file-getGhcVersionPathName :: DynFlags -> IO FilePath-getGhcVersionPathName dflags = do-  candidates <- case ghcVersionFile dflags of-    Just path -> return [path]-    Nothing -> (map (</> "ghcversion.h")) <$>-               (getPackageIncludePath dflags [toInstalledUnitId rtsUnit])--  found <- filterM doesFileExist candidates-  case found of-      []    -> throwGhcExceptionIO (InstallationError-                                    ("ghcversion.h missing; tried: "-                                      ++ intercalate ", " candidates))-      (x:_) -> return x--rtsUnit :: UnitId-rtsUnit = Module.rtsUnitId
+ 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,11 +1,7 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE ConstraintKinds   #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PatternSynonyms   #-}--- TODO: remove-{-# OPTIONS -Wno-dodgy-imports -Wno-unused-imports #-}+{-# LANGUAGE CPP             #-}+{-# LANGUAGE PatternSynonyms #-} --- | Compat Core module that handles the GHC module hierarchy re-organisation+-- | Compat Core module that handles the GHC module hierarchy re-organization -- by re-exporting everything we care about. -- -- This module provides no other compat mechanisms, except for simple@@ -35,12 +31,13 @@     maxRefHoleFits,     maxValidHoleFits,     setOutputFile,-#if MIN_VERSION_ghc(8,8,0)+    lookupType,+    needWiredInHomeIface,+    loadWiredInHomeIface,+    readIface,+    loadSysInterface,+    importDecl,     CommandLineOption,-#if !MIN_VERSION_ghc(9,2,0)-    staticPlugins,-#endif-#endif     sPgm_F,     settings,     gopt,@@ -61,47 +58,38 @@     pattern ExposePackage,     parseDynamicFlagsCmdLine,     parseDynamicFilePragma,-    WarnReason(..),     wWarningFlags,     updOptLevel,     -- slightly unsafe     setUnsafeGlobalDynFlags,     -- * Linear Haskell-#if !MIN_VERSION_ghc(9,0,0)-    Scaled,-    unrestricted,-#endif     scaledThing,     -- * Interface Files     IfaceExport,     IfaceTyCon(..),-#if MIN_VERSION_ghc(8,10,0)     ModIface,     ModIface_(..),-#else-    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,-    SourceModified(..),     loadModuleInterface,     RecompileRequired(..),-#if MIN_VERSION_ghc(8,10,0)     mkPartialIface,     mkFullIface,-#else-    mkIface,-#endif-    checkOldIface,-#if MIN_VERSION_ghc(9,0,0)     IsBootInterface(..),-#else-    pattern IsBoot,-    pattern NotBoot,-#endif     -- * Fixity     LexicalFixity(..),+    Fixity (..),+    mi_fix,+    defaultFixity,+    lookupFixityRn,     -- * ModSummary     ModSummary(..),     -- * HomeModInfo@@ -112,10 +100,6 @@     -- * ModDetails     ModDetails(..),     -- * HsExpr,-#if !MIN_VERSION_ghc(9,2,0)-    pattern HsLet,-    pattern LetStmt,-#endif     -- * Var     Type (       TyCoRep.TyVarTy,@@ -131,21 +115,13 @@       ),     pattern FunTy,     pattern ConPatIn,-#if !MIN_VERSION_ghc(9,2,0)-    Development.IDE.GHC.Compat.Core.splitForAllTyCoVars,-#endif-    Development.IDE.GHC.Compat.Core.mkVisFunTys,-    Development.IDE.GHC.Compat.Core.mkInfForAllTys,+    conPatDetails,+    mapConPatDetail,     -- * Specs     ImpDeclSpec(..),     ImportSpec(..),     -- * SourceText     SourceText(..),-#if !MIN_VERSION_ghc(9,2,0)-    rationalFromFractionalLit,-#endif-    -- * Name-    tyThingParent_maybe,     -- * Ways     Way,     wayGeneralFlags,@@ -157,7 +133,9 @@     pattern AvailTC,     Avail.availName,     Avail.availNames,+#if !MIN_VERSION_ghc(9,7,0)     Avail.availNamesWithSelectors,+#endif     Avail.availsToNameSet,     -- * TcGblEnv     TcGblEnv(..),@@ -184,12 +162,17 @@     hscInteractive,     hscSimplify,     hscTypecheckRename,-    makeSimpleDetails,+    hscUpdateHPT,+    Development.IDE.GHC.Compat.Core.makeSimpleDetails,     -- * Typecheck utils-    Development.IDE.GHC.Compat.Core.tcSplitForAllTyVars,-    Development.IDE.GHC.Compat.Core.tcSplitForAllTyVarBinder_maybe,+    tcSplitForAllTyVars,+    tcSplitForAllTyVarBinder_maybe,     typecheckIface,-    mkIfaceTc,+    Development.IDE.GHC.Compat.Core.mkIfaceTc,+    Development.IDE.GHC.Compat.Core.mkBootModDetailsTc,+    Development.IDE.GHC.Compat.Core.initTidyOpts,+    driverNoStop,+    tidyProgram,     ImportedModsVal(..),     importedByUser,     GHC.TypecheckedSource,@@ -198,17 +181,14 @@     SrcLoc.Located,     SrcLoc.unLoc,     getLoc,-    getLocA,-    locA,-    noLocA,+    GHC.getLocA,+    GHC.locA,+    GHC.noLocA,+    unLocA,     LocatedAn,-#if MIN_VERSION_ghc(9,2,0)+    GHC.LocatedA,     GHC.AnnListItem(..),     GHC.NameAnn(..),-#else-    AnnListItem,-    NameAnn,-#endif     SrcLoc.RealLocated,     SrcLoc.GenLocated(..),     SrcLoc.SrcSpan(SrcLoc.UnhelpfulSpan),@@ -218,8 +198,7 @@     pattern RealSrcLoc,     SrcLoc.SrcLoc(SrcLoc.UnhelpfulLoc),     BufSpan,-#if MIN_VERSION_ghc(9,2,0)-    SrcSpanAnn',+#if !MIN_VERSION_ghc(9,9,0)     GHC.SrcAnn, #endif     SrcLoc.leftmost_smallest,@@ -227,7 +206,7 @@     SrcLoc.mkGeneralSrcSpan,     SrcLoc.mkRealSrcSpan,     SrcLoc.mkRealSrcLoc,-    getRealSrcSpan,+    SrcLoc.getRealSrcSpan,     SrcLoc.realSrcLocSpan,     SrcLoc.realSrcSpanStart,     SrcLoc.realSrcSpanEnd,@@ -248,23 +227,24 @@     SrcLoc.noSrcSpan,     SrcLoc.noSrcLoc,     SrcLoc.noLoc,-#if !MIN_VERSION_ghc(8,10,0) && MIN_VERSION_ghc(8,8,0)-    SrcLoc.dL,-#endif+    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,-    initDynLinker,     -- * Hooks     Hooks,     runMetaHook,@@ -281,7 +261,7 @@     -- * Driver-Make     Target(..),     TargetId(..),-    mkModuleGraph,+    mkSimpleTarget,     -- * GHCi     initObjLinker,     loadDLL,@@ -293,18 +273,16 @@     Warn(..),     -- * ModLocation     GHC.ModLocation,-    pattern ModLocation,     Module.ml_hs_file,     Module.ml_obj_file,     Module.ml_hi_file,-    Development.IDE.GHC.Compat.Core.ml_hie_file,+    Module.ml_hie_file,     -- * DataCon-    Development.IDE.GHC.Compat.Core.dataConExTyCoVars,+    DataCon.dataConExTyCoVars,     -- * Role     Role(..),     -- * Panic-    PlainGhcException,-    panic,+    Plain.PlainGhcException,     -- * Other     GHC.CoreModule(..),     GHC.SafeHaskellMode(..),@@ -313,11 +291,8 @@     gre_imp,     gre_lcl,     gre_par,-#if MIN_VERSION_ghc(9,2,0)     collectHsBindsBinders,-#endif     -- * Util Module re-exports-#if MIN_VERSION_ghc(9,0,0)     module GHC.Builtin.Names,     module GHC.Builtin.Types,     module GHC.Builtin.Types.Prim,@@ -329,9 +304,6 @@     module GHC.Core.FamInstEnv,     module GHC.Core.InstEnv,     module GHC.Types.Unique.FM,-#if !MIN_VERSION_ghc(9,2,0)-    module GHC.Core.Ppr.TyThing,-#endif     module GHC.Core.PatSyn,     module GHC.Core.Predicate,     module GHC.Core.TyCon,@@ -344,10 +316,9 @@     module GHC.HsToCore.Expr,     module GHC.HsToCore.Monad, -    module GHC.Iface.Tidy,     module GHC.Iface.Syntax,+    module GHC.Iface.Recomp, -#if MIN_VERSION_ghc(9,2,0)     module GHC.Hs.Decls,     module GHC.Hs.Expr,     module GHC.Hs.Doc,@@ -357,7 +328,6 @@     module GHC.Hs.Type,     module GHC.Hs.Utils,     module Language.Haskell.Syntax,-#endif      module GHC.Rename.Names,     module GHC.Rename.Splice,@@ -371,425 +341,282 @@      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,-#if MIN_VERSION_ghc(9,2,0)+    module GHC.Utils.Error,+#if !MIN_VERSION_ghc(9,7,0)     module GHC.Types.Avail,+#endif     module GHC.Types.SourceFile,     module GHC.Types.SourceText,     module GHC.Types.TyThing,     module GHC.Types.TyThing.Ppr,-#endif     module GHC.Types.Unique.Supply,     module GHC.Types.Var,     module GHC.Unit.Module,-    module GHC.Utils.Error,-#else-    module BasicTypes,-    module Class,-#if MIN_VERSION_ghc(8,10,0)-    module Coercion,-    module Predicate,-#endif-    module ConLike,-    module CoreUtils,-    module DataCon,-    module DsExpr,-    module DsMonad,-    module ErrUtils,-    module FamInst,-    module FamInstEnv,-    module HeaderInfo,-    module Id,-    module InstEnv,-    module IfaceSyn,-    module Module,-    module Name,-    module NameCache,-    module NameEnv,-    module NameSet,-    module PatSyn,-    module PprTyThing,-    module PrelInfo,-    module PrelNames,-    module RdrName,-    module RnSplice,-    module RnNames,-    module TcEnv,-    module TcEvidence,-    module TcType,-    module TcRnTypes,-    module TcRnDriver,-    module TcRnMonad,-    module TidyPgm,-    module TyCon,-    module TysPrim,-    module TysWiredIn,-    module Type,-    module Unify,-    module UniqFM,-    module UniqSupply,-    module Var,-#endif+    module GHC.Unit.Module.Graph,     -- * Syntax re-exports-#if MIN_VERSION_ghc(9,0,0)     module GHC.Hs,+    module GHC.Hs.Binds,     module GHC.Parser,     module GHC.Parser.Header,     module GHC.Parser.Lexer,-#else-#if MIN_VERSION_ghc(8,10,0)-    module GHC.Hs,-#else-    module HsBinds,-    module HsDecls,-    module HsDoc,-    module HsExtension,-    noExtField,-    module HsExpr,-    module HsImpExp,-    module HsLit,-    module HsPat,-    module HsSyn,-    module HsTypes,-    module HsUtils,-#endif-    module ExtractDocs,-    module Parser,-    module Lexer,+    module GHC.Utils.Panic,+    CompileReason(..),+    hsc_type_env_vars,+    hscUpdateHUG, hsc_HUG,+    GhcMessage(..),+    getKey,+    module GHC.Driver.Env.KnotVars,+    module GHC.Linker.Types,+    module GHC.Types.Unique.Map,+    module GHC.Utils.TmpFs,+    module GHC.Unit.Finder.Types,+    module GHC.Unit.Env,+    module GHC.Driver.Phases,+    Extension(..),+    mkCgInteractiveGuts,+    justBytecode,+    justObjects,+    emptyHomeModInfoLinkable,+    homeModInfoByteCode,+    homeModInfoObject,+    groupOrigin,+    isVisibleFunArg,+#if MIN_VERSION_ghc(9,8,0)+    lookupGlobalRdrEnv #endif     ) where  import qualified GHC -#if MIN_VERSION_ghc(9,0,0)-import           GHC.Builtin.Names            hiding (Unique, printName)+-- 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.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-#if MIN_VERSION_ghc(9,2,0)-import           GHC.Data.Bag-import           GHC.Core.Multiplicity        (scaledThing)-#else-import           GHC.Core.Ppr.TyThing         hiding (pprFamInst)-import           GHC.Core.TyCo.Rep            (scaledThing)-#endif 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                hiding (mkInfForAllTys,-                                               mkVisFunTys)+import           GHC.Core.Type import           GHC.Core.Unify import           GHC.Core.Utils---#if MIN_VERSION_ghc(9,2,0)-import           GHC.Driver.Env-#else-import           GHC.Driver.Finder-import           GHC.Driver.Types-import           GHC.Driver.Ways-#endif-import           GHC.Driver.CmdLine           (Warn (..))+import           GHC.Driver.CmdLine          (Warn (..)) import           GHC.Driver.Hooks-import           GHC.Driver.Main+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-#if MIN_VERSION_ghc(9,2,0)-import           GHC.Hs                       (HsModule (..), SrcSpanAnn')-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.Hs.Utils                 as GHC-#endif-#if !MIN_VERSION_ghc(9,2,0)-import           GHC.Hs                       hiding (HsLet, LetStmt)-#endif+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               (mkFullIface, mkIfaceTc,-                                               mkPartialIface)+import           GHC.Iface.Make              as GHC import           GHC.Iface.Recomp import           GHC.Iface.Syntax-import           GHC.Iface.Tidy+import           GHC.Iface.Tidy              as GHC import           GHC.IfaceToCore import           GHC.Parser-import           GHC.Parser.Header            hiding (getImports)-#if MIN_VERSION_ghc(9,2,0)-import qualified GHC.Linker.Loader            as Linker-import           GHC.Linker.Types-import           GHC.Parser.Lexer             hiding (initParserState)-import           GHC.Parser.Annotation        (EpAnn (..))-import           GHC.Platform.Ways-import           GHC.Runtime.Context          (InteractiveImport (..))-#else-import           GHC.Parser.Lexer-import qualified GHC.Runtime.Linker           as Linker-#endif+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-#if MIN_VERSION_ghc(9,2,0)-import           GHC.Types.Avail              (greNamePrintableName)-import           GHC.Types.Fixity             (LexicalFixity (..))-#endif-#if MIN_VERSION_ghc(9,2,0)-import           GHC.Types.Meta-#endif+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-#if MIN_VERSION_ghc(9,2,0)+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 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.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.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.Linker.Types+import           GHC.Parser.Annotation       (EpAnn (..))+import           GHC.Parser.Lexer            hiding (getPsMessages,+                                              initParserState)+import           GHC.Platform.Ways+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 (..),-                                               SourceModified (..))+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-#else-import           GHC.Types.Name.Set-#endif-import           GHC.Types.SrcLoc             (BufPos, BufSpan,-                                               SrcLoc (UnhelpfulLoc),-                                               SrcSpan (UnhelpfulSpan))-import qualified GHC.Types.SrcLoc             as SrcLoc-import           GHC.Types.Unique.Supply-import           GHC.Types.Var                (Var (varName), setTyVarUnique,-                                               setVarUnique)-#if MIN_VERSION_ghc(9,2,0)-import           GHC.Unit.Finder+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.Info                (PackageName (..))-import           GHC.Unit.Module              hiding (ModLocation (..), UnitId,-                                               addBootSuffixLocnOut, moduleUnit,-                                               toUnitId)-import qualified GHC.Unit.Module              as Module-#if MIN_VERSION_ghc(9,2,0)-import           GHC.Unit.Module.Graph        (mkModuleGraph)+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_ (..))-import           GHC.Unit.Module.ModSummary   (ModSummary (..))+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-import           GHC.Unit.State               (ModuleOrigin (..))-import           GHC.Utils.Error              (Severity (..))-import           GHC.Utils.Panic              hiding (try)-import qualified GHC.Utils.Panic.Plain        as Plain-#else-import qualified Avail-import           BasicTypes                   hiding (Version)-import           Class-import           CmdLineParser                (Warn (..))-import           ConLike-import           CoreUtils-import           DataCon                      hiding (dataConExTyCoVars)-import qualified DataCon-import           DriverPhases-import           DriverPipeline-import           DsExpr-import           DsMonad                      hiding (foldrM)-import           DynFlags                     hiding (ExposePackage)-import qualified DynFlags-import           ErrUtils                     hiding (logInfo, mkWarnMsg)-import           ExtractDocs-import           FamInst-import           FamInstEnv-import           Finder-#if MIN_VERSION_ghc(8,10,0)-import           GHC.Hs                       hiding (HsLet, LetStmt) #endif-import qualified GHCi-import           GhcMonad-import           HeaderInfo                   hiding (getImports)-import           Hooks-import           HscMain-import           HscTypes-#if !MIN_VERSION_ghc(8,10,0)--- Syntax imports-import           HsBinds-import           HsDecls-import           HsDoc-import           HsExpr                       hiding (HsLet, LetStmt)-import           HsExtension-import           HsImpExp-import           HsLit-import           HsPat-import           HsSyn                        hiding (wildCardName, HsLet, LetStmt)-import           HsTypes                      hiding (wildCardName)-import           HsUtils-#endif-import           Id-import           IfaceSyn-import           InstEnv-import           Lexer                        hiding (getSrcLoc)-import qualified Linker-import           LoadIface-import           MkIface-import           Module                       hiding (ModLocation (..), UnitId,-                                               addBootSuffixLocnOut,-                                               moduleUnitId)-import qualified Module-import           Name                         hiding (varName)-import           NameCache-import           NameEnv-import           NameSet-import           Packages-#if MIN_VERSION_ghc(8,8,0)-import           Panic                        hiding (try)-import qualified PlainPanic                   as Plain-#else-import           Panic                        hiding (GhcException, try)-import qualified Panic                        as Plain-#endif-import           Parser-import           PatSyn-#if MIN_VERSION_ghc(8,8,0)-import           Plugins-#endif-import           PprTyThing                   hiding (pprFamInst)-import           PrelInfo-import           PrelNames                    hiding (Unique, printName)-import           RdrName                      hiding (GRE, gre_name, gre_imp, gre_lcl, gre_par)-import qualified RdrName-import           RnNames-import           RnSplice-import qualified SrcLoc-import           TcEnv-import           TcEvidence                   hiding ((<.>))-import           TcIface-import           TcRnDriver-import           TcRnMonad                    hiding (Applicative (..), IORef,-                                               MonadFix (..), MonadIO (..),-                                               allM, anyM, concatMapM, foldrM,-                                               mapMaybeM, (<$>))-import           TcRnTypes-import           TcType                       hiding (mkVisFunTys)-import qualified TcType-import           TidyPgm-import qualified TyCoRep-import           TyCon-import           Type                         hiding (mkVisFunTys)-import           TysPrim-import           TysWiredIn-import           Unify-import           UniqFM-import           UniqSupply-import           Var                          (Var (varName), setTyVarUnique,-                                               setVarUnique, varType)+                                             )+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(8,10,0)-import           Coercion                     (coercionKind)-import           Predicate-import           SrcLoc                       (Located, SrcLoc (UnhelpfulLoc),-                                               SrcSpan (UnhelpfulSpan))-#else-import           SrcLoc                       (RealLocated,-                                               SrcLoc (UnhelpfulLoc),-                                               SrcSpan (UnhelpfulSpan))-#endif-#endif +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(8,8,0)-import           Data.List                    (isSuffixOf)-import           System.FilePath+#if MIN_VERSION_ghc(9,11,0)+import System.OsPath #endif +#if MIN_VERSION_ghc(9,13,0)+import qualified System.FilePath as FP+#endif -#if MIN_VERSION_ghc(9,2,0)-import           Language.Haskell.Syntax hiding (FunDep)+#if !MIN_VERSION_ghc(9,7,0)+import           GHC.Types.Avail             (greNamePrintableName) #endif -#if !MIN_VERSION_ghc(9,0,0)-type BufSpan = ()-type BufPos = ()+#if !MIN_VERSION_ghc(9,9,0)+import           GHC.Hs                      (SrcSpanAnn') #endif -pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan-#if MIN_VERSION_ghc(9,0,0)-pattern RealSrcSpan x y = SrcLoc.RealSrcSpan x y+mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO Module.ModLocation+#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-pattern RealSrcSpan x y <- ((,Nothing) -> (SrcLoc.RealSrcSpan x, y)) where-    RealSrcSpan x _ = SrcLoc.RealSrcSpan x+mkHomeModLocation df mn f = pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn f #endif++pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan++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)+ {-# COMPLETE RealSrcSpan, UnhelpfulSpan #-} -pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Maybe BufPos-> SrcLoc.SrcLoc-#if MIN_VERSION_ghc(9,0,0)+pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Strict.Maybe BufPos-> SrcLoc.SrcLoc pattern RealSrcLoc x y = SrcLoc.RealSrcLoc x y-#else-pattern RealSrcLoc x y <- ((,Nothing) -> (SrcLoc.RealSrcLoc x, y)) where-    RealSrcLoc x _ = SrcLoc.RealSrcLoc x-#endif {-# COMPLETE RealSrcLoc, UnhelpfulLoc #-}   pattern AvailTC :: Name -> [Name] -> [FieldLabel] -> Avail.AvailInfo-#if __GLASGOW_HASKELL__ >= 902+#if __GLASGOW_HASKELL__ >= 907+pattern AvailTC n names pieces <- Avail.AvailTC n ((,[]) -> (names,pieces))+#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))-#else-pattern AvailTC n names pieces <- Avail.AvailTC n names pieces #endif  pattern AvailName :: Name -> Avail.AvailInfo-#if __GLASGOW_HASKELL__ >= 902-pattern AvailName n <- Avail.Avail (Avail.NormalGreName n)-#else+#if __GLASGOW_HASKELL__ >= 907 pattern AvailName n <- Avail.Avail n+#else+pattern AvailName n <- Avail.Avail (Avail.NormalGreName n) #endif  pattern AvailFL :: FieldLabel -> Avail.AvailInfo-#if __GLASGOW_HASKELL__ >= 902-pattern AvailFL fl <- Avail.Avail (Avail.FieldGreName fl)+#if __GLASGOW_HASKELL__ >= 907+pattern AvailFL fl <- (const Nothing -> Just fl) -- this pattern always fails as this field was removed in 9.7 #else--- pattern synonym that is never populated-pattern AvailFL x <- Avail.Avail (const (True, undefined) -> (False, x))+pattern AvailFL fl <- Avail.Avail (Avail.FieldGreName fl) #endif  {-# COMPLETE AvailTC, AvailName, AvailFL #-}@@ -805,16 +632,11 @@ pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr #endif -pattern FunTy :: Type -> Type -> Type-#if MIN_VERSION_ghc(8,10,0)-pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res}-#else-pattern FunTy arg res <- TyCoRep.FunTy arg res-#endif--#if MIN_VERSION_ghc(9,0,0)--- 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@@ -825,262 +647,124 @@ instance HasSrcSpan (SrcLoc.GenLocated SrcSpan a) where   getLoc = GHC.getLoc -#if MIN_VERSION_ghc(9,2,0)+#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 = locA+  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 {-# COMPLETE L #-}-#endif -#elif MIN_VERSION_ghc(8,8,0)-type HasSrcSpan = SrcLoc.HasSrcSpan-getLoc :: SrcLoc.HasSrcSpan a => a -> SrcLoc.SrcSpan-getLoc = SrcLoc.getLoc--#else--class HasSrcSpan a where-    getLoc :: a -> SrcSpan-instance HasSrcSpan Name where-    getLoc = nameSrcSpan-instance HasSrcSpan (SrcLoc.GenLocated SrcSpan a) where-    getLoc = SrcLoc.getLoc--#endif--getRealSrcSpan :: SrcLoc.RealLocated a -> SrcLoc.RealSrcSpan-#if !MIN_VERSION_ghc(8,8,0)-getRealSrcSpan = SrcLoc.getLoc-#else-getRealSrcSpan = SrcLoc.getRealSrcSpan-#endif----- | Add the @-boot@ suffix to all output file paths associated with the--- module, not including the input file itself-addBootSuffixLocnOut :: GHC.ModLocation -> GHC.ModLocation-#if !MIN_VERSION_ghc(8,8,0)-addBootSuffixLocnOut locn-  = locn { Module.ml_hi_file  = Module.addBootSuffix (Module.ml_hi_file locn)-         , Module.ml_obj_file = Module.addBootSuffix (Module.ml_obj_file locn)-         }-#else-addBootSuffixLocnOut = Module.addBootSuffixLocnOut-#endif---dataConExTyCoVars :: DataCon -> [TyCoVar]-#if __GLASGOW_HASKELL__ >= 808-dataConExTyCoVars = DataCon.dataConExTyCoVars-#else-dataConExTyCoVars = DataCon.dataConExTyVars-#endif--#if !MIN_VERSION_ghc(9,0,0)--- Linear Haskell-type Scaled a = a-scaledThing :: Scaled a -> a-scaledThing = id--unrestricted :: a -> Scaled a-unrestricted = id-#endif--mkVisFunTys :: [Scaled Type] -> Type -> Type-mkVisFunTys =-#if __GLASGOW_HASKELL__ <= 808-  mkFunTys-#else-  TcType.mkVisFunTys-#endif--mkInfForAllTys :: [TyVar] -> Type -> Type-mkInfForAllTys =-#if MIN_VERSION_ghc(9,0,0)-  TcType.mkInfForAllTys-#else-  mkInvForAllTys-#endif--#if !MIN_VERSION_ghc(9,2,0)-splitForAllTyCoVars :: Type -> ([TyCoVar], Type)-splitForAllTyCoVars =-  splitForAllTys-#endif--tcSplitForAllTyVars :: Type -> ([TyVar], Type)-tcSplitForAllTyVars =-#if MIN_VERSION_ghc(9,2,0)-  TcType.tcSplitForAllTyVars-#else-  tcSplitForAllTys-#endif---tcSplitForAllTyVarBinder_maybe :: Type -> Maybe (TyVarBinder, Type)-tcSplitForAllTyVarBinder_maybe =-#if MIN_VERSION_ghc(9,2,0)-  TcType.tcSplitForAllTyVarBinder_maybe-#else-  tcSplitForAllTy_maybe-#endif--pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation-#if MIN_VERSION_ghc(8,8,0)-pattern ModLocation a b c <--    GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c ""-#else-pattern ModLocation a b c <--    GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c-#endif--#if !MIN_VERSION_ghc(8,10,0)-noExtField :: GHC.NoExt-noExtField = GHC.noExt-#endif--ml_hie_file :: GHC.ModLocation -> FilePath-#if !MIN_VERSION_ghc(8,8,0)-ml_hie_file ml-  | "boot" `isSuffixOf ` Module.ml_hi_file ml = Module.ml_hi_file ml -<.> ".hie-boot"-  | otherwise  = Module.ml_hi_file ml -<.> ".hie"-#else-ml_hie_file = Module.ml_hie_file-#endif--#if !MIN_VERSION_ghc(9,0,0)-pattern NotBoot, IsBoot :: IsBootInterface-pattern NotBoot = False-pattern IsBoot = True-#endif--#if MIN_VERSION_ghc(8,8,0)-type PlainGhcException = Plain.PlainGhcException-#else-type PlainGhcException = Plain.GhcException-#endif--#if MIN_VERSION_ghc(9,0,0) -- 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,2,0)+#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-#else-pattern ConPatIn con args = ConPat NoExtField con args #endif-#endif -initDynLinker, initObjLinker :: HscEnv -> IO ()-initDynLinker =-#if !MIN_VERSION_ghc(9,0,0)-    Linker.initDynLinker-#else-    -- It errors out in GHC 9.0 and doesn't exist in 9.2-    const $ return ()-#endif+conPatDetails :: Pat p -> Maybe (HsConPatDetails p)+conPatDetails (ConPat _ _ args) = Just args+conPatDetails _ = Nothing +mapConPatDetail :: (HsConPatDetails p -> Maybe (HsConPatDetails p)) -> Pat p -> Maybe (Pat p)+mapConPatDetail f pat@(ConPat _ _ args) = (\args' -> pat { pat_args = args'}) <$> f args+mapConPatDetail _ _ = Nothing+++initObjLinker :: HscEnv -> IO () initObjLinker env =-#if !MIN_VERSION_ghc(9,2,0)-    GHCi.initObjLinker env-#else     GHCi.initObjLinker (GHCi.hscInterp env)-#endif  loadDLL :: HscEnv -> String -> IO (Maybe String)-loadDLL env =-#if !MIN_VERSION_ghc(9,2,0)-    GHCi.loadDLL 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-    GHCi.loadDLL (GHCi.hscInterp env)+    pure res #endif  unload :: HscEnv -> [Linkable] -> IO () unload hsc_env linkables =   Linker.unload-#if MIN_VERSION_ghc(9,2,0)     (GHCi.hscInterp hsc_env)-#endif     hsc_env linkables -setOutputFile :: FilePath -> DynFlags -> DynFlags-setOutputFile f d = d {-#if MIN_VERSION_ghc(9,2,0)-  outputFile_    = Just f-#else-  outputFile     = Just f-#endif-  }  isSubspanOfA :: LocatedAn la a -> LocatedAn lb b -> Bool-#if MIN_VERSION_ghc(9,2,0) isSubspanOfA a b = SrcLoc.isSubspanOf (GHC.getLocA a) (GHC.getLocA b)-#else-isSubspanOfA a b = SrcLoc.isSubspanOf (GHC.getLoc a) (GHC.getLoc b)-#endif -#if MIN_VERSION_ghc(9,2,0) type LocatedAn a = GHC.LocatedAn a-#else-type LocatedAn a = GHC.Located-#endif -#if MIN_VERSION_ghc(9,2,0)-locA :: SrcSpanAnn' a -> SrcSpan-locA = GHC.locA-#else-locA = id-#endif+unLocA :: forall pass a. XRec (GhcPass pass) a -> a+unLocA = unXRec @(GhcPass pass) -#if MIN_VERSION_ghc(9,2,0)-getLocA :: SrcLoc.GenLocated (SrcSpanAnn' a) e -> SrcSpan-getLocA = GHC.getLocA-#else--- getLocA :: HasSrcSpan a => a -> SrcSpan-getLocA x = GHC.getLoc x-#endif -noLocA :: a -> LocatedAn an a-#if MIN_VERSION_ghc(9,2,0)-noLocA = GHC.noLocA-#else-noLocA = GHC.noLoc-#endif--#if !MIN_VERSION_ghc(9,2,0)-type AnnListItem = SrcLoc.SrcSpan-#endif--#if !MIN_VERSION_ghc(9,2,0)-type NameAnn = SrcLoc.SrcSpan-#endif- pattern GRE :: Name -> Parent -> Bool -> [ImportSpec] -> RdrName.GlobalRdrElt {-# COMPLETE GRE #-}-#if MIN_VERSION_ghc(9,2,0) pattern GRE{gre_name, gre_par, gre_lcl, gre_imp} <- RdrName.GRE-    {gre_name = (greNamePrintableName -> gre_name)-    ,gre_par, gre_lcl, gre_imp}+#if MIN_VERSION_ghc(9,7,0)+    {gre_name = gre_name #else-pattern GRE{gre_name, gre_par, gre_lcl, gre_imp} = RdrName.GRE{..}+    {gre_name = (greNamePrintableName -> gre_name) #endif+    ,gre_par, gre_lcl, gre_imp = (toList -> gre_imp)} -#if MIN_VERSION_ghc(9,2,0)-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-#endif -#if !MIN_VERSION_ghc(9,2,0)-pattern HsLet xlet localBinds expr <- GHC.HsLet xlet (SrcLoc.unLoc -> localBinds) expr-pattern LetStmt xlet localBinds <- GHC.LetStmt xlet (SrcLoc.unLoc -> localBinds)-#endif -#if !MIN_VERSION_ghc(9,2,0)-rationalFromFractionalLit :: FractionalLit -> Rational-rationalFromFractionalLit = fl_value++makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails+makeSimpleDetails hsc_env =+  GHC.makeSimpleDetails+              (hsc_logger hsc_env)++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+          (hsc_logger session)+++initTidyOpts :: HscEnv -> IO TidyOpts+initTidyOpts =+  GHC.initTidyOpts++driverNoStop :: StopPhase+driverNoStop = NoStop++groupOrigin :: MatchGroup GhcRn body -> Origin+mapLoc :: (a -> b) -> SrcLoc.GenLocated l a -> SrcLoc.GenLocated l b+mapLoc = fmap+groupOrigin = mg_ext++mkSimpleTarget :: DynFlags -> FilePath -> Target+mkSimpleTarget df fp = Target (TargetFile fp Nothing) True (homeUnitId_ df) Nothing++#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,36 +3,40 @@ -- | 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, hsc_HPT, hsc_type_env_var),+    Env.HscEnv(hsc_FC, hsc_NC, hsc_IC+              , hsc_type_env_vars+              ),+    Env.hsc_mod_graph,+    Env.hsc_HPT,     InteractiveContext(..),     setInteractivePrintName,     setInteractiveDynFlags,     Env.hsc_dflags,     hsc_EPS,-    hsc_logger,-    hsc_tmpfs,-    hsc_unit_env,-    hsc_hooks,+    Env.hsc_logger,+    Env.hsc_tmpfs,+    Env.hsc_unit_env,+    Env.hsc_hooks,     hscSetHooks,     TmpFs,     -- * HomeUnit     hscHomeUnit,     HomeUnit,     setHomeUnitId_,-    Development.IDE.GHC.Compat.Env.mkHomeModule,+    Home.mkHomeModule,     -- * Provide backwards Compatible     -- types and helper functions.-    Logger(..),+    Logger,     UnitEnv,     hscSetUnitEnv,     hscSetFlags,     initTempFs,     -- * Home Unit-    Development.IDE.GHC.Compat.Env.homeUnitId_,+    Session.homeUnitId_,     -- * DynFlags Helper     setBytecodeLinkerOptions,     setInterpreterLinkerOptions,-    Development.IDE.GHC.Compat.Env.safeImportsOn,+    Session.safeImportsOn,     -- * Ways     Ways,     Way,@@ -43,193 +47,73 @@     -- * Backend, backwards compatible     Backend,     setBackend,+    ghciBackend,     Development.IDE.GHC.Compat.Env.platformDefaultBackend,+    workingDirectory,+    setWorkingDirectory,+    hscSetActiveUnitId,+    reexportedModules,     ) where -import           GHC                  (setInteractiveDynFlags)+import           GHC                 (setInteractiveDynFlags) -#if MIN_VERSION_ghc(9,0,0)-#if MIN_VERSION_ghc(9,2,0)-import           GHC.Driver.Backend   as Backend-import           GHC.Driver.Env       (HscEnv, hsc_EPS)-import qualified GHC.Driver.Env       as Env-import qualified GHC.Driver.Session   as Session-import           GHC.Platform.Ways    hiding (hostFullWays)-import qualified GHC.Platform.Ways    as Ways+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+import qualified GHC.Driver.Session  as Session+import           GHC.Platform.Ways import           GHC.Runtime.Context-import           GHC.Unit.Env         (UnitEnv)-import           GHC.Unit.Home        as Home+import           GHC.Unit.Env        (UnitEnv)+import           GHC.Unit.Home       as Home+import           GHC.Unit.Types      (UnitId) import           GHC.Utils.Logger import           GHC.Utils.TmpFs-#else-import qualified GHC.Driver.Session   as DynFlags-import           GHC.Driver.Types     (HscEnv, InteractiveContext (..), hsc_EPS,-                                       setInteractivePrintName)-import qualified GHC.Driver.Types     as Env-import           GHC.Driver.Ways      hiding (hostFullWays)-import qualified GHC.Driver.Ways      as Ways-#endif-import           GHC.Driver.Hooks     (Hooks)-import           GHC.Driver.Session   hiding (mkHomeModule)-import           GHC.Unit.Module.Name-import           GHC.Unit.Types       (Module, Unit, UnitId, mkModule)-#else-import           DynFlags-import           Hooks-import           HscTypes             as Env-import           Module-#endif -#if MIN_VERSION_ghc(9,0,0)-#if !MIN_VERSION_ghc(9,2,0)-import qualified Data.Set             as Set-#endif-#endif-#if !MIN_VERSION_ghc(9,2,0)-import           Data.IORef-#endif -#if !MIN_VERSION_ghc(9,2,0)-type UnitEnv = ()-newtype Logger = Logger { log_action :: LogAction }-type TmpFs = ()-#endif+hsc_EPS :: HscEnv -> UnitEnv+hsc_EPS = Env.hsc_unit_env +setWorkingDirectory :: FilePath -> DynFlags -> DynFlags+setWorkingDirectory p d = d { workingDirectory =  Just p }+ setHomeUnitId_ :: UnitId -> DynFlags -> DynFlags-#if MIN_VERSION_ghc(9,2,0) setHomeUnitId_ uid df = df { Session.homeUnitId_ = uid }-#elif MIN_VERSION_ghc(9,0,0)-setHomeUnitId_ uid df = df { homeUnitId = uid }-#else-setHomeUnitId_ uid df = df { thisInstalledUnitId = toInstalledUnitId uid }-#endif  hscSetFlags :: DynFlags -> HscEnv -> HscEnv hscSetFlags df env = env { Env.hsc_dflags = df }  initTempFs :: HscEnv -> IO HscEnv initTempFs env = do-#if MIN_VERSION_ghc(9,2,0)   tmpFs <- initTmpFs   pure env { Env.hsc_tmpfs = tmpFs }-#else-  filesToClean <- newIORef emptyFilesToClean-  dirsToClean <- newIORef mempty-  let dflags = (Env.hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}-  pure $ hscSetFlags dflags env-#endif  hscSetUnitEnv :: UnitEnv -> HscEnv -> HscEnv-#if MIN_VERSION_ghc(9,2,0) hscSetUnitEnv ue env = env { Env.hsc_unit_env = ue }-#else-hscSetUnitEnv _ env  = env-#endif -hsc_unit_env :: HscEnv -> UnitEnv-hsc_unit_env =-#if MIN_VERSION_ghc(9,2,0)-  Env.hsc_unit_env-#else-  const ()-#endif--hsc_tmpfs :: HscEnv -> TmpFs-hsc_tmpfs =-#if MIN_VERSION_ghc(9,2,0)-  Env.hsc_tmpfs-#else-  const ()-#endif--hsc_logger :: HscEnv -> Logger-hsc_logger =-#if MIN_VERSION_ghc(9,2,0)-  Env.hsc_logger-#else-  Logger . DynFlags.log_action . Env.hsc_dflags-#endif--hsc_hooks :: HscEnv -> Hooks-hsc_hooks =-#if MIN_VERSION_ghc(9,2,0)-  Env.hsc_hooks-#else-  hooks . Env.hsc_dflags-#endif- hscSetHooks :: Hooks -> HscEnv -> HscEnv hscSetHooks hooks env =-#if MIN_VERSION_ghc(9,2,0)   env { Env.hsc_hooks = hooks }-#else-  hscSetFlags ((Env.hsc_dflags env) { hooks = hooks}) env-#endif -homeUnitId_ :: DynFlags -> UnitId-homeUnitId_ =-#if MIN_VERSION_ghc(9,2,0)-  Session.homeUnitId_-#elif MIN_VERSION_ghc(9,0,0)-  homeUnitId-#else-  thisPackage-#endif--safeImportsOn :: DynFlags -> Bool-safeImportsOn =-#if MIN_VERSION_ghc(9,2,0)-  Session.safeImportsOn-#else-  DynFlags.safeImportsOn-#endif--#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0)-type HomeUnit = Unit-#elif !MIN_VERSION_ghc(9,0,0)-type HomeUnit = UnitId-#endif- hscHomeUnit :: HscEnv -> HomeUnit hscHomeUnit =-#if MIN_VERSION_ghc(9,2,0)   Env.hsc_home_unit-#elif MIN_VERSION_ghc(9,0,0)-  homeUnit . Env.hsc_dflags-#else-  homeUnitId_ . hsc_dflags-#endif -mkHomeModule :: HomeUnit -> ModuleName -> Module-mkHomeModule =-#if MIN_VERSION_ghc(9,2,0)-  Home.mkHomeModule-#else-  mkModule-#endif- -- | We don't want to generate object code so we compile to bytecode -- (HscInterpreted) which implies LinkInMemory -- HscInterpreted setBytecodeLinkerOptions :: DynFlags -> DynFlags setBytecodeLinkerOptions df = df {     ghcLink   = LinkInMemory-#if MIN_VERSION_ghc(9,2,0)-  , backend = NoBackend-#else-  , hscTarget = HscNothing-#endif+  , backend = noBackend   , ghcMode = CompManager     }  setInterpreterLinkerOptions :: DynFlags -> DynFlags setInterpreterLinkerOptions df = df {     ghcLink   = LinkInMemory-#if MIN_VERSION_ghc(9,2,0)-  , backend = Interpreter-#else-  , hscTarget = HscInterpreted-#endif+   , backend = interpreterBackend   , ghcMode = CompManager     } @@ -237,53 +121,28 @@ -- Ways helpers -- ------------------------------------------------------- -#if !MIN_VERSION_ghc(9,2,0) && MIN_VERSION_ghc(9,0,0)-type Ways = Set.Set Way-#elif !MIN_VERSION_ghc(9,0,0)-type Ways = [Way]-#endif -hostFullWays :: Ways-hostFullWays =-#if MIN_VERSION_ghc(9,0,0)-  Ways.hostFullWays-#else-  interpWays-#endif- setWays :: Ways -> DynFlags -> DynFlags-setWays ways flags =-#if MIN_VERSION_ghc(9,2,0)-  flags { Session.targetWays_ = ways}-#elif MIN_VERSION_ghc(9,0,0)-  flags {ways = ways}-#else-  updateWays $ flags {ways = ways}-#endif+setWays newWays flags =+  flags { Session.targetWays_ = newWays}  -- ------------------------------------------------------- -- Backend helpers -- ------------------------------------------------------- -#if !MIN_VERSION_ghc(9,2,0)-type Backend = HscTarget++ghciBackend  :: Backend+#if MIN_VERSION_ghc(9,6,0)+ghciBackend = interpreterBackend+#else+ghciBackend = Interpreter #endif  platformDefaultBackend :: DynFlags -> Backend platformDefaultBackend =-#if MIN_VERSION_ghc(9,2,0)   Backend.platformDefaultBackend . targetPlatform-#elif MIN_VERSION_ghc(8,10,0)-  defaultObjectTarget-#else-  defaultObjectTarget . DynFlags.targetPlatform-#endif  setBackend :: Backend -> DynFlags -> DynFlags setBackend backend flags =-#if MIN_VERSION_ghc(9,2,0)   flags { backend = backend }-#else-  flags { hscTarget = backend }-#endif
+ 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/ExactPrint.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PatternSynonyms   #-}---- | This module contains compatibility constructs to write type signatures across---   multiple ghc-exactprint versions, accepting that anything more ambitious is---   pretty much impossible with the GHC 9.2 redesign of ghc-exactprint-module Development.IDE.GHC.Compat.ExactPrint-    ( ExactPrint-    , exactPrint-    , makeDeltaAst-    , Retrie.Annotated, pattern Annotated, astA, annsA-    ) where--#if !MIN_VERSION_ghc(9,2,0)-import           Control.Arrow                     ((&&&))-#else-import           Development.IDE.GHC.Compat.Parser-#endif-import           Language.Haskell.GHC.ExactPrint   as Retrie-import qualified Retrie.ExactPrint                 as Retrie--#if !MIN_VERSION_ghc(9,2,0)-class ExactPrint ast where-    makeDeltaAst :: ast -> ast-    makeDeltaAst = id--instance ExactPrint ast-#endif--#if !MIN_VERSION_ghc(9,2,0)-pattern Annotated :: ast -> Anns -> Retrie.Annotated ast-pattern Annotated {astA, annsA} <- (Retrie.astA &&& Retrie.annsA -> (astA, annsA))-#else-pattern Annotated :: ast -> ApiAnns -> Retrie.Annotated ast-pattern Annotated {astA, annsA} <- ((,()) . Retrie.astA -> (astA, annsA))-#endif
src/Development/IDE/GHC/Compat/Iface.hs view
@@ -6,36 +6,31 @@     cannotFindModule,     ) where +import           Development.IDE.GHC.Compat.Env+import           Development.IDE.GHC.Compat.Outputable import           GHC-#if MIN_VERSION_ghc(9,2,0)+import           GHC.Driver.Session                    (targetProfile) import qualified GHC.Iface.Load                        as Iface import           GHC.Unit.Finder.Types                 (FindResult)-#elif MIN_VERSION_ghc(9,0,0)-import qualified GHC.Driver.Finder                     as Finder-import           GHC.Driver.Types                      (FindResult)-import qualified GHC.Iface.Load                        as Iface-#else-import           Finder                                (FindResult)-import qualified Finder-import qualified MkIface-#endif -import           Development.IDE.GHC.Compat.Env-import           Development.IDE.GHC.Compat.Outputable+-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] +#if MIN_VERSION_ghc(9,7,0)+import           GHC.Iface.Errors.Ppr                  (missingInterfaceErrorDiagnostic)+import           GHC.Iface.Errors.Types                (IfaceMessage)+#endif+ writeIfaceFile :: HscEnv -> FilePath -> ModIface -> IO ()-#if MIN_VERSION_ghc(9,2,0)-writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (hsc_dflags env) fp iface-#elif MIN_VERSION_ghc(9,0,0)-writeIfaceFile env = Iface.writeIface (hsc_dflags env)+#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 = MkIface.writeIfaceFile (hsc_dflags env)+writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (targetProfile $ hsc_dflags env) fp iface #endif  cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc cannotFindModule env modname fr =-#if MIN_VERSION_ghc(9,2,0)-    Iface.cannotFindModule env modname fr+#if MIN_VERSION_ghc(9,7,0)+    missingInterfaceErrorDiagnostic (defaultDiagnosticOpts @IfaceMessage) $ Iface.cannotFindModule env modname fr #else-    Finder.cannotFindModule (hsc_dflags env) modname fr+    Iface.cannotFindModule env modname fr #endif
src/Development/IDE/GHC/Compat/Logger.hs view
@@ -2,7 +2,7 @@ -- | Compat module for GHC 9.2 Logger infrastructure. module Development.IDE.GHC.Compat.Logger (     putLogHook,-    Development.IDE.GHC.Compat.Logger.pushLogHook,+    Logger.pushLogHook,     -- * Logging stuff     LogActionCompat,     logActionCompat,@@ -13,44 +13,23 @@ import           Development.IDE.GHC.Compat.Env        as Env import           Development.IDE.GHC.Compat.Outputable -#if MIN_VERSION_ghc(9,0,0)-import           GHC.Driver.Session                    as DynFlags-import           GHC.Utils.Outputable-#if MIN_VERSION_ghc(9,2,0)-import           GHC.Driver.Env                        (hsc_logger)++import           GHC.Types.Error import           GHC.Utils.Logger                      as Logger-#endif-#else-import           DynFlags-import           Outputable                            (queryQual)-#endif+import           GHC.Utils.Outputable  putLogHook :: Logger -> HscEnv -> HscEnv putLogHook logger env =-#if MIN_VERSION_ghc(9,2,0)   env { hsc_logger = logger }-#else-  hscSetFlags ((hsc_dflags env) { DynFlags.log_action = Env.log_action logger }) env-#endif -pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger-pushLogHook f logger =-#if MIN_VERSION_ghc(9,2,0)-  Logger.pushLogHook f logger-#else-  logger { Env.log_action = f (Env.log_action logger) }-#endif--#if MIN_VERSION_ghc(9,0,0)-type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO ()+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-logActionCompat logAction dynFlags wr severity loc = logAction dynFlags wr severity loc alwaysQualify-+#if MIN_VERSION_ghc(9,7,0)+logActionCompat logAction logFlags (MCDiagnostic severity (ResolvedDiagnosticReason wr) _) loc = logAction logFlags (Just wr) (Just severity) loc alwaysQualify #else-type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO ()--logActionCompat :: LogActionCompat -> LogAction-logActionCompat logAction dynFlags wr severity loc style = logAction dynFlags wr severity loc (queryQual style)+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+
src/Development/IDE/GHC/Compat/Outputable.hs view
@@ -6,186 +6,136 @@     showSDoc,     showSDocUnsafe,     showSDocForUser,-    ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest,+    ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest, punctuate,     printSDocQualifiedUnsafe,     printWithoutUniques,-    mkPrintUnqualified,+    printWithoutUniquesOneLine,     mkPrintUnqualifiedDefault,-    PrintUnqualified(..),+    PrintUnqualified,     defaultUserStyle,     withPprStyle,     -- * Parser errors     PsWarning,     PsError,-    pprWarning,-    pprError,+    defaultDiagnosticOpts,+    GhcMessage,+    DriverMessage,+    Messages,+    initDiagOpts,+    pprMessages,+    DiagnosticReason(..),+    renderDiagnosticMessageWithHints,+    pprMsgEnvelopeBagWithLoc,+    Error.getMessages,+    renderWithContext,+    showSDocOneLine,+    defaultSDocContext,+    errMsgDiagnostic,+    unDecorated,+    diagnosticMessage,     -- * Error infrastructure     DecoratedSDoc,     MsgEnvelope,+    ErrMsg,+    WarnMsg,+    SourceError(..),     errMsgSpan,     errMsgSeverity,     formatErrorWithQual,     mkWarnMsg,     mkSrcErr,     srcErrorMessages,+    textDoc,     ) where --#if MIN_VERSION_ghc(9,2,0)+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-import qualified GHC.Parser.Errors.Ppr           as Ppr-import qualified GHC.Types.Error                 as Error+import           GHC.Parser.Errors.Types+import qualified GHC.Types.Error              as Error 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.Outputable            as Out hiding (defaultUserStyle)-import qualified GHC.Utils.Outputable            as Out+import           GHC.Utils.Error+import           GHC.Utils.Outputable         as Out import           GHC.Utils.Panic-#elif MIN_VERSION_ghc(9,0,0)-import           GHC.Driver.Session-import           GHC.Driver.Types                as HscTypes-import           GHC.Types.Name.Reader           (GlobalRdrEnv)-import           GHC.Types.SrcLoc-import           GHC.Utils.Error                 as Err hiding (mkWarnMsg)-import qualified GHC.Utils.Error                 as Err-import           GHC.Utils.Outputable            as Out hiding (defaultUserStyle)-import qualified GHC.Utils.Outputable            as Out-#else-import           Development.IDE.GHC.Compat.Core (GlobalRdrEnv)-import           DynFlags-import           ErrUtils                        hiding (mkWarnMsg)-import qualified ErrUtils                        as Err-import           HscTypes-import           Outputable                      as Out hiding (defaultUserStyle)-import qualified Outputable                      as Out-import           SrcLoc++-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if MIN_VERSION_ghc(9,7,0)+import           GHC.Types.Error              (defaultDiagnosticOpts) #endif +type PrintUnqualified = NamePprCtx+ -- | 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 =-#if MIN_VERSION_ghc(9,2,0)-  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     , sdocCanUseUnicode = True     }) . ppr-#else-  go . ppr-    where-      go sdoc = oldRenderWithStyle dflags sdoc (oldMkUserStyle dflags neverQualify AllTheWay)-      dflags = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques-#endif  printSDocQualifiedUnsafe :: PrintUnqualified -> SDoc -> String-#if MIN_VERSION_ghc(9,2,0) printSDocQualifiedUnsafe unqual doc =   -- Taken from 'showSDocForUser'   renderWithContext (defaultSDocContext { sdocStyle = sty }) doc'   where     sty  = mkUserStyle unqual AllTheWay     doc' = pprWithUnitState emptyUnitState doc-#else-printSDocQualifiedUnsafe unqual doc =-    showSDocForUser unsafeGlobalDynFlags unqual doc-#endif -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0)-oldRenderWithStyle dflags sdoc sty = Out.renderWithStyle (initSDocContext dflags sty) sdoc-oldMkUserStyle _ = Out.mkUserStyle-oldMkErrStyle _ = Out.mkErrStyle -oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc-oldFormatErrDoc dflags = Err.formatErrDoc dummySDocContext-  where dummySDocContext = initSDocContext dflags Out.defaultUserStyle-#elif !MIN_VERSION_ghc(9,0,0)-oldRenderWithStyle :: DynFlags -> Out.SDoc -> Out.PprStyle -> String-oldRenderWithStyle = Out.renderWithStyle -oldMkUserStyle :: DynFlags -> Out.PrintUnqualified -> Out.Depth -> Out.PprStyle-oldMkUserStyle = Out.mkUserStyle--oldMkErrStyle :: DynFlags -> Out.PrintUnqualified -> Out.PprStyle-oldMkErrStyle = Out.mkErrStyle--oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc-oldFormatErrDoc = Err.formatErrDoc-#endif--pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc-pprWarning =-#if MIN_VERSION_ghc(9,2,0)-  Ppr.pprWarning-#else-  id-#endif--pprError :: PsError -> MsgEnvelope DecoratedSDoc-pprError =-#if MIN_VERSION_ghc(9,2,0)-  Ppr.pprError-#else-  id-#endif- formatErrorWithQual :: DynFlags -> MsgEnvelope DecoratedSDoc -> String formatErrorWithQual dflags e =-#if MIN_VERSION_ghc(9,2,0)   showSDoc dflags (pprNoLocMsgEnvelope e) -pprNoLocMsgEnvelope :: Error.RenderableDiagnostic e => MsgEnvelope e -> SDoc+pprNoLocMsgEnvelope :: MsgEnvelope DecoratedSDoc -> SDoc pprNoLocMsgEnvelope (MsgEnvelope { errMsgDiagnostic = e                                  , errMsgContext   = unqual })-  = sdocWithContext $ \ctx ->+  = sdocWithContext $ \_ctx ->     withErrStyle unqual $-      (formatBulleted ctx $ Error.renderDiagnostic e)-+#if MIN_VERSION_ghc(9,7,0)+      formatBulleted e #else-  Out.showSDoc dflags-  $ Out.withPprStyle (oldMkErrStyle dflags $ errMsgContext e)-  $ oldFormatErrDoc dflags-  $ Err.errMsgDoc e+      formatBulleted _ctx e #endif -#if !MIN_VERSION_ghc(9,2,0)-type DecoratedSDoc = ()-type MsgEnvelope e = ErrMsg -type PsWarning = ErrMsg-type PsError = ErrMsg-#endif +type ErrMsg  = MsgEnvelope GhcMessage+type WarnMsg  = MsgEnvelope GhcMessage+ mkPrintUnqualifiedDefault :: HscEnv -> GlobalRdrEnv -> PrintUnqualified mkPrintUnqualifiedDefault env =-#if MIN_VERSION_ghc(9,2,0)-  -- GHC 9.2 version-  -- mkPrintUnqualified :: UnitEnv -> GlobalRdrEnv -> PrintUnqualified-  mkPrintUnqualified (hsc_unit_env env)-#else-  HscTypes.mkPrintUnqualified (hsc_dflags env)-#endif+  mkNamePprCtx ptc (hsc_unit_env env)+    where+      ptc = initPromotionTickContext (hsc_dflags env) -mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc-mkWarnMsg =-#if MIN_VERSION_ghc(9,2,0)-  const Error.mkWarnMsg-#else-  Err.mkWarnMsg-#endif+renderDiagnosticMessageWithHints :: forall a. Diagnostic a => a -> DecoratedSDoc+renderDiagnosticMessageWithHints a = Error.unionDecoratedSDoc+  (diagnosticMessage+    (defaultDiagnosticOpts @a)+    a) (mkDecorated $ map ppr $ diagnosticHints a) -defaultUserStyle :: PprStyle-#if MIN_VERSION_ghc(9,0,0)-defaultUserStyle = Out.defaultUserStyle-#else-defaultUserStyle = Out.defaultUserStyle unsafeGlobalDynFlags-#endif+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)++textDoc :: String -> SDoc+textDoc = text
src/Development/IDE/GHC/Compat/Parser.hs view
@@ -1,172 +1,77 @@ {-# LANGUAGE CPP             #-} {-# LANGUAGE PatternSynonyms #-}-{-# HLINT ignore "Unused LANGUAGE pragma" #-} --- | Parser compaibility module.+-- | Parser compatibility module. module Development.IDE.GHC.Compat.Parser (     initParserOpts,     initParserState,-#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0)-    -- in GHC == 9.2 the type doesn't exist-    -- In GHC == 9.0 it is a data-type-    -- and GHC < 9.0 it is type-def-    ---    -- Export data-type here, otherwise only the simple type.-    Anno.ApiAnns(..),-#else-    ApiAnns,-#endif-#if MIN_VERSION_ghc(9,0,0)     PsSpan(..),-#endif-#if MIN_VERSION_ghc(9,2,0)     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,-#else-    GHC.HsParsedModule(..),-    GHC.ParsedModule(..),-#endif-    mkApiAnns,     -- * API Annotations+#if !MIN_VERSION_ghc(9,11,0)     Anno.AnnKeywordId(..),-#if !MIN_VERSION_ghc(9,2,0)-    Anno.AnnotationComment(..), #endif     pattern EpaLineComment,     pattern EpaBlockComment     ) where -#if MIN_VERSION_ghc(9,0,0)-#if !MIN_VERSION_ghc(9,2,0)-import qualified GHC.Driver.Types                as GHC-#endif+import           Development.IDE.GHC.Compat.Core+import           Development.IDE.GHC.Compat.Util import qualified GHC.Parser.Annotation           as Anno import qualified GHC.Parser.Lexer                as Lexer import           GHC.Types.SrcLoc                (PsSpan (..))-#if MIN_VERSION_ghc(9,2,0)-import           GHC                             (Anchor (anchor),-                                                  EpAnnComments (priorComments),-                                                  EpaComment (EpaComment),-                                                  EpaCommentTok (..),-                                                  epAnnComments,++++import           GHC                             (EpaCommentTok (..),                                                   pm_extra_src_files,                                                   pm_mod_summary,                                                   pm_parsed_source) import qualified GHC-import qualified GHC.Driver.Config               as Config-import           GHC.Hs                          (LEpaComment, hpm_module,-                                                  hpm_src_files)-import           GHC.Parser.Lexer                hiding (initParserState)-#endif-#else-import qualified ApiAnnotation                   as Anno-import qualified HscTypes                        as GHC-import           Lexer-import qualified SrcLoc-#endif-import           Development.IDE.GHC.Compat.Core-import           Development.IDE.GHC.Compat.Util+import qualified GHC.Driver.Config.Parser        as Config+import           GHC.Hs                          (hpm_module, hpm_src_files) -#if !MIN_VERSION_ghc(9,2,0)-import qualified Data.Map                        as Map-import qualified GHC-#endif -#if !MIN_VERSION_ghc(9,0,0)-type ParserOpts = DynFlags-#elif !MIN_VERSION_ghc(9,2,0)-type ParserOpts = Lexer.ParserFlags-#endif  initParserOpts :: DynFlags -> ParserOpts initParserOpts =-#if MIN_VERSION_ghc(9,2,0)   Config.initParserOpts-#elif MIN_VERSION_ghc(9,0,0)-  Lexer.mkParserFlags-#else-  id-#endif  initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState initParserState =-#if MIN_VERSION_ghc(9,2,0)   Lexer.initParserState-#elif MIN_VERSION_ghc(9,0,0)-  Lexer.mkPStatePure-#else-  Lexer.mkPState-#endif -#if MIN_VERSION_ghc(9,2,0)--- GHC 9.2 does not have ApiAnns anymore packaged in ParsedModule. Now the--- annotations are found in the ast.-type ApiAnns = ()-#else-type ApiAnns = Anno.ApiAnns-#endif--#if MIN_VERSION_ghc(9,2,0)-pattern HsParsedModule :: Located HsModule -> [FilePath] -> ApiAnns -> GHC.HsParsedModule+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-#endif  -#if MIN_VERSION_ghc(9,2,0)-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              , pm_extra_src_files = extra_src_files              } {-# COMPLETE ParsedModule :: GHC.ParsedModule #-}-#endif -mkApiAnns :: PState -> ApiAnns-#if MIN_VERSION_ghc(9,2,0)-mkApiAnns = const ()-#else-mkApiAnns pst =-#if MIN_VERSION_ghc(9,0,1)-    -- Copied from GHC.Driver.Main-    Anno.ApiAnns {-            apiAnnItems = Map.fromListWith (++) $ annotations pst,-            apiAnnEofPos = eof_pos pst,-            apiAnnComments = Map.fromList (annotations_comments pst),-            apiAnnRogueComments = comment_q pst-        }-#else-    (Map.fromListWith (++) $ annotations pst,-     Map.fromList ((SrcLoc.noSrcSpan,comment_q pst)-                  :annotations_comments pst))-#endif-#endif -#if !MIN_VERSION_ghc(9,2,0)-pattern EpaLineComment a = Anno.AnnLineComment a-pattern EpaBlockComment a = Anno.AnnBlockComment a-#endif
src/Development/IDE/GHC/Compat/Plugins.hs view
@@ -2,71 +2,48 @@  -- | Plugin Compat utils. module Development.IDE.GHC.Compat.Plugins (+    -- * Plugin Compat Types, and initialisation     Plugin(..),     defaultPlugin,-#if __GLASGOW_HASKELL__ >= 808     PluginWithArgs(..),-#endif     applyPluginsParsedResultAction,-    initializePlugins,      -- * Static plugins-#if MIN_VERSION_ghc(8,8,0)     StaticPlugin(..),     hsc_static_plugins,-#endif++    -- * Plugin messages+    PsMessages(..),+    getPsMessages     ) where -#if MIN_VERSION_ghc(9,0,0)-#if MIN_VERSION_ghc(9,2,0)+import           Development.IDE.GHC.Compat.Core+import           Development.IDE.GHC.Compat.Parser as Parser+ import qualified GHC.Driver.Env                    as Env-#endif-import           GHC.Driver.Plugins                (Plugin (..),+import           GHC.Driver.Plugins                (ParsedResult (..),+                                                    Plugin (..),                                                     PluginWithArgs (..),+                                                    PsMessages (..),                                                     StaticPlugin (..),-                                                    defaultPlugin, withPlugins)-import qualified GHC.Runtime.Loader                as Loader-#elif MIN_VERSION_ghc(8,8,0)-import qualified DynamicLoading                    as Loader-import           Plugins-#else-import qualified DynamicLoading                    as Loader-import           Plugins                           (Plugin (..), defaultPlugin,-                                                    withPlugins)-#endif-import           Development.IDE.GHC.Compat.Core-import           Development.IDE.GHC.Compat.Env    (hscSetFlags, hsc_dflags)-import           Development.IDE.GHC.Compat.Parser as Parser+                                                    defaultPlugin,+                                                    staticPlugins, withPlugins)+import qualified GHC.Parser.Lexer                  as Lexer -applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> Parser.ApiAnns -> ParsedSource -> IO ParsedSource-applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do++getPsMessages :: PState -> PsMessages+getPsMessages pst =+  uncurry PsMessages $ Lexer.getPsMessages pst++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-  fmap hpm_module $-    runHsc env $ withPlugins-#if MIN_VERSION_ghc(9,2,0)-      env-#else-      dflags-#endif+  fmap (\result -> (hpm_module (parsedResultModule result), parsedResultMessages result)) $ runHsc env $ withPlugins+      (Env.hsc_plugins env)       applyPluginAction-      (HsParsedModule parsed [] hpm_annotations)--initializePlugins :: HscEnv -> IO HscEnv-initializePlugins env = do-#if MIN_VERSION_ghc(9,2,0)-    Loader.initializePlugins env-#else-    newDf <- Loader.initializePlugins env (hsc_dflags env)-    pure $ hscSetFlags newDf env-#endif+      (ParsedResult (HsParsedModule parsed []) msgs)  -#if MIN_VERSION_ghc(8,8,0) hsc_static_plugins :: HscEnv -> [StaticPlugin]-#if MIN_VERSION_ghc(9,2,0)-hsc_static_plugins = Env.hsc_static_plugins-#else-hsc_static_plugins = staticPlugins . hsc_dflags-#endif-#endif+hsc_static_plugins = staticPlugins . Env.hsc_plugins
src/Development/IDE/GHC/Compat/Units.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE CPP             #-}-{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE CPP #-}  -- | Compat module for 'UnitState' and 'UnitInfo'. module Development.IDE.GHC.Compat.Units (@@ -23,7 +22,7 @@     unitExposedModules,     unitDepends,     unitHaddockInterfaces,-    unitInfoId,+    mkUnit,     unitPackageNameString,     unitPackageVersion,     -- * UnitId helpers@@ -31,9 +30,6 @@     Unit,     unitString,     stringToUnit,-#if !MIN_VERSION_ghc(9,0,0)-    pattern RealUnit,-#endif     definiteUnitId,     defUnitId,     installedModule,@@ -47,228 +43,135 @@     filterInplaceUnits,     FinderCache,     showSDocForUser',+    findImportedModule,     ) where -#if MIN_VERSION_ghc(9,0,0)-#if MIN_VERSION_ghc(9,2,0)-import qualified GHC.Data.ShortText              as ST-import           GHC.Driver.Env                  (hsc_unit_dbs)-import           GHC.Driver.Ppr-import           GHC.Unit.Env-import           GHC.Unit.External-import           GHC.Unit.Finder-#else-import           GHC.Driver.Types-#endif-import           GHC.Data.FastString-import qualified GHC.Driver.Session              as DynFlags-import           GHC.Types.Unique.Set-import qualified GHC.Unit.Info                   as UnitInfo-import           GHC.Unit.State                  (LookupResult, UnitInfo,-                                                  UnitState (unitInfoMap))-import qualified GHC.Unit.State                  as State-import           GHC.Unit.Types                  hiding (moduleUnit, toUnitId)-import qualified GHC.Unit.Types                  as Unit-import           GHC.Utils.Outputable-#else-import qualified DynFlags-import           FastString-import           GhcPlugins                      (SDoc, showSDocForUser)-import           HscTypes-import           Module                          hiding (moduleUnitId)-import qualified Module-import           Packages                        (InstalledPackageInfo (haddockInterfaces, packageName),-                                                  LookupResult, PackageConfig,-                                                  PackageConfigMap,-                                                  PackageState,-                                                  getPackageConfigMap,-                                                  lookupPackage')-import qualified Packages-#endif-+import           Data.Either import           Development.IDE.GHC.Compat.Core import           Development.IDE.GHC.Compat.Env-#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0)-import           Data.Map                        (Map)-#endif-import           Data.Either-import           Data.Version+import           Development.IDE.GHC.Compat.Outputable+import           Prelude                               hiding (mod)++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,+                                                        UnitState (unitInfoMap),+                                                        lookupUnit', mkUnit,+                                                        unitDepends,+                                                        unitExposedModules,+                                                        unitPackageNameString,+                                                        unitPackageVersion)+import qualified GHC.Unit.State                        as State+import           GHC.Unit.Types -#if MIN_VERSION_ghc(9,0,0)-type PreloadUnitClosure = UniqSet UnitId-#if MIN_VERSION_ghc(9,2,0)-type UnitInfoMap = State.UnitInfoMap-#else-type UnitInfoMap = Map UnitId UnitInfo-#endif-#else-type UnitState = PackageState-type UnitInfo = PackageConfig-type UnitInfoMap = PackageConfigMap-type PreloadUnitClosure = ()-type Unit = UnitId+#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  -#if !MIN_VERSION_ghc(9,0,0)-unitString :: Unit -> String-unitString = Module.unitIdString--stringToUnit :: String -> Unit-stringToUnit = Module.stringToUnitId-#endif+type PreloadUnitClosure = UniqSet UnitId  unitState :: HscEnv -> UnitState-#if MIN_VERSION_ghc(9,2,0) unitState = ue_units . hsc_unit_env-#elif MIN_VERSION_ghc(9,0,0)-unitState = DynFlags.unitState . hsc_dflags++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-unitState = DynFlags.pkgState . hsc_dflags+  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 :: HscEnv -> IO HscEnv-initUnits env = do-#if MIN_VERSION_ghc(9,2,0)-  let dflags1         = hsc_dflags env-  -- Copied from GHC.setSessionDynFlags-  let cached_unit_dbs = hsc_unit_dbs env-  (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags1 cached_unit_dbs+initUnits :: [DynFlags] -> HscEnv -> IO HscEnv+initUnits unitDflags env = do+  let dflags0         = hsc_dflags env+  -- additionally, set checked dflags so we don't lose fixes+  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+        old_hpt = homeUnitEnv_hpt homeUnitEnv -  dflags <- DynFlags.updatePlatformConstants dflags1 mconstants+    (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags cached_unit_dbs home_units +    updated_dflags <- DynFlags.updatePlatformConstants dflags mconstants+    pure HomeUnitEnv+      { homeUnitEnv_units = unit_state+      , homeUnitEnv_unit_dbs = Just dbs+      , homeUnitEnv_dflags = updated_dflags+      , homeUnitEnv_hpt = old_hpt+      , homeUnitEnv_home_unit = Just home_unit+      } +  let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup (homeUnitId_ dflags0) home_unit_graph   let unit_env = UnitEnv-        { ue_platform  = targetPlatform dflags-        , ue_namever   = DynFlags.ghcNameVersion dflags-        , ue_home_unit = home_unit-        , ue_units     = unit_state-        }-  pure $ hscSetFlags dflags $ hscSetUnitEnv unit_env env-    { hsc_unit_dbs = Just dbs-    }-#elif MIN_VERSION_ghc(9,0,0)-  newFlags <- State.initUnits $ hsc_dflags env-  pure $ hscSetFlags newFlags env-#else-  newFlags <- fmap fst . Packages.initPackages $ hsc_dflags env-  pure $ hscSetFlags newFlags env+        { ue_platform        = targetPlatform dflags1+        , ue_namever         = GHC.ghcNameVersion dflags1+        , 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 + explicitUnits :: UnitState -> [Unit] explicitUnits ue =-#if MIN_VERSION_ghc(9,0,0)-  State.explicitUnits ue-#else-  Packages.explicitPackages ue-#endif+  map fst $ State.explicitUnits ue  listVisibleModuleNames :: HscEnv -> [ModuleName] listVisibleModuleNames env =-#if MIN_VERSION_ghc(9,0,0)   State.listVisibleModuleNames $ unitState env-#else-  Packages.listVisibleModuleNames $ hsc_dflags env-#endif  getUnitName :: HscEnv -> UnitId -> Maybe PackageName getUnitName env i =-#if MIN_VERSION_ghc(9,0,0)   State.unitPackageName <$> State.lookupUnitId (unitState env) i-#else-  packageName <$> Packages.lookupPackage (hsc_dflags env) (definiteUnitId (defUnitId i))-#endif -lookupModuleWithSuggestions :: HscEnv -> ModuleName -> Maybe FastString -> LookupResult+lookupModuleWithSuggestions+  :: HscEnv+  -> ModuleName+  -> GHC.PkgQual+  -> LookupResult lookupModuleWithSuggestions env modname mpkg =-#if MIN_VERSION_ghc(9,0,0)   State.lookupModuleWithSuggestions (unitState env) modname mpkg-#else-  Packages.lookupModuleWithSuggestions (hsc_dflags env) modname mpkg-#endif  getUnitInfoMap :: HscEnv -> UnitInfoMap getUnitInfoMap =-#if MIN_VERSION_ghc(9,2,0)   unitInfoMap . ue_units . hsc_unit_env-#elif MIN_VERSION_ghc(9,0,0)-  unitInfoMap . unitState-#else-  Packages.getPackageConfigMap . hsc_dflags-#endif  lookupUnit :: HscEnv -> Unit -> Maybe UnitInfo-#if MIN_VERSION_ghc(9,0,0) lookupUnit env pid = State.lookupUnit (unitState env) pid-#else-lookupUnit env pid = Packages.lookupPackage (hsc_dflags env) pid-#endif -lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo-#if MIN_VERSION_ghc(9,0,0)-lookupUnit' = State.lookupUnit'-#else-lookupUnit' b pcm _ u = Packages.lookupPackage' b pcm u-#endif- preloadClosureUs :: HscEnv -> PreloadUnitClosure-#if MIN_VERSION_ghc(9,2,0) preloadClosureUs = State.preloadClosure . unitState-#elif MIN_VERSION_ghc(9,0,0)-preloadClosureUs = State.preloadClosure . unitState-#else-preloadClosureUs = const ()-#endif -unitExposedModules :: UnitInfo -> [(ModuleName, Maybe Module)]-unitExposedModules ue =-#if MIN_VERSION_ghc(9,0,0)-  UnitInfo.unitExposedModules ue-#else-  Packages.exposedModules ue-#endif--unitDepends :: UnitInfo -> [UnitId]-#if MIN_VERSION_ghc(9,0,0)-unitDepends = State.unitDepends-#else-unitDepends = fmap (Module.DefiniteUnitId. defUnitId') . Packages.depends-#endif--unitPackageNameString :: UnitInfo -> String-unitPackageNameString =-#if MIN_VERSION_ghc(9,0,0)-  UnitInfo.unitPackageNameString-#else-  Packages.packageNameString-#endif--unitPackageVersion :: UnitInfo -> Version-unitPackageVersion =-#if MIN_VERSION_ghc(9,0,0)-  UnitInfo.unitPackageVersion-#else-  Packages.packageVersion-#endif--unitInfoId :: UnitInfo -> Unit-unitInfoId =-#if MIN_VERSION_ghc(9,0,0)-  UnitInfo.mkUnit-#else-  Packages.packageConfigId-#endif- unitHaddockInterfaces :: UnitInfo -> [FilePath] unitHaddockInterfaces =-#if MIN_VERSION_ghc(9,2,0)   fmap ST.unpack . UnitInfo.unitHaddockInterfaces-#elif MIN_VERSION_ghc(9,0,0)-  UnitInfo.unitHaddockInterfaces-#else-  haddockInterfaces-#endif  -- ------------------------------------------------------------------ -- Backwards Compatible UnitState@@ -278,7 +181,6 @@ -- Patterns and helpful definitions -- ------------------------------------------------------------------ -#if MIN_VERSION_ghc(9,2,0) definiteUnitId :: Definite uid -> GenUnit uid definiteUnitId         = RealUnit defUnitId :: unit -> Definite unit@@ -286,72 +188,24 @@ installedModule :: unit -> ModuleName -> GenModule unit installedModule        = Module -#elif MIN_VERSION_ghc(9,0,0)-definiteUnitId         = RealUnit-defUnitId              = Definite-installedModule        = Module -#else-pattern RealUnit :: Module.DefUnitId -> UnitId-pattern RealUnit x = Module.DefiniteUnitId x--definiteUnitId :: Module.DefUnitId -> UnitId-definiteUnitId = Module.DefiniteUnitId--defUnitId :: UnitId -> Module.DefUnitId-defUnitId = Module.DefUnitId . Module.toInstalledUnitId--defUnitId' :: Module.InstalledUnitId -> Module.DefUnitId-defUnitId' = Module.DefUnitId--installedModule :: UnitId -> ModuleName -> Module.InstalledModule-installedModule uid modname = Module.InstalledModule (Module.toInstalledUnitId uid) modname-#endif--toUnitId :: Unit -> UnitId-toUnitId =-#if MIN_VERSION_ghc(9,0,0)-    Unit.toUnitId-#else-    id-#endif--moduleUnitId :: Module -> UnitId-moduleUnitId =-#if MIN_VERSION_ghc(9,0,0)-    Unit.toUnitId . Unit.moduleUnit-#else-    Module.moduleUnitId-#endif--moduleUnit :: Module -> Unit-moduleUnit =-#if MIN_VERSION_ghc(9,0,0)-    Unit.moduleUnit-#else-    Module.moduleUnitId-#endif- filterInplaceUnits :: [UnitId] -> [PackageFlag] -> ([UnitId], [PackageFlag]) filterInplaceUnits us packageFlags =   partitionEithers (map isInplace packageFlags)   where     isInplace :: PackageFlag -> Either UnitId PackageFlag     isInplace p@(ExposePackage _ (UnitIdArg u) _) =-#if MIN_VERSION_ghc(9,0,0)       if toUnitId u `elem` us         then Left $ toUnitId  u         else Right p-#else-      if u `elem` us-        then Left u-        else Right p-#endif     isInplace p = Right p -showSDocForUser' :: HscEnv -> GHC.PrintUnqualified -> SDoc -> String-#if MIN_VERSION_ghc(9,2,0)+showSDocForUser' :: HscEnv -> PrintUnqualified -> SDoc -> String showSDocForUser' env = showSDocForUser (hsc_dflags env) (unitState env)-#else-showSDocForUser' env = showSDocForUser (hsc_dflags env)-#endif++findImportedModule :: HscEnv -> ModuleName -> IO (Maybe Module)+findImportedModule env mn = do+    res <- GHC.findImportedModule env mn NoPkgQual+    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@@ -28,19 +27,16 @@     -- * Maybes     MaybeErr(..),     orElse,-#if MIN_VERSION_ghc(8,10,0)     -- * Pair     Pair(..),-#endif     -- * EnumSet     EnumSet,+    member,     toList,     -- * FastString exports     FastString,-#if MIN_VERSION_ghc(9,2,0)     -- Export here, so we can coerce safely on consumer sites     LexicalFastString(..),-#endif     uniq,     unpackFS,     mkFastString,@@ -69,54 +65,19 @@     stringToStringBuffer,     nextChar,     atEnd,-    -- * Char-    is_ident     ) where -#if MIN_VERSION_ghc(9,0,0) 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 import           GHC.Data.StringBuffer-import           GHC.Parser.CharClass    (is_ident) import           GHC.Types.Unique import           GHC.Types.Unique.DFM import           GHC.Utils.Fingerprint-import           GHC.Utils.Misc import           GHC.Utils.Outputable    (pprHsString) import           GHC.Utils.Panic         hiding (try)-#else-import           Bag-import           BooleanFormula-import           Ctype                   (is_ident)-import           EnumSet-import qualified Exception-import           FastString-import           Fingerprint-import           Maybes-#if MIN_VERSION_ghc(8,10,0)-import           Pair-#endif-import           Outputable              (pprHsString)-import           Panic                   hiding (try)-import           StringBuffer-import           UniqDFM-import           Unique-import           Util-#endif--#if !MIN_VERSION_ghc(9,0,0)-type MonadCatch = Exception.ExceptionMonad---- We are using Safe here, which is not equivalent, but probably what we want.-catch :: (Exception.ExceptionMonad m, Exception e) => m a -> (e -> m a) -> m a-catch = Exception.gcatch--try :: (Exception.ExceptionMonad m, Exception e) => m a -> m (Either e a)-try = Exception.gtry-#endif
+ src/Development/IDE/GHC/CoreFile.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE RecordWildCards #-}++-- | CoreFiles let us serialize Core to a file in order to later recover it+-- without reparsing or retypechecking+module Development.IDE.GHC.CoreFile+  ( CoreFile(..)+  , codeGutsToCoreFile+  , typecheckCoreFile+  , readBinCoreFile+  , writeBinCoreFile+  , getImplicitBinds+  ) where++import           Control.Monad+import           Data.IORef+import           Data.Maybe+import           Development.IDE.GHC.Compat+import qualified Development.IDE.GHC.Compat.Util as Util+import           GHC.Core+import           GHC.CoreToIface+import           GHC.Fingerprint+import           GHC.Iface.Binary+#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.Types.TypeEnv+import           GHC.Utils.Binary+import           Prelude                         hiding (mod)+++-- | Initial ram buffer to allocate for writing interface files+initBinMemSize :: Int+initBinMemSize = 1024 * 1024++data CoreFile+  = CoreFile+  { cf_bindings   :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]+  -- ^ The actual core file bindings, deserialized lazily+  , cf_iface_hash :: !Fingerprint+  }++instance Binary CoreFile where+  put_ bh (CoreFile core fp) = lazyPut bh core >> put_ bh fp+  get bh = CoreFile <$> lazyGet bh <*> get bh++readBinCoreFile+  :: NameCacheUpdater+  -> FilePath+  -> IO (CoreFile, Fingerprint)+readBinCoreFile name_cache fat_hi_path = do+    bh <- readBinMem fat_hi_path+    file <- getWithUserData name_cache bh+    !fp <- Util.getFileHash fat_hi_path+    return (file, fp)++-- | Write a core file+writeBinCoreFile :: DynFlags -> FilePath -> CoreFile -> IO Fingerprint+writeBinCoreFile _dflags core_path fat_iface = do+    bh <- openBinMem initBinMemSize++    let quietTrace =+          QuietBinIFace++    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++    !fp <- fingerprintBinMem bh+    pure fp++-- Implicit binds aren't tidied, so we can't serialise them.+-- This isn't a problem however since we can regenerate them from the+-- original ModIface+codeGutsToCoreFile+  :: Fingerprint -- ^ Hash of the interface this was generated from+  -> CgGuts+  -> CoreFile+-- In GHC 9.6, implicit binds are tidied and part of core binds+codeGutsToCoreFile hash CgGuts{..} = CoreFile (map toIfaceTopBind cg_binds) hash++getImplicitBinds :: TyCon -> [CoreBind]+getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc+  where+    cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc)++getTyConImplicitBinds :: TyCon -> [CoreBind]+getTyConImplicitBinds tc+  | isNewTyCon tc = []  -- See Note [Compulsory newtype unfolding] in MkId+  | otherwise     = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))++getClassImplicitBinds :: Class -> [CoreBind]+getClassImplicitBinds cls+  = [ NonRec op (mkDictSelRhs cls val_index)+    | (op, val_index) <- classAllSelIds cls `zip` [0..] ]++get_defn :: Id -> CoreBind+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+    tcTopIfaceBindings type_var prepd_binding
− src/Development/IDE/GHC/Dump.hs 
@@ -1,337 +0,0 @@-{-# LANGUAGE CPP #-}-module Development.IDE.GHC.Dump(showAstDataHtml) where-import           Data.Data                       hiding (Fixity)-import           Development.IDE.GHC.Compat      hiding (NameAnn)-#if MIN_VERSION_ghc(8,10,1)-import           GHC.Hs.Dump-#else-import           HsDumpAst-#endif-#if MIN_VERSION_ghc(9,2,1)-import qualified Data.ByteString                 as B-import           Development.IDE.GHC.Compat.Util-import           GHC.Hs-import           Generics.SYB                    (ext1Q, ext2Q, extQ)-#endif-#if MIN_VERSION_ghc(9,0,1)-import           GHC.Plugins-#else-import           GhcPlugins-#endif-import           Prelude                         hiding ((<>))---- | Show a GHC syntax tree in HTML.-#if MIN_VERSION_ghc(9,2,1)-showAstDataHtml :: (Data a, ExactPrint a, Outputable a) => a -> SDoc-#else-showAstDataHtml :: (Data a, Outputable a) => a -> SDoc-#endif-showAstDataHtml a0 = html $-    header $$-    body (tag' [("id",text (show @String "myUL"))] "ul" $ vcat-        [-#if MIN_VERSION_ghc(9,2,1)-            li (pre $ text (exactPrint a0)),-            li (showAstDataHtml' a0),-            li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan NoBlankEpAnnotations a0)-#else-            li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan a0)-#endif-        ])-  where-    tag = tag' []-    tag' attrs t cont =-        angleBrackets (text t <+> hcat [text a<>char '=' <>v | (a,v) <- attrs])-        <> cont-        <> angleBrackets (char '/' <> text t)-    ul = tag' [("class", text (show @String "nested"))] "ul"-    li = tag "li"-    caret x = tag' [("class", text "caret")] "span" "" <+> x-    nested foo cts-#if MIN_VERSION_ghc(9,2,1)-      | cts == empty = foo-#endif-      | otherwise = foo $$ (caret $ ul cts)-    body cts = tag "body" $ cts $$ tag "script" (text js)-    header = tag "head" $ tag "style" $ text css-    html = tag "html"-    pre = tag "pre"-#if MIN_VERSION_ghc(9,2,1)-    showAstDataHtml' :: Data a => a -> SDoc-    showAstDataHtml' =-      (generic-              `ext1Q` list-              `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan-              `extQ` annotation-              `extQ` annotationModule-              `extQ` annotationAddEpAnn-              `extQ` annotationGrhsAnn-              `extQ` annotationEpAnnHsCase-              `extQ` annotationEpAnnHsLet-              `extQ` annotationAnnList-              `extQ` annotationEpAnnImportDecl-              `extQ` annotationAnnParen-              `extQ` annotationTrailingAnn-              `extQ` annotationEpaLocation-              `extQ` addEpAnn-              `extQ` lit `extQ` litr `extQ` litt-              `extQ` sourceText-              `extQ` deltaPos-              `extQ` epaAnchor-              `extQ` anchorOp-              `extQ` bytestring-              `extQ` name `extQ` occName `extQ` moduleName `extQ` var-              `extQ` dataCon-              `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet-              `extQ` fixity-              `ext2Q` located-              `extQ` srcSpanAnnA-              `extQ` srcSpanAnnL-              `extQ` srcSpanAnnP-              `extQ` srcSpanAnnC-              `extQ` srcSpanAnnN-              )--      where generic :: Data a => a -> SDoc-            generic t = nested (text $ showConstr (toConstr t))-                     (vcat (gmapQ (li . showAstDataHtml') t))--            string :: String -> SDoc-            string = text . normalize_newlines . show--            fastString :: FastString -> SDoc-            fastString s = braces $-                            text "FastString:"-                        <+> text (normalize_newlines . show $ s)--            bytestring :: B.ByteString -> SDoc-            bytestring = text . normalize_newlines . show--            list []  = brackets empty-            list [x] = "[]" $$ showAstDataHtml' x-            list xs  = nested "[]" (vcat $ map (li . showAstDataHtml') xs)--            -- Eliminate word-size dependence-            lit :: HsLit GhcPs -> SDoc-            lit (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s-            lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s-            lit (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s-            lit (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s-            lit l                  = generic l--            litr :: HsLit GhcRn -> SDoc-            litr (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s-            litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s-            litr (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s-            litr (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s-            litr l                  = generic l--            litt :: HsLit GhcTc -> SDoc-            litt (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s-            litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s-            litt (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s-            litt (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s-            litt l                  = generic l--            numericLit :: String -> Integer -> SourceText -> SDoc-            numericLit tag x s = braces $ hsep [ text tag-                                               , generic x-                                               , generic s ]--            sourceText :: SourceText -> SDoc-            sourceText NoSourceText     = text "NoSourceText"-            sourceText (SourceText src) = text "SourceText" <+> text src--            epaAnchor :: EpaLocation -> SDoc-            epaAnchor (EpaSpan r)  = text "EpaSpan" <+> realSrcSpan r-            epaAnchor (EpaDelta d cs) = text "EpaDelta" <+> deltaPos d <+> showAstDataHtml' cs--            anchorOp :: AnchorOperation -> SDoc-            anchorOp UnchangedAnchor  = "UnchangedAnchor"-            anchorOp (MovedAnchor dp) = "MovedAnchor " <> deltaPos dp--            deltaPos :: DeltaPos -> SDoc-            deltaPos (SameLine c) = text "SameLine" <+> ppr c-            deltaPos (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c--            name :: Name -> SDoc-            name nm    = braces $ text "Name:" <+> ppr nm--            occName n  =  braces $-                          text "OccName:"-                      <+> text (occNameString n)--            moduleName :: ModuleName -> SDoc-            moduleName m = braces $ text "ModuleName:" <+> ppr m--            srcSpan :: SrcSpan -> SDoc-            srcSpan ss = char ' ' <>-                             (hang (ppr ss) 1-                                   -- TODO: show annotations here-                                   (text ""))--            realSrcSpan :: RealSrcSpan -> SDoc-            realSrcSpan ss = braces $ char ' ' <>-                             (hang (ppr ss) 1-                                   -- TODO: show annotations here-                                   (text ""))--            addEpAnn :: AddEpAnn -> SDoc-            addEpAnn (AddEpAnn a s) = text "AddEpAnn" <+> ppr a <+> epaAnchor s--            var  :: Var -> SDoc-            var v      = braces $ text "Var:" <+> ppr v--            dataCon :: DataCon -> SDoc-            dataCon c  = braces $ text "DataCon:" <+> ppr c--            bagRdrName:: Bag (LocatedA (HsBind GhcPs)) -> SDoc-            bagRdrName bg =  braces $-                             text "Bag(LocatedA (HsBind GhcPs)):"-                          $$ (list . bagToList $ bg)--            bagName   :: Bag (LocatedA (HsBind GhcRn)) -> SDoc-            bagName bg  =  braces $-                           text "Bag(LocatedA (HsBind Name)):"-                        $$ (list . bagToList $ bg)--            bagVar    :: Bag (LocatedA (HsBind GhcTc)) -> SDoc-            bagVar bg  =  braces $-                          text "Bag(LocatedA (HsBind Var)):"-                       $$ (list . bagToList $ bg)--            nameSet ns =  braces $-                          text "NameSet:"-                       $$ (list . nameSetElemsStable $ ns)--            fixity :: Fixity -> SDoc-            fixity fx =  braces $-                         text "Fixity:"-                     <+> ppr fx--            located :: (Data a, Data b) => GenLocated a b -> SDoc-            located (L ss a)-              = nested "L" $ (li (showAstDataHtml' ss) $$ li (showAstDataHtml' a))--            -- ---------------------------            annotation :: EpAnn [AddEpAnn] -> SDoc-            annotation = annotation' (text "EpAnn [AddEpAnn]")--            annotationModule :: EpAnn AnnsModule -> SDoc-            annotationModule = annotation' (text "EpAnn AnnsModule")--            annotationAddEpAnn :: EpAnn AddEpAnn -> SDoc-            annotationAddEpAnn = annotation' (text "EpAnn AddEpAnn")--            annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc-            annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn")--            annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc-            annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase")--            annotationEpAnnHsLet :: EpAnn AnnsLet -> SDoc-            annotationEpAnnHsLet = annotation' (text "EpAnn AnnsLet")--            annotationAnnList :: EpAnn AnnList -> SDoc-            annotationAnnList = annotation' (text "EpAnn AnnList")--            annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc-            annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl")--            annotationAnnParen :: EpAnn AnnParen -> SDoc-            annotationAnnParen = annotation' (text "EpAnn AnnParen")--            annotationTrailingAnn :: EpAnn TrailingAnn -> SDoc-            annotationTrailingAnn = annotation' (text "EpAnn TrailingAnn")--            annotationEpaLocation :: EpAnn EpaLocation -> SDoc-            annotationEpaLocation = annotation' (text "EpAnn EpaLocation")--            annotation' :: forall a .(Data a, Typeable a)-                       => SDoc -> EpAnn a -> SDoc-            annotation' tag anns = nested (text $ showConstr (toConstr anns))-              (vcat (map li $ gmapQ showAstDataHtml' anns))--            -- ---------------------------            srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc-            srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA")--            srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc-            srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL")--            srcSpanAnnP :: SrcSpanAnn' (EpAnn AnnPragma) -> SDoc-            srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP")--            srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc-            srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC")--            srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc-            srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")--            locatedAnn'' :: forall a. (Typeable a, Data a)-              => SDoc -> SrcSpanAnn' a -> SDoc-            locatedAnn'' tag ss =-              case cast ss of-                Just ((SrcSpanAnn ann s) :: SrcSpanAnn' a) ->-                      nested "SrcSpanAnn" $ (-                                 li(showAstDataHtml' ann)-                              $$ li(srcSpan s))-                Nothing -> text "locatedAnn:unmatched" <+> tag-                           <+> (text (showConstr (toConstr ss)))-#endif---normalize_newlines :: String -> String-normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs-normalize_newlines (x:xs)                 = x:normalize_newlines xs-normalize_newlines []                     = []--css :: String-css = unlines-  [ "body {background-color: black; color: white ;}"-  , "/* Remove default bullets */"-  , "ul, #myUL {"-  , "  list-style-type: none;"-  , "}"-  , "/* Remove margins and padding from the parent ul */"-  , "#myUL {"-  , "  margin: 0;                       "-  , "  padding: 0;                      "-  , "}                                  "-  , "/* Style the caret/arrow */        "-  , ".caret {                           "-  , "  cursor: pointer;                 "-  , "  user-select: none; /* Prevent text selection */"-  , "}                                  "-  , "/* Create the caret/arrow with a unicode, and style it */"-  , ".caret::before {                   "-  , "  content: \"\\25B6 \";                "-  , "  color: white;                    "-  , "  display: inline-block;           "-  , "  margin-right: 6px;               "-  , "}                                  "-  , "/* Rotate the caret/arrow icon when clicked on (using JavaScript) */"-  , ".caret-down::before {              "-  , "  transform: rotate(90deg);        "-  , "}                                  "-  , "/* Hide the nested list */         "-  , ".nested {                          "-  , "  display: none;                   "-  , "}                                  "-  , "/* Show the nested list when the user clicks on the caret/arrow (with JavaScript) */"-  , ".active {                          "-  , "  display: block;}"-  ]--js :: String-js = unlines-  [ "var toggler = document.getElementsByClassName(\"caret\");"-  , "var i;"-  , "for (i = 0; i < toggler.length; i++) {"-  , "  toggler[i].addEventListener(\"click\", function() {"-  , "    this.parentElement.querySelector(\".nested\").classList.toggle(\"active\");"-  , "    this.classList.toggle(\"caret-down\");"-  , "  }); }"-  ]
src/Development/IDE/GHC/Error.hs view
@@ -1,10 +1,15 @@+{-# 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@@ -16,6 +21,8 @@   , realSrcSpanToRange   , realSrcLocToPosition   , realSrcSpanToLocation+  , realSrcSpanToCodePointRange+  , realSrcLocToCodePointPosition   , srcSpanToFilename   , rangeToSrcSpan   , rangeToRealSrcSpan@@ -23,16 +30,20 @@   , zeroSpan   , realSpan   , isInsideSrcSpan+  , spanContainsRange   , noSpan    -- * utilities working with severities   , 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)@@ -42,30 +53,50 @@ import           Development.IDE.Types.Diagnostics as D 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-    }+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@@ -81,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@@ -118,26 +172,26 @@   Just (Range sp ep) -> sp <= p && p <= ep   _                  -> False +-- Returns Nothing if the SrcSpan does not represent a valid range+spanContainsRange :: SrcSpan -> Range -> Maybe Bool+spanContainsRange srcSpan range = (range `isSubrangeOf`) <$> srcSpanToRange srcSpan+ -- | Convert a GHC severity to a DAML compiler Severity. Severities below -- "Warning" level are dropped (returning Nothing). toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity-toDSeverity SevOutput      = Nothing-toDSeverity SevInteractive = Nothing-toDSeverity SevDump        = Nothing-toDSeverity SevInfo        = Just DsInfo-toDSeverity SevWarning     = Just DsWarning-toDSeverity SevError       = Just DsError-toDSeverity SevFatal       = Just DsError+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.@@ -162,16 +216,16 @@ -- diagnostics catchSrcErrors :: DynFlags -> T.Text -> IO a -> IO (Either [FileDiagnostic] a) catchSrcErrors dflags fromWhere ghcM = do-    Compat.handleGhcException (ghcExceptionToDiagnostics dflags) $-      handleSourceError (sourceErrorToDiagnostics dflags) $+    Compat.handleGhcException ghcExceptionToDiagnostics $+      handleSourceError sourceErrorToDiagnostics $       Right <$> ghcM     where-        ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags-        sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags . srcErrorMessages-+        ghcExceptionToDiagnostics = return . Left . diagFromGhcException fromWhere dflags+        sourceErrorToDiagnostics diag = pure $ Left $+          diagFromErrMsgs fromWhere dflags (Compat.getMessages (srcErrorMessages diag))  diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic]-diagFromGhcException diagSource dflags exc = diagFromString diagSource DsError (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/ExactPrint.hs 
@@ -1,664 +0,0 @@-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE DerivingVia            #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs                  #-}-{-# LANGUAGE RankNTypes             #-}-{-# LANGUAGE TypeFamilies           #-}---- | This module hosts various abstractions and utility functions to work with ghc-exactprint.-module Development.IDE.GHC.ExactPrint-    ( Graft(..),-      graftDecls,-      graftDeclsWithM,-      annotate,-      annotateDecl,-      hoistGraft,-      graftWithM,-      graftExprWithM,-      genericGraftWithSmallestM,-      genericGraftWithLargestM,-      graftSmallestDeclsWithM,-      transform,-      transformM,-      ExactPrint(..),-#if !MIN_VERSION_ghc(9,2,0)-      Anns,-      Annotate,-      setPrecedingLinesT,-#else-      addParens,-      addParensToCtxt,-      modifyAnns,-      removeComma,-      -- * Helper function-      eqSrcSpan,-      epl,-      epAnn,-      removeTrailingComma,-#endif-      annotateParsedSource,-      getAnnotatedParsedSourceRule,-      GetAnnotatedParsedSource(..),-      ASTElement (..),-      ExceptStringT (..),-      TransformT,-      Log(..),-    )-where--import           Control.Applicative                     (Alternative)-import           Control.Arrow                           (right, (***))-import           Control.Monad-import qualified Control.Monad.Fail                      as Fail-import           Control.Monad.IO.Class                  (MonadIO)-import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Except-import           Control.Monad.Zip-import           Data.Bifunctor-import           Data.Bool                               (bool)-import qualified Data.DList                              as DL-import           Data.Either.Extra                       (mapLeft)-import           Data.Foldable                           (Foldable (fold))-import           Data.Functor.Classes-import           Data.Functor.Contravariant-import           Data.Monoid                             (All (All), getAll)-import qualified Data.Text                               as T-import           Data.Traversable                        (for)-import           Development.IDE.Core.RuleTypes-import           Development.IDE.Core.Service            (runAction)-import           Development.IDE.Core.Shake              hiding (Log)-import qualified Development.IDE.Core.Shake              as Shake-import           Development.IDE.GHC.Compat              hiding (parseImport,-                                                          parsePattern,-                                                          parseType)-import           Development.IDE.Graph                   (RuleResult, Rules)-import           Development.IDE.Graph.Classes-import           Development.IDE.Types.Location-import           Development.IDE.Types.Logger            (Pretty (pretty),-                                                          Recorder,-                                                          WithPriority,-                                                          cmapWithPrio)-import qualified GHC.Generics                            as GHC-import           Generics.SYB-import           Generics.SYB.GHC-import           Ide.PluginUtils-import           Language.Haskell.GHC.ExactPrint.Parsers-import           Language.LSP.Types-import           Language.LSP.Types.Capabilities         (ClientCapabilities)-import           Retrie.ExactPrint                       hiding (Annotated (..),-                                                          parseDecl, parseExpr,-                                                          parsePattern,-                                                          parseType)-#if MIN_VERSION_ghc(9,2,0)-import           GHC                                     (EpAnn (..),-                                                          NameAdornment (NameParens),-                                                          NameAnn (..),-                                                          SrcSpanAnn' (SrcSpanAnn),-                                                          SrcSpanAnnA,-                                                          TrailingAnn (AddCommaAnn),-                                                          emptyComments,-                                                          spanAsAnchor)-import           GHC.Parser.Annotation                   (AnnContext (..),-                                                          DeltaPos (SameLine),-                                                          EpaLocation (EpaDelta))-#endif----------------------------------------------------------------------------------data Log = LogShake Shake.Log deriving Show--instance Pretty Log where-  pretty = \case-    LogShake shakeLog -> pretty shakeLog--data GetAnnotatedParsedSource = GetAnnotatedParsedSource-  deriving (Eq, Show, Typeable, GHC.Generic)--instance Hashable GetAnnotatedParsedSource-instance NFData GetAnnotatedParsedSource-type instance RuleResult GetAnnotatedParsedSource = Annotated ParsedSource---- | Get the latest version of the annotated parse source with comments.-getAnnotatedParsedSourceRule :: Recorder (WithPriority Log) -> Rules ()-getAnnotatedParsedSourceRule recorder = define (cmapWithPrio LogShake recorder) $ \GetAnnotatedParsedSource nfp -> do-  pm <- use GetParsedModuleWithComments nfp-  return ([], fmap annotateParsedSource pm)--#if MIN_VERSION_ghc(9,2,0)-annotateParsedSource :: ParsedModule -> Annotated ParsedSource-annotateParsedSource (ParsedModule _ ps _ _) = unsafeMkA (makeDeltaAst ps) 0-#else-annotateParsedSource :: ParsedModule -> Annotated ParsedSource-annotateParsedSource = fixAnns-#endif----------------------------------------------------------------------------------{- | A transformation for grafting source trees together. Use the semigroup- instance to combine 'Graft's, and run them via 'transform'.--}-newtype Graft m a = Graft-    { runGraft :: DynFlags -> a -> TransformT m a-    }--hoistGraft :: (forall x. m x -> n x) -> Graft m a -> Graft n a-hoistGraft h (Graft f) = Graft (fmap (hoistTransform h) . f)--newtype ExceptStringT m a = ExceptStringT {runExceptString :: ExceptT String m a}-    deriving newtype-        ( MonadTrans-        , Monad-        , Functor-        , Applicative-        , Alternative-        , Foldable-        , Contravariant-        , MonadIO-        , Eq1-        , Ord1-        , Show1-        , Read1-        , MonadZip-        , MonadPlus-        , Eq-        , Ord-        , Show-        , Read-        )--instance Monad m => Fail.MonadFail (ExceptStringT m) where-    fail = ExceptStringT . ExceptT . pure . Left--instance Monad m => Semigroup (Graft m a) where-    Graft a <> Graft b = Graft $ \dflags -> a dflags >=> b dflags--instance Monad m => Monoid (Graft m a) where-    mempty = Graft $ const pure------------------------------------------------------------------------------------ | Convert a 'Graft' into a 'WorkspaceEdit'.-transform ::-    DynFlags ->-    ClientCapabilities ->-    Uri ->-    Graft (Either String) ParsedSource ->-    Annotated ParsedSource ->-    Either String WorkspaceEdit-transform dflags ccs uri f a = do-    let src = printA a-    a' <- transformA a $ runGraft f dflags-    let res = printA a'-    pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions------------------------------------------------------------------------------------ | Convert a 'Graft' into a 'WorkspaceEdit'.-transformM ::-    Monad m =>-    DynFlags ->-    ClientCapabilities ->-    Uri ->-    Graft (ExceptStringT m) ParsedSource ->-    Annotated ParsedSource ->-    m (Either String WorkspaceEdit)-transformM dflags ccs uri f a = runExceptT $-    runExceptString $ do-        let src = printA a-        a' <- transformA a $ runGraft f dflags-        let res = printA a'-        pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions----- | Returns whether or not this node requires its immediate children to have--- be parenthesized and have a leading space.------ A more natural type for this function would be to return @(Bool, Bool)@, but--- we use 'All' instead for its monoid instance.-needsParensSpace ::-    HsExpr GhcPs ->-    -- | (Needs parens, needs space)-    (All, All)-needsParensSpace HsLam{}         = (All False, All False)-needsParensSpace HsLamCase{}     = (All False, All True)-needsParensSpace HsApp{}         = mempty-needsParensSpace HsAppType{}     = mempty-needsParensSpace OpApp{}         = mempty-needsParensSpace HsPar{}         = (All False, All False)-needsParensSpace SectionL{}      = (All False, All False)-needsParensSpace SectionR{}      = (All False, All False)-needsParensSpace ExplicitTuple{} = (All False, All False)-needsParensSpace ExplicitSum{}   = (All False, All False)-needsParensSpace HsCase{}        = (All False, All True)-needsParensSpace HsIf{}          = (All False, All False)-needsParensSpace HsMultiIf{}     = (All False, All False)-needsParensSpace HsLet{}         = (All False, All True)-needsParensSpace HsDo{}          = (All False, All False)-needsParensSpace ExplicitList{}  = (All False, All False)-needsParensSpace RecordCon{}     = (All False, All True)-needsParensSpace RecordUpd{}     = mempty-needsParensSpace _               = mempty-----------------------------------------------------------------------------------{- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with the- given @Located ast@. The node at that position must already be a @Located- ast@, or this is a no-op.--}-graft' ::-    forall ast a l.-    (Data a, Typeable l, ASTElement l ast) =>-    -- | Do we need to insert a space before this grafting? In do blocks, the-    -- answer is no, or we will break layout. But in function applications,-    -- the answer is yes, or the function call won't get its argument. Yikes!-    ---    -- More often the answer is yes, so when in doubt, use that.-    Bool ->-    SrcSpan ->-    LocatedAn l ast ->-    Graft (Either String) a-graft' needs_space dst val = Graft $ \dflags a -> do-#if MIN_VERSION_ghc(9,2,0)-    val' <- annotate dflags needs_space val-#else-    (anns, val') <- annotate dflags needs_space val-    modifyAnnsT $ mappend anns-#endif-    pure $-        everywhere'-            ( mkT $-                \case-                    (L src _ :: LocatedAn l ast)-                        | locA src `eqSrcSpan` dst -> val'-                    l                         -> l-            )-            a----- | Like 'graft', but specialized to 'LHsExpr', and intelligently inserts--- parentheses if they're necessary.-graftExpr ::-    forall a.-    (Data a) =>-    SrcSpan ->-    LHsExpr GhcPs ->-    Graft (Either String) a-graftExpr dst val = Graft $ \dflags a -> do-    let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a--    runGraft-      (graft' needs_space dst $ mk_parens val)-      dflags-      a--getNeedsSpaceAndParenthesize ::-    (ASTElement l ast, Data a) =>-    SrcSpan ->-    a ->-    (Bool, LocatedAn l ast -> LocatedAn l ast)-getNeedsSpaceAndParenthesize dst a =-  -- Traverse the tree, looking for our replacement node. But keep track of-  -- the context (parent HsExpr constructor) we're in while we do it. This-  -- lets us determine wehther or not we need parentheses.-  let (needs_parens, needs_space) =-          everythingWithContext (Nothing, Nothing) (<>)-            ( mkQ (mempty, ) $ \x s -> case x of-                (L src _ :: LHsExpr GhcPs) | locA src `eqSrcSpan` dst ->-                  (s, s)-                L _ x' -> (mempty, Just *** Just $ needsParensSpace x')-            ) a-   in ( maybe True getAll needs_space-      , bool id maybeParensAST $ maybe False getAll needs_parens-      )-----------------------------------------------------------------------------------graftExprWithM ::-    forall m a.-    (Fail.MonadFail m, Data a) =>-    SrcSpan ->-    (LHsExpr GhcPs -> TransformT m (Maybe (LHsExpr GhcPs))) ->-    Graft m a-graftExprWithM dst trans = Graft $ \dflags a -> do-    let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a--    everywhereM'-        ( mkM $-            \case-                val@(L src _ :: LHsExpr GhcPs)-                    | locA src `eqSrcSpan` dst -> do-                        mval <- trans val-                        case mval of-                            Just val' -> do-#if MIN_VERSION_ghc(9,2,0)-                                val'' <--                                    hoistTransform (either Fail.fail pure)-                                        (annotate @AnnListItem @(HsExpr GhcPs) dflags needs_space (mk_parens val'))-                                pure val''-#else-                                (anns, val'') <--                                    hoistTransform (either Fail.fail pure)-                                        (annotate @AnnListItem @(HsExpr GhcPs) dflags needs_space (mk_parens val'))-                                modifyAnnsT $ mappend anns-                                pure val''-#endif-                            Nothing -> pure val-                l -> pure l-        )-        a--graftWithM ::-    forall ast m a l.-    (Fail.MonadFail m, Data a, Typeable l, ASTElement l ast) =>-    SrcSpan ->-    (LocatedAn l ast -> TransformT m (Maybe (LocatedAn l ast))) ->-    Graft m a-graftWithM dst trans = Graft $ \dflags a -> do-    everywhereM'-        ( mkM $-            \case-                val@(L src _ :: LocatedAn l ast)-                    | locA src `eqSrcSpan` dst -> do-                        mval <- trans val-                        case mval of-                            Just val' -> do-#if MIN_VERSION_ghc(9,2,0)-                                val'' <--                                    hoistTransform (either Fail.fail pure) $-                                        annotate dflags True $ maybeParensAST val'-                                pure val''-#else-                                (anns, val'') <--                                    hoistTransform (either Fail.fail pure) $-                                        annotate dflags True $ maybeParensAST val'-                                modifyAnnsT $ mappend anns-                                pure val''-#endif-                            Nothing -> pure val-                l -> pure l-        )-        a---- | Run the given transformation only on the smallest node in the tree that--- contains the 'SrcSpan'.-genericGraftWithSmallestM ::-    forall m a ast.-    (Monad m, Data a, Typeable ast) =>-    -- | The type of nodes we'd like to consider when finding the smallest.-    Proxy (Located ast) ->-    SrcSpan ->-    (DynFlags -> ast -> GenericM (TransformT m)) ->-    Graft m a-genericGraftWithSmallestM proxy dst trans = Graft $ \dflags ->-    smallestM (genericIsSubspan proxy dst) (trans dflags)---- | Run the given transformation only on the largest node in the tree that--- contains the 'SrcSpan'.-genericGraftWithLargestM ::-    forall m a ast.-    (Monad m, Data a, Typeable ast) =>-    -- | The type of nodes we'd like to consider when finding the largest.-    Proxy (Located ast) ->-    SrcSpan ->-    (DynFlags -> ast -> GenericM (TransformT m)) ->-    Graft m a-genericGraftWithLargestM proxy dst trans = Graft $ \dflags ->-    largestM (genericIsSubspan proxy dst) (trans dflags)---graftDecls ::-    forall a.-    (HasDecls a) =>-    SrcSpan ->-    [LHsDecl GhcPs] ->-    Graft (Either String) a-graftDecls dst decs0 = Graft $ \dflags a -> do-    decs <- forM decs0 $ \decl -> do-        annotateDecl dflags decl-    let go [] = DL.empty-        go (L src e : rest)-            | locA src `eqSrcSpan` dst = DL.fromList decs <> DL.fromList rest-            | otherwise = DL.singleton (L src e) <> go rest-    modifyDeclsT (pure . DL.toList . go) a--graftSmallestDeclsWithM ::-    forall a.-    (HasDecls a) =>-    SrcSpan ->-    (LHsDecl GhcPs -> TransformT (Either String) (Maybe [LHsDecl GhcPs])) ->-    Graft (Either String) a-graftSmallestDeclsWithM dst toDecls = Graft $ \dflags a -> do-    let go [] = pure DL.empty-        go (e@(L src _) : rest)-            | dst `isSubspanOf` locA src = toDecls e >>= \case-                Just decs0 -> do-                    decs <- forM decs0 $ \decl ->-                        annotateDecl dflags decl-                    pure $ DL.fromList decs <> DL.fromList rest-                Nothing -> (DL.singleton e <>) <$> go rest-            | otherwise = (DL.singleton e <>) <$> go rest-    modifyDeclsT (fmap DL.toList . go) a--graftDeclsWithM ::-    forall a m.-    (HasDecls a, Fail.MonadFail m) =>-    SrcSpan ->-    (LHsDecl GhcPs -> TransformT m (Maybe [LHsDecl GhcPs])) ->-    Graft m a-graftDeclsWithM dst toDecls = Graft $ \dflags a -> do-    let go [] = pure DL.empty-        go (e@(L src _) : rest)-            | locA src `eqSrcSpan` dst = toDecls e >>= \case-                Just decs0 -> do-                    decs <- forM decs0 $ \decl ->-                        hoistTransform (either Fail.fail pure) $-                          annotateDecl dflags decl-                    pure $ DL.fromList decs <> DL.fromList rest-                Nothing -> (DL.singleton e <>) <$> go rest-            | otherwise = (DL.singleton e <>) <$> go rest-    modifyDeclsT (fmap DL.toList . go) a---class (Data ast, Typeable l, Outputable l, Outputable ast) => ASTElement l ast | ast -> l where-    parseAST :: Parser (LocatedAn l ast)-    maybeParensAST :: LocatedAn l ast -> LocatedAn l ast-    {- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with-        the given @Located ast@. The node at that position must already be-        a @Located ast@, or this is a no-op.-    -}-    graft ::-        forall a.-        (Data a) =>-        SrcSpan ->-        LocatedAn l ast ->-        Graft (Either String) a-    graft dst = graft' True dst . maybeParensAST--instance p ~ GhcPs => ASTElement AnnListItem (HsExpr p) where-    parseAST = parseExpr-    maybeParensAST = parenthesize-    graft = graftExpr--instance p ~ GhcPs => ASTElement AnnListItem (Pat p) where-#if __GLASGOW_HASKELL__ == 808-    parseAST = fmap (fmap $ right $ second dL) . parsePattern-    maybeParensAST = dL . parenthesizePat appPrec . unLoc-#else-    parseAST = parsePattern-    maybeParensAST = parenthesizePat appPrec-#endif--instance p ~ GhcPs => ASTElement AnnListItem (HsType p) where-    parseAST = parseType-    maybeParensAST = parenthesizeHsType appPrec--instance p ~ GhcPs => ASTElement AnnListItem (HsDecl p) where-    parseAST = parseDecl-    maybeParensAST = id--instance p ~ GhcPs => ASTElement AnnListItem (ImportDecl p) where-    parseAST = parseImport-    maybeParensAST = id--instance ASTElement NameAnn RdrName where-    parseAST df fp = parseWith df fp parseIdentifier-    maybeParensAST = id----------------------------------------------------------------------------------#if !MIN_VERSION_ghc(9,2,0)--- | Dark magic I stole from retrie. No idea what it does.-fixAnns :: ParsedModule -> Annotated ParsedSource-fixAnns ParsedModule {..} =-    let ranns = relativiseApiAnns pm_parsed_source pm_annotations-     in unsafeMkA pm_parsed_source ranns 0-#endif------------------------------------------------------------------------------------ | Given an 'LHSExpr', compute its exactprint annotations.---   Note that this function will throw away any existing annotations (and format)-annotate :: (ASTElement l ast, Outputable l)-#if MIN_VERSION_ghc(9,2,0)-    => DynFlags -> Bool -> LocatedAn l ast -> TransformT (Either String) (LocatedAn l ast)-#else-    => DynFlags -> Bool -> LocatedAn l ast -> TransformT (Either String) (Anns, LocatedAn l ast)-#endif-annotate dflags needs_space ast = do-    uniq <- show <$> uniqueSrcSpanT-    let rendered = render dflags ast-#if MIN_VERSION_ghc(9,2,0)-    expr' <- lift $ mapLeft show $ parseAST dflags uniq rendered-    pure expr'-#else-    (anns, expr') <- lift $ mapLeft show $ parseAST dflags uniq rendered-    let anns' = setPrecedingLines expr' 0 (bool 0 1 needs_space) anns-    pure (anns',expr')-#endif---- | Given an 'LHsDecl', compute its exactprint annotations.-annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (LHsDecl GhcPs)--- The 'parseDecl' function fails to parse 'FunBind' 'ValD's which contain--- multiple matches. To work around this, we split the single--- 'FunBind'-of-multiple-'Match'es into multiple 'FunBind's-of-one-'Match',--- and then merge them all back together.-annotateDecl dflags-            (L src (-                ValD ext fb@FunBind-                  { fun_matches = mg@MG { mg_alts = L alt_src alts@(_:_)}-                  })) = do-    let set_matches matches =-          ValD ext fb { fun_matches = mg { mg_alts = L alt_src matches }}--#if MIN_VERSION_ghc(9,2,0)-    alts' <- for alts $ \alt -> do-      uniq <- show <$> uniqueSrcSpanT-      let rendered = render dflags $ set_matches [alt]-      lift (mapLeft show $ parseDecl dflags uniq rendered) >>= \case-        (L _ (ValD _ FunBind { fun_matches = MG { mg_alts = L _ [alt']}}))-           -> pure alt'-        _ ->  lift $ Left "annotateDecl: didn't parse a single FunBind match"--    pure $ L src $ set_matches alts'-#else-    (anns', alts') <- fmap unzip $ for alts $ \alt -> do-      uniq <- show <$> uniqueSrcSpanT-      let rendered = render dflags $ set_matches [alt]-      lift (mapLeft show $ parseDecl dflags uniq rendered) >>= \case-        (ann, L _ (ValD _ FunBind { fun_matches = MG { mg_alts = L _ [alt']}}))-           -> pure (setPrecedingLines alt' 1 0 ann, alt')-        _ ->  lift $ Left "annotateDecl: didn't parse a single FunBind match"--    modifyAnnsT $ mappend $ fold anns'-    pure $ L src $ set_matches alts'-#endif-annotateDecl dflags ast = do-    uniq <- show <$> uniqueSrcSpanT-    let rendered = render dflags ast-#if MIN_VERSION_ghc(9,2,0)-    lift $ mapLeft show $ parseDecl dflags uniq rendered-#else-    (anns, expr') <- lift $ mapLeft show $ parseDecl dflags uniq rendered-    let anns' = setPrecedingLines expr' 1 0 anns-    modifyAnnsT $ mappend anns'-    pure expr'-#endif------------------------------------------------------------------------------------ | Print out something 'Outputable'.-render :: Outputable a => DynFlags -> a -> String-render dflags = showSDoc dflags . ppr------------------------------------------------------------------------------------ | Put parentheses around an expression if required.-parenthesize :: LHsExpr GhcPs -> LHsExpr GhcPs-parenthesize = parenthesizeHsExpr appPrec------------------------------------------------------------------------------------ | Equality on SrcSpan's.--- Ignores the (Maybe BufSpan) field of SrcSpan's.-eqSrcSpan :: SrcSpan -> SrcSpan -> Bool-eqSrcSpan l r = leftmost_smallest l r == EQ---- | Equality on SrcSpan's.--- Ignores the (Maybe BufSpan) field of SrcSpan's.-#if MIN_VERSION_ghc(9,2,0)-eqSrcSpanA :: SrcAnn la -> SrcAnn b -> Bool-eqSrcSpanA l r = leftmost_smallest (locA l) (locA r) == EQ-#else-eqSrcSpanA :: SrcSpan -> SrcSpan -> Bool-eqSrcSpanA l r = leftmost_smallest l r == EQ-#endif--#if MIN_VERSION_ghc(9,2,0)-addParensToCtxt :: Maybe EpaLocation -> AnnContext -> AnnContext-addParensToCtxt close_dp = addOpen . addClose-  where-      addOpen it@AnnContext{ac_open = []} = it{ac_open = [epl 0]}-      addOpen other                       = other-      addClose it-        | Just c <- close_dp = it{ac_close = [c]}-        | AnnContext{ac_close = []} <- it = it{ac_close = [epl 0]}-        | otherwise = it--epl :: Int -> EpaLocation-epl n = EpaDelta (SameLine n) []--epAnn :: SrcSpan -> ann -> EpAnn ann-epAnn srcSpan anns = EpAnn (spanAsAnchor srcSpan) anns emptyComments--modifyAnns :: LocatedAn a ast -> (a -> a) -> LocatedAn a ast-modifyAnns x f = first ((fmap.fmap) f) x--removeComma :: SrcSpanAnnA -> SrcSpanAnnA-removeComma it@(SrcSpanAnn EpAnnNotUsed _) = it-removeComma (SrcSpanAnn (EpAnn anc (AnnListItem as) cs) l)-  = (SrcSpanAnn (EpAnn anc (AnnListItem (filter (not . isCommaAnn) as)) cs) l)-  where-      isCommaAnn AddCommaAnn{} = True-      isCommaAnn _             = False--addParens :: Bool -> GHC.NameAnn -> GHC.NameAnn-addParens True it@NameAnn{} =-        it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 }-addParens True it@NameAnnCommas{} =-        it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 }-addParens True it@NameAnnOnly{} =-        it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 }-addParens True NameAnnTrailing{..} =-        NameAnn{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0, nann_name = epl 0, ..}-addParens _ it = it--removeTrailingComma :: GenLocated SrcSpanAnnA ast -> GenLocated SrcSpanAnnA ast-removeTrailingComma = flip modifyAnns $ \(AnnListItem l) -> AnnListItem $ filter (not . isCommaAnn) l--isCommaAnn :: TrailingAnn -> Bool-isCommaAnn AddCommaAnn{} = True-isCommaAnn _             = False-#endif
src/Development/IDE/GHC/Orphans.hs view
@@ -1,50 +1,44 @@ -- 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. --   Note that the 'NFData' instances may not be law abiding. module Development.IDE.GHC.Orphans() where+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Util -#if MIN_VERSION_ghc(9,2,0)-import           GHC.Parser.Annotation-#endif-#if MIN_VERSION_ghc(9,0,0)+import           Control.DeepSeq+import           Control.Monad.Trans.Reader        (ReaderT (..))+import           Data.Aeson+import           Data.Hashable+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.Name.Occurrence+import qualified GHC.Data.StringBuffer             as SB+import           GHC.Iface.Ext.Types+import           GHC.Parser.Annotation+import           GHC.Types.PkgQual import           GHC.Types.SrcLoc-import           GHC.Types.Unique           (getKey)-import           GHC.Unit.Info-import           GHC.Utils.Outputable-#else-import           Bag-import           GhcPlugins-import qualified StringBuffer               as SB-import           Unique                     (getKey)+#if MIN_VERSION_ghc(9,13,0)+import           GHC.Types.Basic                   (ImportLevel) #endif --import           Retrie.ExactPrint          (Annotated)+-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -import           Development.IDE.GHC.Compat-import           Development.IDE.GHC.Util+import           GHC.Unit.Home.ModInfo+import           GHC.Unit.Module.Location          (ModLocation (..))+import           GHC.Unit.Module.WholeCoreBindings -import           Control.DeepSeq-import           Data.Aeson-import           Data.Bifunctor             (Bifunctor (..))-import           Data.Hashable-import           Data.String                (IsString (fromString))-import           Data.Text                  (unpack)-#if MIN_VERSION_ghc(9,0,0)-import          GHC.ByteCode.Types-#else-import          ByteCodeTypes-#endif+-- Orphan instance for Shake.hs+-- https://hub.darcs.net/ross/transformers/issue/86+deriving instance (Semigroup (m a)) => Semigroup (ReaderT r m a)  -- Orphan instances for types from the GHC API. instance Show CoreModule where show = unpack . printOutputable@@ -53,45 +47,58 @@ 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-instance Show PackageFlag where show = unpack . printOutputable-instance Show InteractiveImport where show = unpack . printOutputable-instance Show PackageName  where show = unpack . printOutputable+  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 -#if !MIN_VERSION_ghc(9,0,1)-instance Show ComponentId  where show = unpack . printOutputable-instance Show SourcePackageId  where show = unpack . printOutputable+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 Show GhcPlugins.InstalledUnitId where-    show = installedUnitIdString+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 NFData GhcPlugins.InstalledUnitId where rnf = rwhnf . installedUnitIdFS+instance Show PackageFlag where show = unpack . printOutputable+instance Show InteractiveImport where show = unpack . printOutputable+instance Show PackageName  where show = unpack . printOutputable -instance Hashable GhcPlugins.InstalledUnitId where-  hashWithSalt salt = hashWithSalt salt . installedUnitIdString-#else instance Show UnitId where show = unpack . printOutputable deriving instance Ord SrcSpan deriving instance Ord UnhelpfulSpanReason-#endif  instance NFData SB.StringBuffer where rnf = rwhnf  instance Show Module where     show = moduleNameString . moduleName -instance Outputable a => Show (GenLocated SrcSpan a) where show = unpack . printOutputable--instance (NFData l, NFData e) => NFData (GenLocated l e) where-    rnf (L l e) = rnf l `seq` rnf e- instance Show ModSummary where     show = show . ms_mod @@ -101,24 +108,22 @@ instance NFData ModSummary where     rnf = rwhnf -#if !MIN_VERSION_ghc(8,10,0)-instance NFData FastString where-    rnf = rwhnf-#endif--#if MIN_VERSION_ghc(9,2,0) 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--instance Bifunctor (GenLocated) where-    bimap f g (L l x) = L (f l) (g x)- deriving instance Functor SrcSpanAnn' #endif +instance Bifunctor GenLocated where+    bimap f g (L l x) = L (f l) (g x)+ instance NFData ParsedModule where     rnf = rwhnf @@ -128,15 +133,7 @@ instance NFData HieFile where     rnf = rwhnf -deriving instance Eq SourceModified-deriving instance Show SourceModified-instance NFData SourceModified where-    rnf = rwhnf -#if !MIN_VERSION_ghc(9,2,0)-instance Show ModuleName where-    show = moduleNameString-#endif instance Hashable ModuleName where     hashWithSalt salt = hashWithSalt salt . show @@ -144,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@@ -184,9 +183,6 @@ instance Show a => Show (Bag a) where     show = show . bagToList -instance NFData HsDocString where-    rnf = rwhnf- instance Show ModGuts where     show _ = "modguts" instance NFData ModGuts where@@ -195,18 +191,61 @@ instance NFData (ImportDecl GhcPs) where     rnf = rwhnf -instance Show (Annotated ParsedSource) where-  show _ = "<Annotated ParsedSource>"--instance NFData (Annotated ParsedSource) where+instance (NFData (HsModule a)) where   rnf = rwhnf -#if MIN_VERSION_ghc(9,0,1)-instance (NFData HsModule) where+instance Show OccName where show = unpack . printOutputable+++#if MIN_VERSION_ghc(9,7,0)+instance Hashable OccName where hashWithSalt s n = hashWithSalt s (getKey $ getUnique $ occNameFS n, getKey $ getUnique $ occNameSpace n) #else-instance (NFData (HsModule a)) where+instance Hashable OccName where hashWithSalt s n = hashWithSalt s (getKey $ getUnique n) #endif++instance Show HomeModInfo where show = show . mi_module . hm_iface++instance Show ModuleGraph where show _ = "ModuleGraph {..}"+instance NFData ModuleGraph where rnf = rwhnf++instance NFData HomeModInfo where+  rnf (HomeModInfo iface dets link) = rwhnf iface `seq` rnf dets `seq` rnf link++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 Show OccName where show = unpack . printOutputable-instance Hashable OccName where hashWithSalt s n = hashWithSalt s (getKey $ getUnique n)+instance NFData NodeKey where+  rnf = rwhnf++instance NFData HomeModLinkable where+  rnf = rwhnf++instance NFData (HsExpr (GhcPass Renamed)) where+    rnf = rwhnf++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
@@ -26,28 +26,13 @@     setHieDir,     dontWriteHieFiles,     disableWarningsAsErrors,-    traceAst,-    printOutputable+    printOutputable,+    printOutputableOneLine,+    getExtensions,+    getExtensionsSet,+    stripOccNamePrefix,     ) where -#if MIN_VERSION_ghc(9,2,0)-import           GHC.Data.FastString-import           GHC.Data.StringBuffer-import           GHC.Driver.Env-import           GHC.Driver.Monad-import           GHC.Driver.Session                hiding (ExposePackage)-import           GHC.Parser.Lexer-import           GHC.Runtime.Context-import           GHC.Types.Name.Occurrence-import           GHC.Types.Name.Reader-import           GHC.Types.SrcLoc-import           GHC.Unit.Module.ModDetails-import           GHC.Unit.Module.ModGuts-import           GHC.Utils.Fingerprint-import           GHC.Utils.Outputable-#else-import           Development.IDE.GHC.Compat.Util-#endif import           Control.Concurrent import           Control.Exception                 as E import           Data.Binary.Put                   (Put, runPut)@@ -55,40 +40,36 @@ import           Data.ByteString.Internal          (ByteString (..)) import qualified Data.ByteString.Internal          as BS import qualified Data.ByteString.Lazy              as LBS-import           Data.Data                         (Data) import           Data.IORef import           Data.List.Extra import           Data.Maybe import qualified Data.Text                         as T import qualified Data.Text.Encoding                as T import qualified Data.Text.Encoding.Error          as T-import           Data.Time.Clock.POSIX             (POSIXTime, getCurrentTime,-                                                    utcTimeToPOSIXSeconds) import           Data.Typeable-import qualified Data.Unique                       as U-import           Debug.Trace-import           Development.IDE.GHC.Compat        as GHC+import           Development.IDE.GHC.Compat        as GHC hiding (unitState) import qualified Development.IDE.GHC.Compat.Parser as Compat import qualified Development.IDE.GHC.Compat.Units  as Compat-import           Development.IDE.GHC.Dump          (showAstDataHtml) import           Development.IDE.Types.Location import           Foreign.ForeignPtr import           Foreign.Ptr import           Foreign.Storable-import           GHC+import           GHC                               hiding (ParsedModule (..),+                                                    parser) import           GHC.IO.BufferedIO                 (BufferedIO) import           GHC.IO.Device                     as IODevice import           GHC.IO.Encoding import           GHC.IO.Exception import           GHC.IO.Handle.Internals import           GHC.IO.Handle.Types-import           GHC.Stack-import           System.Environment.Blank          (getEnvDefault)+import           Ide.PluginUtils                   (unescape) import           System.FilePath-import           System.IO.Unsafe-import           Text.Printf -+import           Data.Monoid                       (First (..))+import           GHC.Data.EnumSet+import           GHC.Data.FastString+import           GHC.Data.StringBuffer+import           GHC.Utils.Fingerprint ---------------------------------------------------------------------- -- GHC setup @@ -188,9 +169,9 @@ --   Will produce an 8 byte unreadable ByteString. fingerprintToBS :: Fingerprint -> BS.ByteString fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do-    ptr <- pure $ castPtr ptr-    pokeElemOff ptr 0 a-    pokeElemOff ptr 1 b+    let ptr' = castPtr ptr+    pokeElemOff ptr' 0 a+    pokeElemOff ptr' 1 b  -- | Take the 'Fingerprint' of a 'StringBuffer'. fingerprintFromStringBuffer :: StringBuffer -> IO Fingerprint@@ -255,11 +236,7 @@  -- | This is copied unmodified from GHC since it is not exposed. -- Note the beautiful inline comment!-#if MIN_VERSION_ghc(9,0,0) dupHandle_ :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev-#else-dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev-#endif            -> FilePath            -> Maybe (MVar Handle__)            -> Handle__@@ -281,48 +258,80 @@ -------------------------------------------------------------------------------- -- Tracing exactprint terms -{-# NOINLINE timestamp #-}-timestamp :: POSIXTime-timestamp = utcTimeToPOSIXSeconds $ unsafePerformIO getCurrentTime--debugAST :: Bool-debugAST = unsafePerformIO (getEnvDefault "GHCIDE_DEBUG_AST" "0") == "1"---- | Prints an 'Outputable' value to stderr and to an HTML file for further inspection-traceAst :: (Data a, ExactPrint a, Outputable a, HasCallStack) => String -> a -> a-traceAst lbl x-  | debugAST = trace doTrace x-  | otherwise = x-  where-#if MIN_VERSION_ghc(9,2,0)-    renderDump = renderWithContext defaultSDocContext{sdocStyle = defaultDumpStyle, sdocPprDebug = True}-#else-    renderDump = showSDocUnsafe . ppr-#endif-    htmlDump = showAstDataHtml x-    doTrace = unsafePerformIO $ do-        u <- U.newUnique-        let htmlDumpFileName = printf "/tmp/hls/%s-%s-%d.html" (show timestamp) lbl (U.hashUnique u)-        writeFile htmlDumpFileName $ renderDump htmlDump-        return $ unlines-            [prettyCallStack callStack ++ ":"-#if MIN_VERSION_ghc(9,2,0)-            , exactPrint x-#endif-            , "file://" ++ htmlDumpFileName]---- Should in `Development.IDE.GHC.Orphans`,--- leave it here to prevent cyclic module dependency-#if !MIN_VERSION_ghc(8,10,0)-instance Outputable SDoc where-  ppr = id-#endif- -- | Print a GHC value in `defaultUserStyle` without unique symbols. ----- This is the most common print utility, will print with a user-friendly style like: `a_a4ME` as `a`.+-- This is the most common print utility.+-- It will do something additionally compared to what the 'Outputable' instance does. ----- It internal using `showSDocUnsafe` with `unsafeGlobalDynFlags`.+--   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 = T.pack . printWithoutUniques+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 . print {-# INLINE printOutputable #-}++getExtensions :: ParsedModule -> [Extension]+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
@@ -1,19 +1,42 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0+{-# LANGUAGE CPP                #-} {-# LANGUAGE ExplicitNamespaces #-}  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.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'@@ -23,28 +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-withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a)+--+-- 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) withWarnings diagSource action = do   warnings <- newVar []-  let newAction :: LogActionCompat-      newAction dynFlags wr _ loc prUnqual msg = do-        let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc prUnqual msg+  let newAction :: DynFlags -> LogActionCompat+      newAction dynFlags logFlags wr _ loc prUnqual msg = do+        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_logger env)+      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)--attachReason :: WarnReason -> Diagnostic -> Diagnostic-attachReason wr d = d{_code = InR <$> showReason wr}- where-  showReason = \case-    NoReason       -> Nothing-    Reason flag    -> showFlag flag-    ErrReason flag -> showFlag =<< flag--showFlag :: WarningFlag -> Maybe T.Text-showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags
src/Development/IDE/Import/DependencyInformation.hs view
@@ -1,5 +1,6 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0+{-# LANGUAGE CPP #-}  module Development.IDE.Import.DependencyInformation   ( DependencyInformation(..)@@ -10,29 +11,32 @@   , TransitiveDependencies(..)   , FilePathId(..)   , NamedModuleDep(..)-  , ShowableModuleName(..)-  , PathIdMap+  , ShowableModule(..)+  , ShowableModuleEnv(..)+  , PathIdMap (..)   , emptyPathIdMap   , getPathId   , lookupPathToId   , insertImport   , pathToId   , idToPath+  , idToModLocation   , reachableModules   , processDependencyInformation   , transitiveDeps   , transitiveReverseDependencies   , immediateReverseDependencies-+  , lookupModuleFile   , BootIdMap   , insertBootId+  , lookupFingerprint   ) where  import           Control.DeepSeq import           Data.Bifunctor import           Data.Coerce import           Data.Either-import           Data.Graph+import           Data.Graph                         hiding (edges, path) import           Data.HashMap.Strict                (HashMap) import qualified Data.HashMap.Strict                as HMS import           Data.IntMap                        (IntMap)@@ -45,14 +49,16 @@ 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           Development.IDE.Import.FindImports (ArtifactsLocation (..)) import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Location+import           GHC.Generics                       (Generic)+import           Prelude                            hiding (mod) -import           GHC  -- | The imports for a given module. newtype ModuleImports = ModuleImports@@ -90,21 +96,21 @@     case HMS.lookup (artifactFilePath path) pathToIdMap of         Nothing ->             let !newId = FilePathId nextFreshId-            in (newId, insertPathId path newId m)-        Just id -> (id, m)+            in (newId, insertPathId newId )+        Just fileId -> (fileId, m)   where-    insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap-    insertPathId path id PathIdMap{..} =+    insertPathId :: FilePathId ->  PathIdMap+    insertPathId fileId =         PathIdMap-            (IntMap.insert (getFilePathId id) path idToPathMap)-            (HMS.insert (artifactFilePath path) id pathToIdMap)+            (IntMap.insert (getFilePathId fileId) path idToPathMap)+            (HMS.insert (artifactFilePath path) fileId pathToIdMap)             (succ nextFreshId)  insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) } -pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId-pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path+pathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId+pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.!? path  lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap@@ -113,7 +119,7 @@ idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId  idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation-idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id+idToModLocation PathIdMap{idToPathMap} (FilePathId i) = idToPathMap IntMap.! i  type BootIdMap = FilePathIdMap FilePathId @@ -128,32 +134,54 @@     -- corresponding hs file. It is used when topologically sorting as we     -- need to add edges between .hs-boot and .hs so that the .hs files     -- appear later in the sort.-    , rawBootMap   :: !BootIdMap-    , rawModuleNameMap :: !(FilePathIdMap ShowableModuleName)+    , rawModuleMap :: !(FilePathIdMap ShowableModule)     } deriving Show  data DependencyInformation =   DependencyInformation-    { depErrorNodes        :: !(FilePathIdMap (NonEmpty NodeError))+    { depErrorNodes         :: !(FilePathIdMap (NonEmpty NodeError))     -- ^ Nodes that cannot be processed correctly.-    , depModuleNames       :: !(FilePathIdMap ShowableModuleName)-    , 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)+    -- ^ Map from Module to the corresponding non-boot hs file+    , 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) -newtype ShowableModuleName =-  ShowableModuleName {showableModuleName :: ModuleName}+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 -instance Show ShowableModuleName where show = moduleNameString . showableModuleName+newtype ShowableModuleEnv a =+  ShowableModuleEnv {showableModuleEnv :: ModuleEnv a} +instance Show a => Show (ShowableModuleEnv a) where+  show (ShowableModuleEnv x) = show (moduleEnvToList x)+instance NFData a => NFData (ShowableModuleEnv a) where+  rnf = rwhnf++instance Show ShowableModule where show = moduleNameString . moduleName . showableModule+ reachableModules :: DependencyInformation -> [NormalizedFilePath] reachableModules DependencyInformation{..} =     map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps@@ -215,15 +243,20 @@    SuccessNode _ <> ErrorNode errs   = ErrorNode errs    SuccessNode a <> SuccessNode _    = SuccessNode a -processDependencyInformation :: RawDependencyInformation -> DependencyInformation-processDependencyInformation RawDependencyInformation{..} =+processDependencyInformation :: RawDependencyInformation -> BootIdMap -> ModuleGraph -> FilePathIdMap Fingerprint -> DependencyInformation+processDependencyInformation RawDependencyInformation{..} rawBootMap mg shallowFingerMap =   DependencyInformation     { depErrorNodes = IntMap.fromList errorNodes     , depModuleDeps = moduleDeps     , depReverseModuleDeps = reverseModuleDeps-    , depModuleNames = rawModuleNameMap+    , depModules = rawModuleMap     , depPathIdMap = rawPathIdMap     , 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@@ -240,6 +273,7 @@           foldr (\(p, cs) res ->             let new = IntMap.fromList (map (, IntSet.singleton (coerce p)) (coerce cs))             in IntMap.unionWith IntSet.union new res ) IntMap.empty successEdges+        reverseModuleMap = mkModuleEnv $ map (\(i,sm) -> (showableModule sm, FilePathId i)) $ IntMap.toList rawModuleMap   -- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:@@ -258,9 +292,9 @@         errorsForCycle files =           IntMap.fromListWith (<>) $ coerce $ concatMap (cycleErrorsForFile files) files         cycleErrorsForFile :: [FilePathId] -> FilePathId -> [(FilePathId,NodeResult)]-        cycleErrorsForFile cycle f =-          let entryPoints = mapMaybe (findImport f) cycle-          in map (\imp -> (f, ErrorNode (PartOfCycle imp cycle :| []))) entryPoints+        cycleErrorsForFile cycles' f =+          let entryPoints = mapMaybe (findImport f) cycles'+          in map (\imp -> (f, ErrorNode (PartOfCycle imp cycles' :| []))) entryPoints         otherErrors = IntMap.map otherErrorsForFile g         otherErrorsForFile :: Either ModuleParseError ModuleImports -> NodeResult         otherErrorsForFile (Left err) = ErrorNode (ParseError err :| [])@@ -328,7 +362,7 @@ -- | returns all transitive dependencies in topological order. transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies transitiveDeps DependencyInformation{..} file = do-  let !fileId = pathToId depPathIdMap file+  !fileId <- pathToId depPathIdMap file   reachableVs <-       -- Delete the starting node       IntSet.delete (getFilePathId fileId) .@@ -351,6 +385,10 @@      vs = topSort g +lookupModuleFile :: Module -> DependencyInformation -> Maybe NormalizedFilePath+lookupModuleFile mod DependencyInformation{..}+  = idToPath depPathIdMap <$> lookupModuleEnv (showableModuleEnv depModuleFiles) mod+ newtype TransitiveDependencies = TransitiveDependencies   { transitiveModuleDeps :: [NormalizedFilePath]   -- ^ Transitive module dependencies in topological order.@@ -378,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,20 +14,25 @@   ) 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.Compat.Util 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 ++#if MIN_VERSION_ghc(9,11,0)+import           GHC.Driver.DynFlags+#endif+ data Import   = FileImport !ArtifactsLocation   | PackageImport@@ -37,11 +42,11 @@   { artifactFilePath    :: !NormalizedFilePath   , artifactModLocation :: !(Maybe ModLocation)   , artifactIsSource    :: !Bool          -- ^ True if a module is a source input-  }-    deriving (Show)+  , artifactModule      :: !(Maybe Module)+  } deriving Show  instance NFData ArtifactsLocation where-  rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource+  rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource `seq` rnf artifactModule  isBootLocation :: ArtifactsLocation -> Bool isBootLocation = not . artifactIsSource@@ -51,28 +56,41 @@   rnf PackageImport  = ()  modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation-modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source+modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source mbMod   where     isSource HsSrcFile = True     isSource _         = False     source = case ms of-      Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp-      Just ms -> isSource (ms_hsc_src ms)+      Nothing     -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp+      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-             => [[FilePath]]+             => [(UnitId, [FilePath], S.Set ModuleName)]              -> [String]              -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath))              -> Bool              -> ModuleName-             -> m (Maybe 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 (targetFor modName) (concatMap candidates 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       | isSource = ext ++ "-boot"       | otherwise = ext@@ -81,8 +99,12 @@ -- It only returns Just for unit-ids which are possible to import into the -- current module. In particular, it will return Nothing for 'main' components -- as they can never be imported into another package.-mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, [FilePath])-mkImportDirs env (i, flags) = (, importPaths flags) <$> getUnitName env i+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 _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 -- Haskell@@ -93,43 +115,68 @@     -> [String]                        -- ^ File extensions     -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath))  -- ^ does file exist predicate     -> Located ModuleName              -- ^ Module name-    -> Maybe FastString                -- ^ Package name+    -> PkgQual                -- ^ Package name     -> 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-    Just "this" -> do-      lookupLocal [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-    Just pkgName-      | Just dirs <- lookup (PackageName pkgName) import_paths-          -> lookupLocal [dirs]-      | otherwise -> lookupInPackageDB env-    Nothing -> do-      -- first try to find the module as a file. If we can't find it try to find it in the package-      -- database.-      -- Here the importPaths for the current modules are added to the front of the import paths from the other components.-      -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in-      -- each component will end up being found in the wrong place and cause a multi-cradle match failure.-      mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts targetFor isSource $ unLoc modName+    OtherPkg uid+      | Just (dirs, reexports) <- lookup uid import_paths+          -> lookupLocal uid dirs reexports+      | otherwise -> lookupInPackageDB+    NoPkgQual -> do++      -- 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 env-        Just file -> toModLocation 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-    toModLocation file = liftIO $ do+    other_imports =+      -- 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.+#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++    toModLocation uid file = liftIO $ do         loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)-        return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource)+        let genMod = mkModule (RealUnit $ Definite uid) (unLoc modName)  -- TODO support backpack holes+        return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) (Just genMod) -    lookupLocal dirs = do-      mbFile <- locateModuleFile 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 file -> toModLocation 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 env =+    lookupInPackageDB = do       case Compat.lookupModuleWithSuggestions env (unLoc modName) mbPkgName of         LookupFound _m _pkgConfig -> return $ Right PackageImport         reason -> return $ Left $ notFoundErr env modName reason@@ -140,10 +187,10 @@   mkError' $ ppr' $ cannotFindModule env modName0 $ lookupToFindResult reason   where     dfs = hsc_dflags env-    mkError' = diagFromString "not found" DsError (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 cannotFindMoudle pretty printer.+    -- We convert the lookup result to a find result to reuse GHC's cannotFindModule pretty printer.     lookupToFindResult =       \case         LookupFound _m _pkgConfig ->@@ -156,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'}@@ -172,3 +223,6 @@   , fr_unusables = []   , fr_suggestions = []   }++noPkgQual :: PkgQual+noPkgQual = NoPkgQual
src/Development/IDE/LSP/HoverDefinition.hs view
@@ -1,89 +1,94 @@ -- 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-    ( setIdeHandlers+    ( Log(..)     -- * For haskell-language-server     , hover+    , foundHover     , gotoDefinition     , gotoTypeDefinition+    , gotoImplementation+    , documentHighlight+    , references+    , wsSymbols     ) where +import           Control.Monad.Except           (ExceptT) 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           Development.IDE.LSP.Server+import qualified Development.IDE.Core.Rules     as Shake+import           Development.IDE.Core.Shake     (IdeAction, IdeState (..),+                                                 runIdeAction) import           Development.IDE.Types.Location-import           Development.IDE.Types.Logger-import qualified Language.LSP.Server            as LSP-import           Language.LSP.Types+import           Ide.Logger+import           Ide.Plugin.Error+import           Ide.Types+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types  import qualified Data.Text                      as T -gotoDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentDefinition))-hover          :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (Maybe Hover))-gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentTypeDefinition))-documentHighlight :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (List DocumentHighlight))-gotoDefinition = request "Definition" getDefinition (InR $ InL $ List []) (InR . InL . List)-gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InL $ List []) (InR . InL . List)-hover          = request "Hover"      getAtPoint     Nothing      foundHover-documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List -references :: IdeState -> ReferenceParams -> LSP.LspM c (Either ResponseError (List Location))-references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = liftIO $-  case uriToFilePath' uri of-    Just path -> do-      let filePath = toNormalizedFilePath' path-      logDebug (ideLogger ide) $-        "References request at position " <> T.pack (showPosition pos) <>-        " in file: " <> T.pack path-      Right . List <$> (runAction "references" ide $ refsAtPoint filePath pos)-    Nothing -> pure $ Left $ ResponseError InvalidParams ("Invalid URI " <> T.pack (show uri)) Nothing+data Log+  = LogWorkspaceSymbolRequest !T.Text+  | LogRequest !T.Text !Position !NormalizedFilePath+  deriving (Show) -wsSymbols :: IdeState -> WorkspaceSymbolParams -> LSP.LspM c (Either ResponseError (List SymbolInformation))-wsSymbols ide (WorkspaceSymbolParams _ _ query) = liftIO $ do-  logDebug (ideLogger ide) $ "Workspace symbols request: " <> query-  runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ Right . maybe (List []) List <$> workspaceSymbols query+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) -foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover-foundHover (mbRange, contents) =-  Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange+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 -setIdeHandlers :: LSP.Handlers (ServerM c)-setIdeHandlers = mconcat-  [ requestHandler STextDocumentDefinition $ \ide DefinitionParams{..} ->-      gotoDefinition ide TextDocumentPositionParams{..}-  , requestHandler STextDocumentTypeDefinition $ \ide TypeDefinitionParams{..} ->-      gotoTypeDefinition ide TextDocumentPositionParams{..}-  , requestHandler STextDocumentDocumentHighlight $ \ide DocumentHighlightParams{..} ->-      documentHighlight ide TextDocumentPositionParams{..}-  , requestHandler STextDocumentReferences references-  , requestHandler SWorkspaceSymbol wsSymbols-  ]+references :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentReferences+references recorder ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do+  nfp <- getNormalizedFilePathE uri+  liftIO $ logWith recorder Debug $ LogRequest "References" pos nfp+  InL <$> (liftIO $ Shake.runAction "references" ide $ refsAtPoint nfp pos) +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+foundHover (mbRange, contents) =+  InL $ Hover (InL $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator contents) mbRange+ -- | Respond to and log a hover or go-to-definition request request   :: T.Text   -> (NormalizedFilePath -> Position -> IdeAction (Maybe a))   -> b   -> (a -> b)+  -> Recorder (WithPriority Log)   -> IdeState   -> TextDocumentPositionParams-  -> LSP.LspM c (Either ResponseError 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 $ Right $ maybe notFound found mbResult+    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,16 +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 ExistentialQuantification #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE PolyKinds                 #-}-{-# LANGUAGE RankNTypes                #-}-+{-# 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@@ -24,25 +26,35 @@ import           Development.IDE.LSP.Server import           Development.IDE.Session               (runWithDb) import           Ide.Types                             (traceWithSpan)+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types import qualified Language.LSP.Server                   as LSP-import           Language.LSP.Types import           System.IO import           UnliftIO.Async import           UnliftIO.Concurrent import           UnliftIO.Directory import           UnliftIO.Exception +import 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.Service          (shutdown) import           Development.IDE.Core.Shake            hiding (Log) import           Development.IDE.Core.Tracing-import           Development.IDE.LSP.HoverDefinition-import           Development.IDE.Types.Logger--import           Control.Monad.IO.Unlift               (MonadUnliftIO)+import           Development.IDE.Core.WorkerThread import qualified Development.IDE.Session               as Session-import qualified Development.IDE.Types.Logger          as Logger-import           Development.IDE.Types.Shake           (WithHieDb)-import           System.IO.Unsafe                      (unsafeInterleaveIO)+import           Development.IDE.Types.Shake           (WithHieDb,+                                                        WithHieDbShield (..))+import           Ide.Logger+import           Language.LSP.Server                   (LanguageContextEnv,+                                                        LspServerLog,+                                                        type (<~>))+import           System.Timeout                        (timeout)  data Log   = LogRegisteringIdeConfig !IdeConfiguration@@ -51,11 +63,31 @@   | LogReactorThreadStopped   | 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+      -- the next line has been modified.       "Registering IDE configuration:" <+> viaShow ideConfig     LogReactorThreadException e ->       vcat@@ -69,182 +101,298 @@       "Reactor thread stopped"     LogCancelledRequest requestId ->       "Cancelled request" <+> viaShow requestId-    LogSession log -> pretty log+    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. (Show config)+    :: forall config a m. (Show config)     => Recorder (WithPriority Log)     -> LSP.Options     -> Handle -- input     -> Handle -- output-    -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project     -> config     -> (config -> Value -> Either T.Text config)-    -> LSP.Handlers (ServerM config)-    -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)+    -> (config -> m ())+    -> (MVar () -> IO (Setup config m a))     -> IO ()-runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigurationChange userHandlers getIdeState = do-+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-    -- Forcefully exit-    let exit = void $ tryPutMVar clientMsgVar () -    -- 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 ()--    -- The set of requests ids that we have received but not finished processing-    pendingRequests <- newTVarIO Set.empty-    -- The set of requests that have been cancelled and are also in pendingRequests-    cancelledRequests <- newTVarIO Set.empty--    let cancelRequest reqId = atomically $ do-            queued <- readTVar pendingRequests-            -- We want to avoid that the list of cancelled requests-            -- keeps growing if we receive cancellations for requests-            -- that do not exist or have already been processed.-            when (reqId `elem` queued) $-                modifyTVar cancelledRequests (Set.insert reqId)-    let clearReqId reqId = atomically $ do-            modifyTVar pendingRequests (Set.delete reqId)-            modifyTVar cancelledRequests (Set.delete reqId)-        -- We implement request cancellation by racing waitForCancel against-        -- the actual request handler.-    let waitForCancel reqId = atomically $ do-            cancelled <- readTVar cancelledRequests-            unless (reqId `Set.member` cancelled) retry--    let ideHandlers = mconcat-          [ setIdeHandlers-          , userHandlers-          ]--    -- Send everything over a channel, since you need to wait until after initialise before-    -- LspFuncs is available-    clientMsgChan :: Chan ReactorMessage <- newChan--    let asyncHandlers = mconcat-          [ ideHandlers-          , cancelHandler cancelRequest-          , exitHandler exit-          , shutdownHandler stopReactorLoop-          ]-          -- Cancel requests are special since they need to be handled-          -- out of order to be useful. Existing handlers are run afterwards.-+    MkSetup+      { doInitialize, staticHandlers, interpretHandler, onExit } <- setup clientMsgVar      let serverDefinition = LSP.ServerDefinition-            { LSP.onConfigurationChange = onConfigurationChange+            { LSP.parseConfig = parseConfig+            , LSP.onConfigChange = onConfigChange             , LSP.defaultConfig = defaultConfig-            , LSP.doInitialize = handleInit reactorLifetime exit clearReqId waitForCancel clientMsgChan-            , LSP.staticHandlers = asyncHandlers-            , LSP.interpretHandler = \(env, st) -> LSP.Iso (LSP.runLspT env . flip runReaderT (clientMsgChan,st)) liftIO+            -- TODO: magic string+            , LSP.configSection = "haskell"+            , LSP.doInitialize = doInitialize+            , LSP.staticHandlers = const staticHandlers+            , LSP.interpretHandler = interpretHandler             , LSP.options = modifyOptions options             } -    void $ untilMVar clientMsgVar $-          void $ LSP.runServerWithHandles+    let lspCologAction :: forall io. MonadIO io => Colog.LogAction io (Colog.WithSeverity LspServerLog)+        lspCologAction = toCologActionWithPrio (cmapWithPrio LogLspServer recorder)++    let runServer =+          LSP.runServerWithHandles+            lspCologAction+            lspCologAction             inH             outH             serverDefinition -    where-        log :: Logger.Priority -> Log -> IO ()-        log = logWith recorder+    untilMVar' clientMsgVar runServer `finally` sequence_ onExit+        >>= logWith recorder Info . LogServerExitWith -        handleInit-          :: MVar () -> IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage-          -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))-        handleInit lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do-            traceWithSpan sp params-            let root = LSP.resRootPath env-            dir <- maybe getCurrentDirectory return root-            dbLoc <- getHieDbLoc dir+setupLSP ::+     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 -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState)+  -> MVar ()+  -> 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 -            -- 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+  -- An MVar to control the lifetime of the reactor loop.+  -- The loop will be stopped and resources freed when it's full+  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 -            ide <- getIdeState env root withHieDb hieChan+  -- Forcefully exit+  let exit = void $ tryPutMVar clientMsgVar () -            let initConfig = parseConfiguration params+  -- The set of requests ids that we have received but not finished processing+  pendingRequests <- newTVarIO Set.empty+  -- The set of requests that have been cancelled and are also in pendingRequests+  cancelledRequests <- newTVarIO Set.empty -            log Info $ LogRegisteringIdeConfig initConfig-            registerIdeConfiguration (shakeExtras ide) initConfig+  let cancelRequest reqId = atomically $ do+          queued <- readTVar pendingRequests+          -- We want to avoid that the list of cancelled requests+          -- keeps growing if we receive cancellations for requests+          -- that do not exist or have already been processed.+          when (reqId `Set.member` queued) $+              modifyTVar cancelledRequests (Set.insert reqId)+  let clearReqId reqId = atomically $ do+          modifyTVar pendingRequests (Set.delete reqId)+          modifyTVar cancelledRequests (Set.delete reqId)+      -- We implement request cancellation by racing waitForCancel against+      -- the actual request handler.+  let waitForCancel reqId = atomically $ do+          cancelled <- readTVar cancelledRequests+          unless (reqId `Set.member` cancelled) retry -            let handleServerException (Left e) = do-                    log Error $ LogReactorThreadException e-                    exitClientMsg-                handleServerException (Right _) = pure ()+  let staticHandlers = mconcat+        [ userHandlers+        , cancelHandler cancelRequest+        , shutdownHandler recorder requestReactorShutdown+        ]+        -- Cancel requests are special since they need to be handled+        -- out of order to be useful. Existing handlers are run afterwards. -                exceptionInHandler e = do-                    log Error $ LogReactorMessageActionException e+  let lifecycleCtx = ServerLifecycleContext+        { ctxRecorder = recorder+        , ctxDefaultRoot = defaultRoot+        , ctxGetHieDbLoc = getHieDbLoc+        , ctxGetIdeState = getIdeState+        , ctxUntilReactorStopSignal = untilReactorStopSignal+        , ctxConfirmReactorShutdown = confirmReactorShutdown+        , ctxForceShutdown = exit+        , ctxClearReqId = clearReqId+        , ctxWaitForCancel = waitForCancel+        , ctxClientMsgChan = clientMsgChan+        } -                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-                                    log Debug $ LogCancelledRequest _id-                                    k $ ResponseError RequestCancelled "" Nothing-                                Right res -> pure res-                        ) $ \(e :: SomeException) -> do-                            exceptionInHandler e-                            k $ ResponseError 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-                log Info LogReactorThreadStopped-            pure $ Right (env,ide)+  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 MkSetup {doInitialize, staticHandlers, interpretHandler, onExit}+++handleInit+    :: ServerLifecycleContext config+    -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))+handleInit lifecycleCtx env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do+    traceWithSpan sp params+  -- 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+    ideMVar <- newEmptyMVar++    let+      loggedTeardown me = do+        -- shutdown shake+        case me of+          Left e -> do+            lifetimeConfirm "due to exception in reactor thread"+            logWith recorder Error $ LogReactorThreadException e+            ctxForceShutdown lifecycleCtx+          _ -> do+            lifetimeConfirm "due to shutdown message"+            return ()++      exceptionInHandler e = do+        logWith recorder Error $ LogReactorMessageActionException e++      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 $ 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 -cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c)-cancelHandler cancelRequest = LSP.notificationHandler SCancelRequest $ \NotificationMessage{_params=CancelParams{_id}} ->-  liftIO $ cancelRequest (SomeLspId _id)+untilMVar' :: MonadUnliftIO m => MVar a -> m b -> m (Either a b)+untilMVar' mvar io = race (readMVar mvar) io -shutdownHandler :: IO () -> LSP.Handlers (ServerM c)-shutdownHandler stopReactor = LSP.requestHandler SShutdown $ \_ 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-    resp $ Right Empty+cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c)+cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \TNotificationMessage{_params=CancelParams{_id}} ->+  liftIO $ cancelRequest (SomeLspId (toLspId _id))+  where toLspId :: (Int32 |? T.Text) -> LspId a+        toLspId (InL x) = IdInt x+        toLspId (InR y) = IdString y -exitHandler :: IO () -> LSP.Handlers (ServerM c)-exitHandler exit = LSP.notificationHandler SExit $ const $ liftIO exit+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  modifyOptions :: LSP.Options -> LSP.Options-modifyOptions x = x{ LSP.textDocumentSync   = Just $ tweakTDS origTDS+modifyOptions x = x{ LSP.optTextDocumentSync   = Just $ tweakTDS origTDS                    }     where-        tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ InR $ SaveOptions Nothing}-        origTDS = fromMaybe tdsDefault $ LSP.textDocumentSync x+        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,17 +3,17 @@  {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs                 #-}-{-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE RankNTypes            #-}  module Development.IDE.LSP.Notifications     ( whenUriFile     , descriptor     , Log(..)+    , ghcideNotificationsPluginPriority     ) where -import           Language.LSP.Types-import qualified Language.LSP.Types                    as LSP+import qualified Language.LSP.Protocol.Message         as LSP+import           Language.LSP.Protocol.Types+import qualified Language.LSP.Protocol.Types           as LSP  import           Control.Concurrent.STM.Stats          (atomically) import           Control.Monad.Extra@@ -30,66 +30,77 @@ import qualified Development.IDE.Core.FileStore        as FileStore import           Development.IDE.Core.IdeConfiguration import           Development.IDE.Core.OfInterest       hiding (Log, LogShake)-import           Development.IDE.Core.RuleTypes        (GetClientSettings (..)) 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           Development.IDE.Types.Logger-import           Development.IDE.Types.Shake           (toKey)+import           Ide.Logger import           Ide.Types+import           Numeric.Natural  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 log     -> pretty log-    LogFileStore log -> pretty log+    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-  [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $+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 (Just _version)) (List [])+      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.STextDocumentDidChange $+  , 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.STextDocumentDidSave $+  , 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.STextDocumentDidClose $+  , 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.SWorkspaceDidChangeWatchedFiles $-      \ide vfs _ (DidChangeWatchedFilesParams (List fileEvents)) -> liftIO $ do+  , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWatchedFiles $+      \ide vfs _ (DidChangeWatchedFilesParams fileEvents) -> liftIO $ do         -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and         -- what we do with them         -- filter out files of interest, since we already know all about those@@ -103,12 +114,13 @@                 ]         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.SWorkspaceDidChangeWorkspaceFolders $+  , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWorkspaceFolders $       \ide _ _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do         let add       = S.union             substract = flip S.difference@@ -116,14 +128,11 @@           $ add       (foldMap (S.singleton . parseWorkspaceFolder) (_added   events))           . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events)) -  , mkPluginNotificationHandler LSP.SWorkspaceDidChangeConfiguration $-      \ide vfs _ (DidChangeConfigurationParams cfg) -> liftIO $ do-        let msg = Text.pack $ show cfg-        logDebug (ideLogger ide) $ "Configuration changed: " <> msg-        modifyClientSettings ide (const $ Just cfg)-        setSomethingModified (VFSModified vfs) ide [toKey GetClientSettings emptyFilePath] "config change"+  -- Nothing additional to do here beyond what `lsp` does for us, but this prevents+  -- complaints about there being no handler defined+  , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration mempty -  , mkPluginNotificationHandler LSP.SInitialized $ \ide _ _ _ -> do+  , mkPluginNotificationHandler LSP.SMethod_Initialized $ \ide _ _ _ -> do       --------- Initialize Shake session --------------------------------------------------------------------       liftIO $ shakeSessionInit (cmapWithPrio LogShake recorder) ide @@ -137,6 +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,37 +9,36 @@ where  import           Control.Monad.IO.Class+import           Data.Foldable                  (toList) import           Data.Functor-import           Data.Generics+import           Data.Generics                  hiding (Prefix)+import           Data.List.NonEmpty             (nonEmpty) import           Data.Maybe-import qualified Data.Text                      as T import           Development.IDE.Core.Rules import           Development.IDE.Core.Shake import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Error      (rangeToRealSrcSpan,                                                  realSrcSpanToRange)-import           Development.IDE.Types.Location import           Development.IDE.GHC.Util       (printOutputable)-import           Language.LSP.Server            (LspM)-import           Language.LSP.Types             (DocumentSymbol (..),+import           Development.IDE.Types.Location+import           Ide.Types+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types    (DocumentSymbol (..),                                                  DocumentSymbolParams (DocumentSymbolParams, _textDocument),-                                                 List (..), ResponseError,-                                                 SymbolInformation,-                                                 SymbolKind (SkConstructor, SkField, SkFile, SkFunction, SkInterface, SkMethod, SkModule, SkObject, SkStruct, SkTypeParameter, SkUnknown),+                                                 SymbolKind (..),                                                  TextDocumentIdentifier (TextDocumentIdentifier),-                                                 type (|?) (InL), uriToFilePath)-#if MIN_VERSION_ghc(9,2,0)-import Data.List.NonEmpty (nonEmpty, toList)-#endif+                                                 type (|?) (InL, InR),+                                                 uriToFilePath) + moduleOutline-  :: IdeState -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation))-moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri }+  :: PluginMethodHandler IdeState Method_TextDocumentDocumentSymbol+moduleOutline ideState _ DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri }   = liftIO $ case uriToFilePath uri of     Just (toNormalizedFilePath' -> fp) -> do       mb_decls <- fmap fst <$> runAction "Outline" ideState (useWithStale GetParsedModule fp)-      pure $ Right $ case mb_decls of-        Nothing -> InL (List [])+      pure $ case mb_decls of+        Nothing -> InL []         Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } }           -> let                declSymbols  = mapMaybe documentSymbolForDecl hsmodDecls@@ -48,7 +46,7 @@                  (L (locA -> (RealSrcSpan l _)) m) -> Just $                    (defDocumentSymbol l :: DocumentSymbol)                      { _name  = printOutputable m-                     , _kind  = SkFile+                     , _kind  = SymbolKind_File                      , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0                      }                  _ -> Nothing@@ -58,14 +56,14 @@                allSymbols    = case moduleSymbol of                  Nothing -> importSymbols <> declSymbols                  Just x ->-                   [ x { _children = Just (List (importSymbols <> declSymbols))+                   [ x { _children = Just (importSymbols <> declSymbols)                        }                    ]              in-               InL (List allSymbols)+               InR (InL allSymbols)  -    Nothing -> pure $ Right $ InL (List [])+    Nothing -> pure $ InL []  documentSymbolForDecl :: LHsDecl GhcPs -> Maybe DocumentSymbol documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))@@ -76,7 +74,7 @@                        t  -> " " <> t                      )     , _detail = Just $ printOutputable fdInfo-    , _kind   = SkFunction+    , _kind   = SymbolKind_Function     } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars }))   = Just (defDocumentSymbol l :: DocumentSymbol)@@ -85,111 +83,83 @@                          "" -> ""                          t  -> " " <> t                        )-    , _kind     = SkInterface+    , _kind     = SymbolKind_Interface     , _detail   = Just "class"     , _children =-      Just $ List-        [ (defDocumentSymbol l :: DocumentSymbol)+      Just $+        [ (defDocumentSymbol l' :: DocumentSymbol)             { _name           = printOutputable n-            , _kind           = SkMethod-            , _selectionRange = realSrcSpanToRange l'+            , _kind           = SymbolKind_Method+            , _selectionRange = realSrcSpanToRange l''             }-        | L (locA -> (RealSrcSpan l _))  (ClassOpSig _ False names _) <- tcdSigs-        , L (locA -> (RealSrcSpan l' _)) n                            <- names+        | L (locA -> (RealSrcSpan l' _))  (ClassOpSig _ False names _) <- tcdSigs+        , L (locA -> (RealSrcSpan l'' _)) n                            <- names         ]     } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } }))   = Just (defDocumentSymbol l :: DocumentSymbol)     { _name     = printOutputable name-    , _kind     = SkStruct+    , _kind     = SymbolKind_Struct     , _children =-      Just $ List-        [ (defDocumentSymbol l :: DocumentSymbol)+      Just $+          [ (defDocumentSymbol l'' :: DocumentSymbol)             { _name           = printOutputable n-            , _kind           = SkConstructor+            , _kind           = SymbolKind_Constructor             , _selectionRange = realSrcSpanToRange l'-#if MIN_VERSION_ghc(9,2,0)-            , _children       = List . toList <$> nonEmpty childs+            , _children       = toList <$> nonEmpty childs             }-        | con <- dd_cons+        | con <- extract_cons dd_cons         , let (cs, flds) = hsConDeclsBinders con         , let childs = mapMaybe cvtFld flds         , L (locA -> RealSrcSpan l' _) n <- cs-        , let l = case con of-                L (locA -> RealSrcSpan l _) _ -> l-                _ -> l'+        , let l'' = case con of+                L (locA -> RealSrcSpan l''' _) _ -> l'''+                _                                -> l'         ]     }   where     cvtFld :: LFieldOcc GhcPs -> Maybe DocumentSymbol-    cvtFld (L (RealSrcSpan l _) n) = Just $ (defDocumentSymbol l :: DocumentSymbol)-                { _name = printOutputable (unLoc (rdrNameFieldOcc n))-                , _kind = SkField+    cvtFld (L (locA -> RealSrcSpan l' _) n) = Just $ (defDocumentSymbol l' :: DocumentSymbol)+                { _name = printOutputable (unLoc (foLabel n))+                , _kind = SymbolKind_Field                 }     cvtFld _  = Nothing-#else-           , _children       = conArgRecordFields (con_args x)-            }-        | L (locA -> (RealSrcSpan l _ )) x <- dd_cons-        , L (locA -> (RealSrcSpan l' _)) n <- getConNames' x-        ]-    }-  where-    -- | Extract the record fields of a constructor-    conArgRecordFields (RecCon (L _ lcdfs)) = Just $ List-      [ (defDocumentSymbol l :: DocumentSymbol)-          { _name = printOutputable n-          , _kind = SkField-          }-      | L _ cdf <- lcdfs-      , L (locA -> (RealSrcSpan l _)) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf-      ]-    conArgRecordFields _ = Nothing-#endif documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ SynDecl { tcdLName = L (locA -> (RealSrcSpan l' _)) n })) = Just   (defDocumentSymbol l :: DocumentSymbol) { _name           = printOutputable n-                                          , _kind           = SkTypeParameter+                                          , _kind           = SymbolKind_TypeParameter                                           , _selectionRange = realSrcSpanToRange l'                                           } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))   = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable cid_poly_ty-                                                 , _kind = SkInterface+                                                 , _kind = SymbolKind_Interface                                                  }-#if MIN_VERSION_ghc(9,2,0) documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl FamEqn { feqn_tycon, feqn_pats } }))-#else-documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))-#endif   = Just (defDocumentSymbol l :: DocumentSymbol)-    { _name = printOutputable (unLoc feqn_tycon) <> " " <> T.unwords-                (map printOutputable feqn_pats)-    , _kind = SkInterface+    { _name =+        printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix feqn_pats+    , _kind = SymbolKind_Interface     }-#if MIN_VERSION_ghc(9,2,0) documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl _ FamEqn { feqn_tycon, feqn_pats } }))-#else-documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))-#endif   = Just (defDocumentSymbol l :: DocumentSymbol)-    { _name = printOutputable (unLoc feqn_tycon) <> " " <> T.unwords-                (map printOutputable feqn_pats)-    , _kind = SkInterface+    { _name =+        printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix feqn_pats+    , _kind = SymbolKind_Interface     } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (DerivD _ DerivDecl { deriv_type })) =   gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) ->     (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable @(HsType GhcPs)                                               name-                                            , _kind = SkInterface+                                            , _kind = SymbolKind_Interface                                             } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ FunBind{fun_id = L _ name})) = Just     (defDocumentSymbol l :: DocumentSymbol)       { _name   = printOutputable name-      , _kind   = SkFunction+      , _kind   = SymbolKind_Function       } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ PatBind{pat_lhs})) = Just     (defDocumentSymbol l :: DocumentSymbol)       { _name   = printOutputable pat_lhs-      , _kind   = SkFunction+      , _kind   = SymbolKind_Function       }  documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ForD _ x)) = Just@@ -197,12 +167,10 @@     { _name   = case x of                   ForeignImport{} -> name                   ForeignExport{} -> name-                  XForeignDecl{}  -> "?"-    , _kind   = SkObject+    , _kind   = SymbolKind_Object     , _detail = case x of                   ForeignImport{} -> Just "import"                   ForeignExport{} -> Just "export"-                  XForeignDecl{}  -> Nothing     }   where name = printOutputable $ unLoc $ fd_name x @@ -217,24 +185,20 @@     let       -- safe because if we have no ranges then we don't take this branch       mergeRanges xs = Range (minimum $ map _start xs) (maximum $ map _end xs)-      importRange = mergeRanges $ map (_range :: DocumentSymbol -> Range) importSymbols+      importRange = mergeRanges $ map (\DocumentSymbol{_range} -> _range) importSymbols     in       Just (defDocumentSymbol (rangeToRealSrcSpan "" importRange))           { _name = "imports"-          , _kind = SkModule-          , _children = Just (List importSymbols)+          , _kind = SymbolKind_Module+          , _children = Just importSymbols           }  documentSymbolForImport :: LImportDecl GhcPs -> Maybe DocumentSymbol documentSymbolForImport (L (locA -> (RealSrcSpan l _)) ImportDecl { ideclName, ideclQualified }) = Just   (defDocumentSymbol l :: DocumentSymbol)     { _name   = "import " <> printOutputable ideclName-    , _kind   = SkModule-#if MIN_VERSION_ghc(8,10,0)+    , _kind   = SymbolKind_Module     , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" }-#else-    , _detail = if ideclQualified then Just "qualified" else Nothing-#endif     } documentSymbolForImport _ = Nothing @@ -243,23 +207,15 @@   _detail         = Nothing   _deprecated     = Nothing   _name           = ""-  _kind           = SkUnknown 0+  -- This used to be SkUnknown 0, which is invalid, as SymbolKinds start at 1,+  -- therefore, I am replacing it with SymbolKind_File, which is the type for 1+  _kind           = SymbolKind_File   _range          = realSrcSpanToRange l   _selectionRange = realSrcSpanToRange l   _children       = Nothing   _tags           = Nothing  -- the version of getConNames for ghc9 is restricted to only the renaming phase-#if !MIN_VERSION_ghc(9,2,0)-getConNames' :: ConDecl GhcPs -> [Located (IdP GhcPs)]-getConNames' ConDeclH98  {con_name  = name}  = [name]-getConNames' ConDeclGADT {con_names = names} = names-#if !MIN_VERSION_ghc(8,10,0)-getConNames' (XConDecl NoExt)                = []-#elif !MIN_VERSION_ghc(9,0,0)-getConNames' (XConDecl x)                    = noExtCon x-#endif-#else hsConDeclsBinders :: LConDecl GhcPs                   -> ([LIdP GhcPs], [LFieldOcc GhcPs])    -- See hsLTyClDeclBinders for what this does@@ -277,7 +233,7 @@            -- remove only the first occurrence of any seen field in order to            -- avoid circumventing detection of duplicate fields (#9156)            ConDeclGADT { con_names = names, con_g_args = args }-             -> (names, flds)+             -> (toList names, flds)              where                 flds = get_flds_gadt args @@ -289,14 +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])-    get_flds_gadt (RecConGADT flds) = get_flds (reLoc flds)-    get_flds_gadt _ = []+                  -> [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)+#endif+    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,57 +1,54 @@-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE UndecidableInstances #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE KindSignatures        #-}-{-# LANGUAGE RankNTypes            #-} module Development.IDE.LSP.Server   ( ReactorMessage(..)   , ReactorChan-  , ServerM+  , ServerM(..)   , requestHandler   , notificationHandler   ) where-+import           Control.Monad.IO.Unlift       (MonadUnliftIO) import           Control.Monad.Reader import           Development.IDE.Core.Shake import           Development.IDE.Core.Tracing-import           Ide.Types                    (HasTracing, traceWithSpan)-import           Language.LSP.Server          (Handlers, LspM)-import qualified Language.LSP.Server          as LSP-import           Language.LSP.Types+import           Ide.Types+import           Language.LSP.Protocol.Message+import           Language.LSP.Server           (Handlers, LspM)+import qualified Language.LSP.Server           as LSP import           Language.LSP.VFS import           UnliftIO.Chan  data ReactorMessage   = ReactorNotification (IO ())-  | ReactorRequest SomeLspId (IO ()) (ResponseError -> IO ())+  | forall m . ReactorRequest (LspId m) (IO ()) (TResponseError m -> IO ())  type ReactorChan = Chan ReactorMessage-type ServerM c = ReaderT (ReactorChan, IdeState) (LspM c)+newtype ServerM c a = ServerM { unServerM :: ReaderT (ReactorChan, IdeState) (LspM c) a }+  deriving (Functor, Applicative, Monad, MonadReader (ReactorChan, IdeState), MonadIO, MonadUnliftIO, LSP.MonadLsp c)  requestHandler-  :: forall (m :: Method FromClient Request) c. (HasTracing (MessageParams m)) =>+  :: forall m c. PluginMethod Request m =>      SMethod m-  -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (ResponseResult m)))+  -> (IdeState -> MessageParams m -> LspM c (Either (TResponseError m) (MessageResult m)))   -> Handlers (ServerM c)-requestHandler m k = LSP.requestHandler m $ \RequestMessage{_method,_id,_params} resp -> do+requestHandler m k = LSP.requestHandler m $ \TRequestMessage{_method,_id,_params} resp -> do   st@(chan,ide) <- ask   env <- LSP.getLspEnv-  let resp' = flip runReaderT st . resp+  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 :: Method FromClient Notification) c. (HasTracing (MessageParams m)) =>+  :: forall m c. PluginMethod Notification m =>      SMethod m   -> (IdeState -> VFS -> MessageParams m -> LspM c ())   -> Handlers (ServerM c)-notificationHandler m k = LSP.notificationHandler m $ \NotificationMessage{_params,_method}-> do+notificationHandler m k = LSP.notificationHandler m $ \TNotificationMessage{_params,_method}-> do   (chan,ide) <- ask   env <- LSP.getLspEnv   -- Take a snapshot of the VFS state on every notification
src/Development/IDE/Main.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -Wno-orphans #-} module Development.IDE.Main (Arguments(..)@@ -11,132 +10,132 @@ ,testing ,Log(..) ) where-import           Control.Concurrent.Extra              (withNumCapabilities)-import           Control.Concurrent.STM.Stats          (atomically,-                                                        dumpSTMStats)-import           Control.Exception.Safe                (SomeException, catchAny,-                                                        displayException)-import           Control.Monad.Extra                   (concatMapM, unless,-                                                        when)-import qualified Data.Aeson.Encode.Pretty              as A-import           Data.Default                          (Default (def))-import           Data.Foldable                         (traverse_)-import qualified Data.HashMap.Strict                   as HashMap-import           Data.Hashable                         (hashed)-import           Data.List.Extra                       (intercalate, isPrefixOf,-                                                        nub, nubOrd, partition)-import           Data.Maybe                            (catMaybes, isJust)-import qualified Data.Text                             as T-import           Data.Text.Lazy.Encoding               (decodeUtf8)-import qualified Data.Text.Lazy.IO                     as LT-import           Data.Typeable                         (typeOf)-import           Development.IDE                       (Action, GhcVersion (..),-                                                        Priority (Debug, Error), Rules,-                                                        ghcVersion,-                                                        hDuplicateTo')-import           Development.IDE.Core.Debouncer        (Debouncer,-                                                        newAsyncDebouncer)-import           Development.IDE.Core.FileStore        (isWatchSupported)-import           Development.IDE.Core.IdeConfiguration (IdeConfiguration (..),-                                                        registerIdeConfiguration)-import           Development.IDE.Core.OfInterest       (FileOfInterestStatus (OnDisk),-                                                        kick,-                                                        setFilesOfInterest)-import           Development.IDE.Core.RuleTypes        (GenerateCore (GenerateCore),-                                                        GetHieAst (GetHieAst),-                                                        GhcSession (GhcSession),-                                                        GhcSessionDeps (GhcSessionDeps),-                                                        TypeCheck (TypeCheck))-import           Development.IDE.Core.Rules            (GhcSessionIO (GhcSessionIO),-                                                        mainRule)-import qualified Development.IDE.Core.Rules            as Rules-import           Development.IDE.Core.Service          (initialise, runAction)-import qualified Development.IDE.Core.Service          as Service-import           Development.IDE.Core.Shake            (IdeState (shakeExtras),-                                                        ShakeExtras (state),-                                                        shakeSessionInit, uses)-import qualified Development.IDE.Core.Shake            as Shake-import           Development.IDE.Core.Tracing          (measureMemory)-import           Development.IDE.Graph                 (action)-import           Development.IDE.LSP.LanguageServer    (runLanguageServer)-import qualified Development.IDE.LSP.LanguageServer    as LanguageServer-import           Development.IDE.Main.HeapStats        (withHeapStats)-import qualified Development.IDE.Main.HeapStats        as HeapStats-import           Development.IDE.Plugin                (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules))-import           Development.IDE.Plugin.HLS            (asGhcIdePlugin)-import qualified Development.IDE.Plugin.HLS            as PluginHLS-import qualified Development.IDE.Plugin.HLS.GhcIde     as GhcIde-import qualified Development.IDE.Plugin.Test           as Test-import           Development.IDE.Session               (SessionLoadingOptions,-                                                        getHieDbLoc,-                                                        loadSessionWithOptions,-                                                        retryOnSqliteBusy,-                                                        runWithDb,-                                                        setInitialDynFlags)-import qualified Development.IDE.Session               as Session-import           Development.IDE.Types.Location        (NormalizedUri,-                                                        toNormalizedFilePath')-import           Development.IDE.Types.Logger          (Logger, Pretty (pretty),-                                                        Priority (Info, Warning),-                                                        Recorder, WithPriority,-                                                        cmapWithPrio, logWith,-                                                        vsep, (<+>))-import           Development.IDE.Types.Options         (IdeGhcSession,-                                                        IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset),-                                                        IdeTesting (IdeTesting),-                                                        clientSupportsProgress,-                                                        defaultIdeOptions,-                                                        optModifyDynFlags,-                                                        optTesting)-import           Development.IDE.Types.Shake           (fromKeyType)-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.Plugin.Config                     (CheckParents (NeverCheck),-                                                        Config, checkParents,-                                                        checkProject,-                                                        getConfigFromNotification)-import           Ide.Plugin.ConfigUtils                (pluginsToDefaultConfig,-                                                        pluginsToVSCodeExtensionSchema)-import           Ide.PluginUtils                       (allLspCmdIds',-                                                        getProcessID,-                                                        idePluginsToPluginDesc,-                                                        pluginDescToIdePlugins)-import           Ide.Types                             (IdeCommand (IdeCommand),-                                                        IdePlugins,-                                                        PluginDescriptor (PluginDescriptor, pluginCli),-                                                        PluginId (PluginId),-                                                        ipMap)-import qualified Language.LSP.Server                   as LSP-import qualified "list-t" ListT-import           Numeric.Natural                       (Natural)-import           Options.Applicative                   hiding (action)-import qualified StmContainers.Map                     as STM-import qualified System.Directory.Extra                as IO-import           System.Exit                           (ExitCode (ExitFailure),-                                                        exitWith)-import           System.FilePath                       (takeExtension,-                                                        takeFileName)-import           System.IO                             (BufferMode (LineBuffering, NoBuffering),-                                                        Handle, hFlush,-                                                        hPutStrLn,-                                                        hSetBuffering,-                                                        hSetEncoding, stderr,-                                                        stdin, stdout, utf8)-import           System.Random                         (newStdGen)-import           System.Time.Extra                     (Seconds, offsetTime,-                                                        showDuration)-import           Text.Printf                           (printf) +import           Control.Concurrent.Extra                 (withNumCapabilities)+import           Control.Concurrent.MVar                  (MVar, newEmptyMVar,+                                                           putMVar, tryReadMVar)+import           Control.Concurrent.STM.Stats             (dumpSTMStats)+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.Hashable                            (hashed)+import qualified Data.HashMap.Strict                      as HashMap+import           Data.List.Extra                          (intercalate,+                                                           isPrefixOf, nubOrd,+                                                           partition)+import           Data.Maybe                               (catMaybes, isJust)+import qualified Data.Text                                as T+import           Development.IDE                          (Action,+                                                           Priority (Debug),+                                                           Rules, hDuplicateTo')+import           Development.IDE.Core.Debouncer           (Debouncer,+                                                           newAsyncDebouncer)+import           Development.IDE.Core.FileStore           (isWatchSupported,+                                                           setSomethingModified)+import           Development.IDE.Core.IdeConfiguration    (IdeConfiguration (..),+                                                           modifyClientSettings,+                                                           registerIdeConfiguration)+import           Development.IDE.Core.OfInterest          (FileOfInterestStatus (OnDisk),+                                                           kick,+                                                           setFilesOfInterest)+import           Development.IDE.Core.Rules               (mainRule)+import qualified Development.IDE.Core.Rules               as Rules+import           Development.IDE.Core.RuleTypes           (GenerateCore (GenerateCore),+                                                           GetHieAst (GetHieAst),+                                                           TypeCheck (TypeCheck))+import           Development.IDE.Core.Service             (initialise,+                                                           runAction)+import qualified Development.IDE.Core.Service             as Service+import           Development.IDE.Core.Shake               (IdeState (shakeExtras),+                                                           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.OpenTelemetry as OpenTelemetry+import           Development.IDE.Plugin                   (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules))+import           Development.IDE.Plugin.HLS               (asGhcIdePlugin)+import qualified Development.IDE.Plugin.HLS               as PluginHLS+import qualified Development.IDE.Plugin.HLS.GhcIde        as GhcIde+import qualified Development.IDE.Plugin.Test              as Test+import           Development.IDE.Session                  (SessionLoadingOptions,+                                                           getHieDbLoc,+                                                           getInitialGhcLibDirDefault,+                                                           loadSessionWithOptions,+                                                           retryOnSqliteBusy)+import qualified Development.IDE.Session                  as Session+import           Development.IDE.Types.Location           (NormalizedUri,+                                                           toNormalizedFilePath')+import           Development.IDE.Types.Monitoring         (Monitoring)+import           Development.IDE.Types.Options            (IdeGhcSession,+                                                           IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset),+                                                           IdeTesting (IdeTesting),+                                                           clientSupportsProgress,+                                                           defaultIdeOptions,+                                                           optModifyDynFlags,+                                                           optTesting)+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                               (Pretty (pretty),+                                                           Priority (Info),+                                                           Recorder,+                                                           WithPriority,+                                                           cmapWithPrio,+                                                           logWith, nest, vsep,+                                                           (<+>))+import           Ide.Plugin.Config                        (CheckParents (NeverCheck),+                                                           Config, checkParents,+                                                           checkProject,+                                                           getConfigFromNotification)+import           Ide.PluginUtils                          (allLspCmdIds',+                                                           getProcessID,+                                                           idePluginsToPluginDesc,+                                                           pluginDescToIdePlugins)+import           Ide.Types                                (IdeCommand (IdeCommand),+                                                           IdePlugins,+                                                           PluginDescriptor (PluginDescriptor, pluginCli),+                                                           PluginId (PluginId),+                                                           ipMap, pluginId)+import qualified Language.LSP.Server                      as LSP+import           Numeric.Natural                          (Natural)+import           Options.Applicative                      hiding (action)+import qualified System.Directory.Extra                   as IO+import           System.Exit                              (ExitCode (ExitFailure, ExitSuccess),+                                                           exitWith)+import           System.FilePath                          (takeExtension,+                                                           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)+ data Log   = LogHeapStats !HeapStats.Log-  | LogLspStart+  | LogLspStart [PluginId]   | LogLspStartDuration !Seconds   | LogShouldRunSubset !Bool-  | LogOnlyPartialGhc9Support-  | LogSetInitialDynFlagsException !SomeException+  | LogConfigurationChange T.Text   | LogService Service.Log   | LogShake Shake.Log   | LogGhcIde GhcIde.Log@@ -144,38 +143,37 @@   | LogSession Session.Log   | LogPluginHLS PluginHLS.Log   | LogRules Rules.Log+  | LogUsingGit   deriving Show  instance Pretty Log where   pretty = \case-    LogHeapStats log -> pretty log-    LogLspStart ->-      vsep-        [ "Staring LSP server..."-        , "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"]+    LogHeapStats msg -> pretty msg+    LogLspStart pluginIds ->+      nest 2 $ vsep+        [ "Starting LSP server..."+        , "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"+        , "PluginIds:" <+> pretty (coerce @_ @[T.Text] pluginIds)+        ]     LogLspStartDuration duration ->       "Started LSP server in" <+> pretty (showDuration duration)     LogShouldRunSubset shouldRunSubset ->       "shouldRunSubset:" <+> pretty shouldRunSubset-    LogOnlyPartialGhc9Support ->-      "Currently, HLS supports GHC 9 only partially. See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail."-    LogSetInitialDynFlagsException e ->-      "setInitialDynFlags:" <+> pretty (displayException e)-    LogService log -> pretty log-    LogShake log -> pretty log-    LogGhcIde log -> pretty log-    LogLanguageServer log -> pretty log-    LogSession log -> pretty log-    LogPluginHLS log -> pretty log-    LogRules log -> pretty log+    LogConfigurationChange msg -> "Configuration changed:" <+> pretty msg+    LogService msg -> pretty msg+    LogShake msg -> pretty msg+    LogGhcIde msg -> pretty msg+    LogLanguageServer msg -> pretty msg+    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     | Db {hieOptions ::  HieDb.Options, hieCommand :: HieDb.Command}      -- ^ Run a command in the hiedb     | LSP   -- ^ Run the LSP server-    | PrintExtensionSchema-    | PrintDefaultConfig     | Custom {ideCommand :: IdeCommand IdeState} -- ^ User defined     deriving Show @@ -192,8 +190,6 @@     hsubparser(command "typecheck" (info (Check <$> fileCmd) fileInfo)             <> command "hiedb" (info (Db <$> HieDb.optParser "" True <*> HieDb.cmdParser) hieInfo)             <> command "lsp" (info (pure LSP) lspInfo)-            <> command "vscode-extension-schema" extensionSchemaCommand-            <> command "generate-default-config" generateDefaultConfigCommand             <> pluginCommands             )   where@@ -201,24 +197,16 @@     lspInfo = fullDesc <> progDesc "Start talking to an LSP client"     fileInfo = fullDesc <> progDesc "Used as a test bed to check your IDE will work"     hieInfo = fullDesc <> progDesc "Query .hie files"-    extensionSchemaCommand =-        info (pure PrintExtensionSchema)-             (fullDesc <> progDesc "Print generic config schema for plugins (used in the package.json of haskell vscode extension)")-    generateDefaultConfigCommand =-        info (pure PrintDefaultConfig)-             (fullDesc <> progDesc "Print config supported by the server with default values")      pluginCommands = mconcat         [ command (T.unpack pId) (Custom <$> p)-        | (PluginId pId, PluginDescriptor{pluginCli = Just p}) <- ipMap plugins+        | PluginDescriptor{pluginCli = Just p, pluginId = PluginId pId} <- ipMap plugins         ]   data Arguments = Arguments-    { argsProjectRoot           :: Maybe FilePath-    , argsOTMemoryProfiling     :: Bool+    { argsProjectRoot           :: FilePath     , argCommand                :: Command-    , argsLogger                :: IO Logger     , argsRules                 :: Rules ()     , argsHlsPlugins            :: IdePlugins IdeState     , argsGhcidePlugin          :: Plugin Config  -- ^ Deprecated@@ -231,24 +219,31 @@     , argsHandleIn              :: IO Handle     , argsHandleOut             :: IO Handle     , argsThreads               :: Maybe Natural+    , argsMonitoring            :: IO Monitoring+    , argsDisableKick           :: Bool -- ^ flag to disable kick used for testing     } --defaultArguments :: Recorder (WithPriority Log) -> Logger -> Arguments-defaultArguments recorder logger = Arguments-        { argsProjectRoot = Nothing-        , argsOTMemoryProfiling = False+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))+        , argsHlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde recorder)) <> plugins         , argsSessionLoadingOptions = def         , argsIdeOptions = \config ghcSession -> (defaultIdeOptions ghcSession)             { optCheckProject = pure $ checkProject config             , optCheckParents = pure $ checkParents config             }-        , argsLspOptions = def {LSP.completionTriggerCharacters = 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@@ -268,108 +263,122 @@                 -- the language server tests without the redirection.                 putStr " " >> hFlush stdout                 return newStdout+        , argsMonitoring = OpenTelemetry.monitoring+        , argsDisableKick = False         }  -testing :: Recorder (WithPriority Log) -> Logger -> Arguments-testing recorder logger =+testing :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments+testing recorder projectRoot plugins =   let-    arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = defaultArguments recorder logger+    arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions } =+        defaultArguments recorder projectRoot plugins     hlsPlugins = pluginDescToIdePlugins $       idePluginsToPluginDesc argsHlsPlugins       ++ [Test.blockCommandDescriptor "block-command", Test.plugin]-    ideOptions = \config sessionLoader ->+    ideOptions config sessionLoader =       let         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 () defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun  where-  log :: Priority -> Log -> IO ()-  log = logWith recorder-   fun = do     setLocaleEncoding utf8     pid <- T.pack . show <$> getProcessID-    logger <- argsLogger     hSetBuffering stderr LineBuffering      let hlsPlugin = asGhcIdePlugin (cmapWithPrio LogPluginHLS recorder) argsHlsPlugins         hlsCommands = allLspCmdIds' pid argsHlsPlugins         plugins = hlsPlugin <> argsGhcidePlugin-        options = argsLspOptions { LSP.executeCommandCommands = LSP.executeCommandCommands argsLspOptions <> Just hlsCommands }-        argsOnConfigChange = getConfigFromNotification-        rules = argsRules >> pluginRules plugins+        options = argsLspOptions { LSP.optExecuteCommandCommands = LSP.optExecuteCommandCommands argsLspOptions <> Just hlsCommands }+        argsParseConfig = getConfigFromNotification argsHlsPlugins+        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     outH <- argsHandleOut      numProcessors <- getNumProcessors+    let numCapabilities = max 1 $ maybe (numProcessors `div` 2) fromIntegral argsThreads      case argCommand of-        PrintExtensionSchema ->-            LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToVSCodeExtensionSchema argsHlsPlugins-        PrintDefaultConfig ->-            LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig argsHlsPlugins-        LSP -> withNumCapabilities (maybe (numProcessors `div` 2) fromIntegral argsThreads) $ do-            t <- offsetTime-            log Info LogLspStart--            runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env rootPath withHieDb hieChan -> do-                traverse_ IO.setCurrentDirectory rootPath-                t <- t-                log Info $ LogLspStartDuration t+        LSP -> withNumCapabilities numCapabilities $ do+            ioT <- offsetTime+            logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) -                dir <- maybe IO.getCurrentDirectory return 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+                  sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath (tLoaderQueue threadQueue)+                  config <- LSP.runLspT env LSP.getConfig+                  let def_options = argsIdeOptions config sessionLoader -                -- 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 -> log Error (LogSetInitialDynFlagsException e) >> pure Nothing)+                  -- disable runSubset if the client doesn't support watched files+                  runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported+                  logWith recorder Debug $ LogShouldRunSubset runSubset -                sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir-                config <- LSP.runLspT env LSP.getConfig-                let def_options = argsIdeOptions config sessionLoader+                  let ideOptions = def_options+                              { optReportProgress = clientSupportsProgress caps+                              , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins+                              , optRunSubset = runSubset+                              }+                      caps = LSP.resClientCapabilities env+                  monitoring <- argsMonitoring+                  ide <- initialise+                      (cmapWithPrio LogService recorder)+                      argsDefaultHlsConfig+                      argsHlsPlugins+                      rules+                      (Just env)+                      debouncer+                      ideOptions+                      withHieDb+                      threadQueue+                      monitoring+                      rootPath+                  putMVar ideStateVar ide+                  pure ide -                -- disable runSubset if the client doesn't support watched files-                runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported-                log Debug $ LogShouldRunSubset runSubset+            let setup ideStateVar = setupLSP (cmapWithPrio LogLanguageServer recorder) argsProjectRoot argsGetHieDbLoc (pluginHandlers plugins) (getIdeState ideStateVar)+                -- See Note [Client configuration in Rules]+                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+                  case mide of+                    Nothing -> pure ()+                    Just ide -> liftIO $ do+                        let msg = T.pack $ show cfg+                        setSomethingModified Shake.VFSUnmodified ide "config change" $ do+                            logWith recorder Debug $ LogConfigurationChange msg+                            modifyClientSettings ide (const $ Just cfgObj)+                            return [toNoFileKey Rules.GetClientSettings] -                let options = def_options-                            { optReportProgress = clientSupportsProgress caps-                            , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins-                            , optRunSubset = runSubset-                            }-                    caps = LSP.resClientCapabilities env-                -- FIXME: Remove this after GHC 9 gets fully supported-                when (ghcVersion == GHC90) $-                    log Warning LogOnlyPartialGhc9Support-                initialise-                    (cmapWithPrio LogService recorder)-                    argsDefaultHlsConfig-                    rules-                    (Just env)-                    logger-                    debouncer-                    options-                    withHieDb-                    hieChan+            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@@ -378,96 +387,107 @@             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-            files <- nubOrd <$> mapM IO.canonicalizePath files-            putStrLn $ "Found " ++ show (length files) ++ " files"+            absoluteFiles <- nubOrd <$> mapM IO.canonicalizePath files+            putStrLn $ "Found " ++ show (length absoluteFiles) ++ " files"              putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup"-            cradles <- mapM findCradle files+            cradles <- mapM findCradle absoluteFiles             let ucradles = nubOrd cradles             let n = length ucradles             putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]             when (n > 0) $ putStrLn $ "  (" ++ intercalate ", " (catMaybes ucradles) ++ ")"             putStrLn "\nStep 3/4: Initializing the IDE"-            sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir+            sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir (tLoaderQueue threadQueue)             let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader-                options = def_options+                ideOptions = def_options                         { optCheckParents = pure NeverCheck                         , optCheckProject = pure False                         , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins                         }-            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan+            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)              putStrLn "\nStep 4/4: Type checking the files"-            setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) . toNormalizedFilePath') files-            results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files)-            _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' files)-            _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' files)-            let (worked, failed) = partition fst $ zip (map isJust results) files+            setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) . toNormalizedFilePath') absoluteFiles+            results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' absoluteFiles)+            _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' absoluteFiles)+            _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' absoluteFiles)+            let (worked, failed) = partition fst $ zip (map isJust results) absoluteFiles             when (failed /= []) $                 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed -            let nfiles xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"+            let nfiles xs = let n' = length xs in if n' == 1 then "1 file" else show n' ++ " files"             putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)" -            when argsOTMemoryProfiling $ do-                let values = state $ shakeExtras ide-                let consoleObserver Nothing = return $ \size -> printf "Total: %.2fMB\n" (fromIntegral @Int @Double size / 1e6)-                    consoleObserver (Just k) = return $ \size -> printf "  - %s: %.2fKB\n" (show k) (fromIntegral @Int @Double size / 1e3)--                stateContents <- atomically $ ListT.toList $ STM.listT values-                printf "# Shake value store contents(%d):\n" (length stateContents)-                let keys =-                        nub $-                            typeOf GhcSession :-                            typeOf GhcSessionDeps :-                            [kty | (fromKeyType -> Just (kty,_), _) <- stateContents, kty /= typeOf GhcSessionIO] ++-                            [typeOf GhcSessionIO]-                measureMemory logger [keys] consoleObserver values-             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-                options = def_options+                ideOptions = def_options                     { optCheckParents = pure NeverCheck                     , optCheckProject = pure False                     , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins                     }-            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan+            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 -{-# ANN defaultMain ("HLint: ignore Use nubOrd" :: String) #-}-+-- | 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 -expandFiles :: [FilePath] -> IO [FilePath]-expandFiles = concatMapM $ \x -> do+  flip concatMapM paths $ \x -> do     b <- IO.doesFileExist x     if b         then return [x]         else do-            let recurse "." = True-                recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc-                recurse x = takeFileName x `notElem` ["dist", "dist-newstyle"] -- cabal directories-            files <- filter (\x -> takeExtension x `elem` [".hs", ".lhs"]) <$> IO.listFilesInside (return . recurse) x+            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 @@ -6,11 +5,11 @@ import           Control.Concurrent.Async import           Control.Monad import           Data.Word-import           Development.IDE.Types.Logger (Pretty (pretty), Priority (Info),-                                               Recorder, WithPriority, hsep,-                                               logWith, (<+>)) import           GHC.Stats-import           Text.Printf                  (printf)+import           Ide.Logger               (Pretty (pretty), Priority (Info),+                                           Recorder, WithPriority, hsep,+                                           logWith, (<+>))+import           Text.Printf              (printf)  data Log   = LogHeapStatsPeriod !Int@@ -19,7 +18,7 @@   deriving Show  instance Pretty Log where-  pretty log = case log of+  pretty = \case     LogHeapStatsPeriod period ->       "Logging heap statistics every" <+> pretty (toFormattedSeconds period)     LogHeapStatsDisabled ->@@ -59,8 +58,8 @@   threadDelay heapStatsInterval   logHeapStats l --- | A helper function which lauches the 'heapStatsThread' and kills it--- appropiately when the inner action finishes. It also checks to see+-- | A helper function which launches the 'heapStatsThread' and kills it+-- appropriately when the inner action finishes. It also checks to see -- if `-T` is enabled. withHeapStats :: Recorder (WithPriority Log) -> IO r -> IO r withHeapStats l k = do
+ src/Development/IDE/Monitoring/OpenTelemetry.hs view
@@ -0,0 +1,31 @@+module Development.IDE.Monitoring.OpenTelemetry (monitoring) where++import           Control.Concurrent.Async         (Async, async, cancel)+import           Control.Monad                    (forever)+import           Data.IORef.Extra                 (atomicModifyIORef'_,+                                                   newIORef, readIORef)+import           Data.Text.Encoding               (encodeUtf8)+import           Debug.Trace.Flags                (userTracingEnabled)+import           Development.IDE.Types.Monitoring (Monitoring (..))+import           OpenTelemetry.Eventlog           (mkValueObserver, observe)+import           System.Time.Extra                (Seconds, sleep)++-- | Dump monitoring to the eventlog using the Opentelemetry package+monitoring :: IO Monitoring+monitoring+  | userTracingEnabled = do+    actions <- newIORef []+    let registerCounter name readA = do+            observer <- mkValueObserver (encodeUtf8 name)+            let update = observe observer . fromIntegral =<< readA+            atomicModifyIORef'_ actions (update :)+        registerGauge = registerCounter+    let start = do+            a <- regularly 1 $ sequence_ =<< readIORef actions+            return (cancel a)+    return Monitoring{..}+  | otherwise = mempty+++regularly :: Seconds -> IO () -> IO (Async ())+regularly delay act = async $ forever (act >> sleep delay)
− src/Development/IDE/Plugin/CodeAction.hs 
@@ -1,1775 +0,0 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.--- SPDX-License-Identifier: Apache-2.0--{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE GADTs                 #-}---- | Go to the definition of a variable.--module Development.IDE.Plugin.CodeAction-    (-    iePluginDescriptor,-    typeSigsPluginDescriptor,-    bindingsPluginDescriptor,-    fillHolePluginDescriptor,-    newImport,-    newImportToEdit-    -- * For testing-    , matchRegExMultipleImports-    ) where--import           Control.Applicative                               ((<|>))-import           Control.Arrow                                     (second,-                                                                    (>>>))-import           Control.Concurrent.STM.Stats                      (atomically)-import           Control.Monad                                     (guard, join,-                                                                    msum)-import           Control.Monad.IO.Class-import           Data.Char-import qualified Data.DList                                        as DL-import           Data.Function-import           Data.Functor-import qualified Data.HashMap.Strict                               as Map-import qualified Data.HashSet                                      as Set-import           Data.List.Extra-import           Data.List.NonEmpty                                (NonEmpty ((:|)))-import qualified Data.List.NonEmpty                                as NE-import qualified Data.Map                                          as M-import           Data.Maybe-import qualified Data.Rope.UTF16                                   as Rope-import qualified Data.Set                                          as S-import qualified Data.Text                                         as T-import           Data.Tuple.Extra                                  (fst3)-import           Development.IDE.Core.RuleTypes-import           Development.IDE.Core.Rules-import           Development.IDE.Core.Service-import           Development.IDE.GHC.Compat-import           Development.IDE.GHC.Compat.Util-import           Development.IDE.GHC.Error-import           Development.IDE.GHC.ExactPrint-import           Development.IDE.GHC.Util                          (printOutputable,-                                                                    printRdrName,-                                                                    traceAst)-import           Development.IDE.Plugin.CodeAction.Args-import           Development.IDE.Plugin.CodeAction.ExactPrint-import           Development.IDE.Plugin.CodeAction.PositionIndexed-import           Development.IDE.Plugin.TypeLenses                 (suggestSignature)-import           Development.IDE.Types.Exports-import           Development.IDE.Types.Location-import           Development.IDE.Types.Options-import qualified GHC.LanguageExtensions                            as Lang-import           Ide.PluginUtils                                   (subRange)-import           Ide.Types-import qualified Language.LSP.Server                               as LSP-import           Language.LSP.Types                                (CodeAction (..),-                                                                    CodeActionContext (CodeActionContext, _diagnostics),-                                                                    CodeActionKind (CodeActionQuickFix, CodeActionUnknown),-                                                                    CodeActionParams (CodeActionParams),-                                                                    Command,-                                                                    Diagnostic (..),-                                                                    List (..),-                                                                    ResponseError,-                                                                    SMethod (STextDocumentCodeAction),-                                                                    TextDocumentIdentifier (TextDocumentIdentifier),-                                                                    TextEdit (TextEdit),-                                                                    UInt,-                                                                    WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges),-                                                                    type (|?) (InR),-                                                                    uriToFilePath)-import           Language.LSP.VFS-import           Text.Regex.TDFA                                   (mrAfter,-                                                                    (=~), (=~~))------------------------------------------------------------------------------------------------------- | Generate code actions.-codeAction-    :: IdeState-    -> PluginId-    -> CodeActionParams-    -> LSP.LspM c (Either ResponseError (List (Command |? CodeAction)))-codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs}) = do-  contents <- LSP.getVirtualFile $ toNormalizedUri uri-  liftIO $ do-    let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents-        mbFile = toNormalizedFilePath' <$> uriToFilePath uri-    diag <- atomically $ fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state-    (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile-    let-      actions = caRemoveRedundantImports parsedModule text diag xs uri-               <> caRemoveInvalidExports parsedModule text diag xs uri-    pure $ Right $ List actions-----------------------------------------------------------------------------------------------------iePluginDescriptor :: PluginId -> PluginDescriptor IdeState-iePluginDescriptor plId =-  let old =-        mkGhcideCAsPlugin [-           wrap suggestExtendImport-          , wrap suggestImportDisambiguation-          , wrap suggestNewOrExtendImportForClassMethod-          , wrap suggestNewImport-          , wrap suggestModuleTypo-          , wrap suggestFixConstructorImport-          , wrap suggestHideShadow-          , wrap suggestExportUnusedTopBinding-          ]-          plId-   in old {pluginHandlers = pluginHandlers old <> mkPluginHandler STextDocumentCodeAction codeAction}--typeSigsPluginDescriptor :: PluginId -> PluginDescriptor IdeState-typeSigsPluginDescriptor =-  mkGhcideCAsPlugin [-      wrap $ suggestSignature True-    , wrap suggestFillTypeWildcard-    , wrap removeRedundantConstraints-    , wrap suggestAddTypeAnnotationToSatisfyContraints-    , wrap suggestConstraint-    ]--bindingsPluginDescriptor :: PluginId -> PluginDescriptor IdeState-bindingsPluginDescriptor =-  mkGhcideCAsPlugin [-      wrap suggestReplaceIdentifier-    , wrap suggestImplicitParameter-    , wrap suggestNewDefinition-    , wrap suggestDeleteUnusedBinding-    ]--fillHolePluginDescriptor :: PluginId -> PluginDescriptor IdeState-fillHolePluginDescriptor = mkGhcideCAPlugin $ wrap suggestFillHole-----------------------------------------------------------------------------------------------------findSigOfDecl :: p ~ GhcPass p0 => (IdP p -> Bool) -> [LHsDecl p] -> Maybe (Sig p)-findSigOfDecl pred decls =-  listToMaybe-    [ sig-      | L _ (SigD _ sig@(TypeSig _ idsSig _)) <- decls,-        any (pred . unLoc) idsSig-    ]--findSigOfDeclRanged :: forall p p0 . p ~ GhcPass p0 => Range -> [LHsDecl p] -> Maybe (Sig p)-findSigOfDeclRanged range decls = do-  dec <- findDeclContainingLoc (_start range) decls-  case dec of-     L _ (SigD _ sig@TypeSig {})     -> Just sig-     L _ (ValD _ (bind :: HsBind p)) -> findSigOfBind range bind-     _                               -> Nothing--findSigOfBind :: forall p p0. p ~ GhcPass p0 => Range -> HsBind p -> Maybe (Sig p)-findSigOfBind range bind =-    case bind of-      FunBind {} -> findSigOfLMatch (unLoc $ mg_alts (fun_matches bind))-      _          -> Nothing-  where-    findSigOfLMatch :: [LMatch p (LHsExpr p)] -> Maybe (Sig p)-    findSigOfLMatch ls = do-      match <- findDeclContainingLoc (_start range) ls-      let grhs = m_grhss $ unLoc match-#if !MIN_VERSION_ghc(9,2,0)-          span = getLoc $ reLoc $ grhssLocalBinds grhs-      if _start range `isInsideSrcSpan` span-        then findSigOfBinds range (unLoc (grhssLocalBinds grhs)) -- where clause-        else do-          grhs <- findDeclContainingLoc (_start range) (map reLocA $ grhssGRHSs grhs)-          case unLoc grhs of-            GRHS _ _ bd -> findSigOfExpr (unLoc bd)-            _           -> Nothing-#else-      msum-        [findSigOfBinds range (grhssLocalBinds grhs) -- where clause-        , do-          grhs <- findDeclContainingLoc (_start range) (map reLocA $ grhssGRHSs grhs)-          case unLoc grhs of-            GRHS _ _ bd -> findSigOfExpr (unLoc bd)-        ]-#endif--    findSigOfExpr :: HsExpr p -> Maybe (Sig p)-    findSigOfExpr = go-      where-        go (HsLet _ binds _) = findSigOfBinds range binds-        go (HsDo _ _ stmts) = do-          stmtlr <- unLoc <$> findDeclContainingLoc (_start range) (unLoc stmts)-          case stmtlr of-            LetStmt _ lhsLocalBindsLR -> findSigOfBinds range lhsLocalBindsLR-            _                         -> Nothing-        go _ = Nothing--findSigOfBinds :: p ~ GhcPass p0 => Range -> HsLocalBinds p -> Maybe (Sig p)-findSigOfBinds range = go-  where-    go (HsValBinds _ (ValBinds _ binds lsigs)) =-        case unLoc <$> findDeclContainingLoc (_start range) lsigs of-          Just sig' -> Just sig'-          Nothing -> do-            lHsBindLR <- findDeclContainingLoc (_start range) (bagToList binds)-            findSigOfBind range (unLoc lHsBindLR)-    go _ = Nothing--findInstanceHead :: (Outputable (HsType p), p ~ GhcPass p0) => DynFlags -> String -> [LHsDecl p] -> Maybe (LHsType p)-findInstanceHead df instanceHead decls =-  listToMaybe-#if !MIN_VERSION_ghc(9,2,0)-    [ hsib_body-      | L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = HsIB {hsib_body}})) <- decls,-        showSDoc df (ppr hsib_body) == instanceHead-    ]-#else-    [ hsib_body-      | L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = (unLoc -> HsSig {sig_body = hsib_body})})) <- decls,-        showSDoc df (ppr hsib_body) == instanceHead-    ]-#endif--#if MIN_VERSION_ghc(9,2,0)-findDeclContainingLoc :: Foldable t => Position -> t (GenLocated (SrcSpanAnn' a) e) -> Maybe (GenLocated (SrcSpanAnn' a) e)-#else--- TODO populate this type signature for GHC versions <9.2-#endif-findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` locA l)---- Single:--- This binding for ‘mod’ shadows the existing binding---   imported from ‘Prelude’ at haskell-language-server/ghcide/src/Development/IDE/Plugin/CodeAction.hs:10:8-40---   (and originally defined in ‘GHC.Real’)typecheck(-Wname-shadowing)--- Multi:---This binding for ‘pack’ shadows the existing bindings---  imported from ‘Data.ByteString’ at B.hs:6:1-22---  imported from ‘Data.ByteString.Lazy’ at B.hs:8:1-27---  imported from ‘Data.Text’ at B.hs:7:1-16-suggestHideShadow :: ParsedSource -> T.Text -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Either TextEdit Rewrite])]-suggestHideShadow ps@(L _ HsModule {hsmodImports}) fileContents mTcM mHar Diagnostic {_message, _range}-  | Just [identifier, modName, s] <--      matchRegexUnifySpaces-        _message-        "This binding for ‘([^`]+)’ shadows the existing binding imported from ‘([^`]+)’ at ([^ ]*)" =-    suggests identifier modName s-  | Just [identifier] <--      matchRegexUnifySpaces-        _message-        "This binding for ‘([^`]+)’ shadows the existing bindings",-    Just matched <- allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’ at ([^ ]*)",-    mods <- [(modName, s) | [_, modName, s] <- matched],-    result <- nubOrdBy (compare `on` fst) $ mods >>= uncurry (suggests identifier),-    hideAll <- ("Hide " <> identifier <> " from all occurence imports", concat $ snd <$> result) =-    result <> [hideAll]-  | otherwise = []-  where-    suggests identifier modName s-      | Just tcM <- mTcM,-        Just har <- mHar,-        [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack s],-        isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (RealSrcSpan s' Nothing),-        mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName,-        title <- "Hide " <> identifier <> " from " <> modName =-        if modName == "Prelude" && null mDecl-          then maybeToList $ (\(_, te) -> (title, [Left te])) <$> newImportToEdit (hideImplicitPreludeSymbol identifier) ps fileContents-          else maybeToList $ (title,) . pure . pure . hideSymbol (T.unpack identifier) <$> mDecl-      | otherwise = []--findImportDeclByModuleName :: [LImportDecl GhcPs] -> String -> Maybe (LImportDecl GhcPs)-findImportDeclByModuleName decls modName = flip find decls $ \case-  (L _ ImportDecl {..}) -> modName == moduleNameString (unLoc ideclName)-  _                     -> error "impossible"--isTheSameLine :: SrcSpan -> SrcSpan -> Bool-isTheSameLine s1 s2-  | Just sl1 <- getStartLine s1,-    Just sl2 <- getStartLine s2 =-    sl1 == sl2-  | otherwise = False-  where-    getStartLine x = srcLocLine . realSrcSpanStart <$> realSpan x--isUnusedImportedId :: TcModuleResult -> HieAstResult -> String -> String -> SrcSpan -> Bool-isUnusedImportedId-  TcModuleResult {tmrTypechecked = TcGblEnv {tcg_imports = ImportAvails {imp_mods}}}-  HAR {refMap}-  identifier-  modName-  importSpan-    | occ <- mkVarOcc identifier,-      impModsVals <- importedByUser . concat $ moduleEnvElts imp_mods,-      Just rdrEnv <--        listToMaybe-          [ imv_all_exports-            | ImportedModsVal {..} <- impModsVals,-              imv_name == mkModuleName modName,-              isTheSameLine imv_span importSpan-          ],-      [GRE {gre_name = name}] <- lookupGlobalRdrEnv rdrEnv occ,-      importedIdentifier <- Right name,-      refs <- M.lookup importedIdentifier refMap =-      maybe True (not . any (\(_, IdentifierDetails {..}) -> identInfo == S.singleton Use)) refs-    | otherwise = False--suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _  HsModule{hsmodImports}} contents Diagnostic{_range=_range,..}---     The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant-    | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"-    , Just (L _ impDecl) <- find (\(L (locA -> l) _) -> _start _range `isInsideSrcSpan` l && _end _range `isInsideSrcSpan` l ) hsmodImports-    , Just c <- contents-    , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings)-    , ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges)-    , not (null ranges')-    = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]---- File.hs:16:1: warning:---     The import of `Data.List' is redundant---       except perhaps to import instances from `Data.List'---     To import instances alone, use: import Data.List()-    | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String)-        = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]-    | otherwise = []--caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction]-caRemoveRedundantImports m contents digs ctxDigs uri-  | Just pm <- m,-    r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) digs,-    allEdits <- [ e | (_, (_, edits)) <- r, e <- edits],-    caRemoveAll <- removeAll allEdits,-    ctxEdits <- [ x | x@(d, _) <- r, d `elem` ctxDigs],-    not $ null ctxEdits,-    caRemoveCtx <- map (\(d, (title, tedit)) -> removeSingle title tedit d) ctxEdits-      = caRemoveCtx ++ [caRemoveAll]-  | otherwise = []-  where-    removeSingle title tedit diagnostic = mkCA title (Just CodeActionQuickFix) Nothing [diagnostic] WorkspaceEdit{..} where-        _changes = Just $ Map.singleton uri $ List tedit-        _documentChanges = Nothing-        _changeAnnotations = Nothing-    removeAll tedit = InR $ CodeAction{..} where-        _changes = Just $ Map.singleton uri $ List tedit-        _title = "Remove all redundant imports"-        _kind = Just CodeActionQuickFix-        _diagnostics = Nothing-        _documentChanges = Nothing-        _edit = Just WorkspaceEdit{..}-        _isPreferred = Nothing-        _command = Nothing-        _disabled = Nothing-        _xdata = Nothing-        _changeAnnotations = Nothing--caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction]-caRemoveInvalidExports m contents digs ctxDigs uri-  | Just pm <- m,-    Just txt <- contents,-    txt' <- indexedByPosition $ T.unpack txt,-    r <- mapMaybe (groupDiag pm) digs,-    r' <- map (\(t,d,rs) -> (t,d,extend txt' rs)) r,-    caRemoveCtx <- mapMaybe removeSingle r',-    allRanges <- nubOrd $ [ range | (_,_,ranges) <- r, range <- ranges],-    allRanges' <- extend txt' allRanges,-    Just caRemoveAll <- removeAll allRanges',-    ctxEdits <- [ x | x@(_, d, _) <- r, d `elem` ctxDigs],-    not $ null ctxEdits-      = caRemoveCtx ++ [caRemoveAll]-  | otherwise = []-  where-    extend txt ranges = extendAllToIncludeCommaIfPossible True txt ranges--    groupDiag pm dig-      | Just (title, ranges) <- suggestRemoveRedundantExport pm dig-      = Just (title, dig, ranges)-      | otherwise = Nothing--    removeSingle (_, _, []) = Nothing-    removeSingle (title, diagnostic, ranges) = Just $ InR $ CodeAction{..} where-        tedit = concatMap (\r -> [TextEdit r ""]) $ nubOrd ranges-        _changes = Just $ Map.singleton uri $ List tedit-        _title = title-        _kind = Just CodeActionQuickFix-        _diagnostics = Just $ List [diagnostic]-        _documentChanges = Nothing-        _edit = Just WorkspaceEdit{..}-        _command = Nothing-        _isPreferred = Nothing-        _disabled = Nothing-        _xdata = Nothing-        _changeAnnotations = Nothing-    removeAll [] = Nothing-    removeAll ranges = Just $ InR $ CodeAction{..} where-        tedit = concatMap (\r -> [TextEdit r ""]) ranges-        _changes = Just $ Map.singleton uri $ List tedit-        _title = "Remove all redundant exports"-        _kind = Just CodeActionQuickFix-        _diagnostics = Nothing-        _documentChanges = Nothing-        _edit = Just WorkspaceEdit{..}-        _command = Nothing-        _isPreferred = Nothing-        _disabled = Nothing-        _xdata = Nothing-        _changeAnnotations = Nothing--suggestRemoveRedundantExport :: ParsedModule -> Diagnostic -> Maybe (T.Text, [Range])-suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..}-  | msg <- unifySpaces _message-  , Just export <- hsmodExports-  , Just exportRange <- getLocatedRange $ reLoc export-  , exports <- unLoc export-  , Just (removeFromExport, !ranges) <- fmap (getRanges exports . notInScope) (extractNotInScopeName msg)-                         <|> (,[_range]) <$> matchExportItem msg-                         <|> (,[_range]) <$> matchDupExport msg-  , subRange _range exportRange-    = Just ("Remove ‘" <> removeFromExport <> "’ from export", ranges)-  where-    matchExportItem msg = regexSingleMatch msg "The export item ‘([^’]+)’"-    matchDupExport msg = regexSingleMatch msg "Duplicate ‘([^’]+)’ in export list"-    getRanges exports txt = case smallerRangesForBindingExport exports (T.unpack txt) of-      []     -> (txt, [_range])-      ranges -> (txt, ranges)-suggestRemoveRedundantExport _ _ = Nothing--suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestDeleteUnusedBinding-  ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}}-  contents-  Diagnostic{_range=_range,..}--- Foo.hs:4:1: warning: [-Wunused-binds] Defined but not used: ‘f’-    | Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’"-    , Just indexedContent <- indexedByPosition . T.unpack <$> contents-      = let edits = flip TextEdit "" <$> relatedRanges indexedContent (T.unpack name)-        in ([("Delete ‘" <> name <> "’", edits) | not (null edits)])-    | otherwise = []-    where-      relatedRanges indexedContent name =-        concatMap (findRelatedSpans indexedContent name . reLoc) hsmodDecls-      toRange = realSrcSpanToRange-      extendForSpaces = extendToIncludePreviousNewlineIfPossible--      findRelatedSpans :: PositionIndexedString -> String -> Located (HsDecl GhcPs) -> [Range]-      findRelatedSpans-        indexedContent-        name-        (L (RealSrcSpan l _) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) =-        case lname of-          (L nLoc _name) | isTheBinding nLoc ->-            let findSig (L (RealSrcSpan l _) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig-                findSig _ = []-            in-              extendForSpaces indexedContent (toRange l) :-              concatMap (findSig . reLoc) hsmodDecls-          _ -> concatMap (findRelatedSpanForMatch indexedContent name) matches-      findRelatedSpans _ _ _ = []--      extractNameAndMatchesFromFunBind-        :: HsBind GhcPs-        -> Maybe (Located (IdP GhcPs), [LMatch GhcPs (LHsExpr GhcPs)])-      extractNameAndMatchesFromFunBind-        FunBind-          { fun_id=lname-          , fun_matches=MG {mg_alts=L _ matches}-          } = Just (reLoc lname, matches)-      extractNameAndMatchesFromFunBind _ = Nothing--      findRelatedSigSpan :: PositionIndexedString -> String -> RealSrcSpan -> Sig GhcPs -> [Range]-      findRelatedSigSpan indexedContent name l sig =-        let maybeSpan = findRelatedSigSpan1 name sig-        in case maybeSpan of-          Just (_span, True) -> pure $ extendForSpaces indexedContent $ toRange l -- a :: Int-          Just (RealSrcSpan span _, False) -> pure $ toRange span -- a, b :: Int, a is unused-          _ -> []--      -- Second of the tuple means there is only one match-      findRelatedSigSpan1 :: String -> Sig GhcPs -> Maybe (SrcSpan, Bool)-      findRelatedSigSpan1 name (TypeSig _ lnames _) =-        let maybeIdx = findIndex (\(L _ id) -> isSameName id name) lnames-        in case maybeIdx of-            Nothing -> Nothing-            Just _ | length lnames == 1 -> Just (getLoc $ reLoc $ head lnames, True)-            Just idx ->-              let targetLname = getLoc $ reLoc $ lnames !! idx-                  startLoc = srcSpanStart targetLname-                  endLoc = srcSpanEnd targetLname-                  startLoc' = if idx == 0-                              then startLoc-                              else srcSpanEnd . getLoc . reLoc $ lnames !! (idx - 1)-                  endLoc' = if idx == 0 && idx < length lnames - 1-                            then srcSpanStart . getLoc . reLoc $ lnames !! (idx + 1)-                            else endLoc-              in Just (mkSrcSpan startLoc' endLoc', False)-      findRelatedSigSpan1 _ _ = Nothing--      -- for where clause-      findRelatedSpanForMatch-        :: PositionIndexedString-        -> String-        -> LMatch GhcPs (LHsExpr GhcPs)-        -> [Range]-      findRelatedSpanForMatch-        indexedContent-        name-        (L _ Match{m_grhss=GRHSs{grhssLocalBinds}}) = do-        let go bag lsigs =-                if isEmptyBag bag-                then []-                else concatMap (findRelatedSpanForHsBind indexedContent name lsigs) bag-#if !MIN_VERSION_ghc(9,2,0)-        case grhssLocalBinds of-          (L _ (HsValBinds _ (ValBinds _ bag lsigs))) -> go bag lsigs-          _                                           -> []-#else-        case grhssLocalBinds of-          (HsValBinds _ (ValBinds _ bag lsigs)) -> go bag lsigs-          _                                     -> []-#endif-      findRelatedSpanForMatch _ _ _ = []--      findRelatedSpanForHsBind-        :: PositionIndexedString-        -> String-        -> [LSig GhcPs]-        -> LHsBind GhcPs-        -> [Range]-      findRelatedSpanForHsBind-        indexedContent-        name-        lsigs-        (L (locA -> (RealSrcSpan l _)) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) =-        if isTheBinding (getLoc lname)-        then-          let findSig (L (RealSrcSpan l _) sig) = findRelatedSigSpan indexedContent name l sig-              findSig _ = []-          in extendForSpaces indexedContent (toRange l) : concatMap (findSig . reLoc) lsigs-        else concatMap (findRelatedSpanForMatch indexedContent name) matches-      findRelatedSpanForHsBind _ _ _ _ = []--      isTheBinding :: SrcSpan -> Bool-      isTheBinding span = srcSpanToRange span == Just _range--      isSameName :: IdP GhcPs -> String -> Bool-      isSameName x name = T.unpack (printOutputable x) == name--data ExportsAs = ExportName | ExportPattern | ExportFamily | ExportAll-  deriving (Eq)--getLocatedRange :: Located a -> Maybe Range-getLocatedRange = srcSpanToRange . getLoc--suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> Diagnostic -> [(T.Text, TextEdit)]-suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..}--- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’--- Foo.hs:5:1: warning: [-Wunused-top-binds] Defined but not used: type constructor or class ‘F’--- Foo.hs:6:1: warning: [-Wunused-top-binds] Defined but not used: data constructor ‘Bar’-  | Just source <- srcOpt-  , Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’"-                   <|> matchRegexUnifySpaces _message ".*Defined but not used: type constructor or class ‘([^ ]+)’"-                   <|> matchRegexUnifySpaces _message ".*Defined but not used: data constructor ‘([^ ]+)’"-  , Just (exportType, _) <- find (matchWithDiagnostic _range . snd)-                            . mapMaybe-                                (\(L (locA -> l) b) -> if maybe False isTopLevel $ srcSpanToRange l-                                                then exportsAs b else Nothing)-                            $ hsmodDecls-  , Just pos <- (fmap _end . getLocatedRange) . reLoc =<< hsmodExports-  , Just needComma <- needsComma source <$> fmap reLoc hsmodExports-  , let exportName = (if needComma then ", " else "") <> printExport exportType name-        insertPos = pos {_character = pred $ _character pos}-  = [("Export ‘" <> name <> "’", TextEdit (Range insertPos insertPos) exportName)]-  | otherwise = []-  where-    -- we get the last export and the closing bracket and check for comma in that range-    needsComma :: T.Text -> Located [LIE GhcPs] -> Bool-    needsComma _ (L _ []) = False-    needsComma source (L (RealSrcSpan l _) exports) =-      let closeParan = _end $ realSrcSpanToRange l-          lastExport = fmap _end . getLocatedRange $ last $ fmap reLoc exports-      in case lastExport of-        Just lastExport -> not $ T.isInfixOf "," $ textInRange (Range lastExport closeParan) source-        _ -> False-    needsComma _ _ = False--    opLetter :: String-    opLetter = ":!#$%&*+./<=>?@\\^|-~"--    parenthesizeIfNeeds :: Bool -> T.Text -> T.Text-    parenthesizeIfNeeds needsTypeKeyword x-      | T.head x `elem` opLetter = (if needsTypeKeyword then "type " else "") <> "(" <> x <>")"-      | otherwise = x--    matchWithDiagnostic :: Range -> Located (IdP GhcPs) -> Bool-    matchWithDiagnostic Range{_start=l,_end=r} x =-      let loc = fmap _start . getLocatedRange $ x-       in loc >= Just l && loc <= Just r--    printExport :: ExportsAs -> T.Text -> T.Text-    printExport ExportName x    = parenthesizeIfNeeds False x-    printExport ExportPattern x = "pattern " <> x-    printExport ExportFamily x  = parenthesizeIfNeeds True x-    printExport ExportAll x     = parenthesizeIfNeeds True x <> "(..)"--    isTopLevel :: Range -> Bool-    isTopLevel l = (_character . _start) l == 0--    exportsAs :: HsDecl GhcPs -> Maybe (ExportsAs, Located (IdP GhcPs))-    exportsAs (ValD _ FunBind {fun_id})          = Just (ExportName, reLoc fun_id)-    exportsAs (ValD _ (PatSynBind _ PSB {psb_id})) = Just (ExportPattern, reLoc psb_id)-    exportsAs (TyClD _ SynDecl{tcdLName})      = Just (ExportName, reLoc tcdLName)-    exportsAs (TyClD _ DataDecl{tcdLName})     = Just (ExportAll, reLoc tcdLName)-    exportsAs (TyClD _ ClassDecl{tcdLName})    = Just (ExportAll, reLoc tcdLName)-    exportsAs (TyClD _ FamDecl{tcdFam})        = Just (ExportFamily, reLoc $ fdLName tcdFam)-    exportsAs _                                = Nothing--suggestAddTypeAnnotationToSatisfyContraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestAddTypeAnnotationToSatisfyContraints sourceOpt Diagnostic{_range=_range,..}--- File.hs:52:41: warning:---     * Defaulting the following constraint to type ‘Integer’---        Num p0 arising from the literal ‘1’---     * In the expression: 1---       In an equation for ‘f’: f = 1--- File.hs:52:41: warning:---     * Defaulting the following constraints to type ‘[Char]’---        (Show a0)---          arising from a use of ‘traceShow’---          at A.hs:228:7-25---        (IsString a0)---          arising from the literal ‘"debug"’---          at A.hs:228:17-23---     * In the expression: traceShow "debug" a---       In an equation for ‘f’: f a = traceShow "debug" a--- File.hs:52:41: warning:---     * Defaulting the following constraints to type ‘[Char]’---         (Show a0)---          arising from a use of ‘traceShow’---          at A.hs:255:28-43---        (IsString a0)---          arising from the literal ‘"test"’---          at /Users/serhiip/workspace/ghcide/src/Development/IDE/Plugin/CodeAction.hs:255:38-43---     * In the fourth argument of ‘seq’, namely ‘(traceShow "test")’---       In the expression: seq "test" seq "test" (traceShow "test")---       In an equation for ‘f’:---          f = seq "test" seq "test" (traceShow "test")-    | Just [ty, lit] <- matchRegexUnifySpaces _message (pat False False True False)-                        <|> matchRegexUnifySpaces _message (pat False False False True)-                        <|> matchRegexUnifySpaces _message (pat False False False False)-            = codeEdit ty lit (makeAnnotatedLit ty lit)-    | Just source <- sourceOpt-    , Just [ty, lit] <- matchRegexUnifySpaces _message (pat True True False False)-            = let lit' = makeAnnotatedLit ty lit;-                  tir = textInRange _range source-              in codeEdit ty lit (T.replace lit lit' tir)-    | otherwise = []-    where-      makeAnnotatedLit ty lit = "(" <> lit <> " :: " <> ty <> ")"-      pat multiple at inArg inExpr = T.concat [ ".*Defaulting the following constraint"-                                       , if multiple then "s" else ""-                                       , " to type ‘([^ ]+)’ "-                                       , ".*arising from the literal ‘(.+)’"-                                       , if inArg then ".+In the.+argument" else ""-                                       , if at then ".+at" else ""-                                       , if inExpr then ".+In the expression" else ""-                                       , ".+In the expression"-                                       ]-      codeEdit ty lit replacement =-        let title = "Add type annotation ‘" <> ty <> "’ to ‘" <> lit <> "’"-            edits = [TextEdit _range replacement]-        in  [( title, edits )]---suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestReplaceIdentifier contents Diagnostic{_range=_range,..}--- File.hs:52:41: error:---     * Variable not in scope:---         suggestAcion :: Maybe T.Text -> Range -> Range---     * Perhaps you meant ‘suggestAction’ (line 83)--- File.hs:94:37: error:---     Not in scope: ‘T.isPrfixOf’---     Perhaps you meant one of these:---       ‘T.isPrefixOf’ (imported from Data.Text),---       ‘T.isInfixOf’ (imported from Data.Text),---       ‘T.isSuffixOf’ (imported from Data.Text)---     Module ‘Data.Text’ does not export ‘isPrfixOf’.-    | renameSuggestions@(_:_) <- extractRenamableTerms _message-        = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]-    | otherwise = []--suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestNewDefinition ideOptions parsedModule contents Diagnostic{_message, _range}---     * Variable not in scope:---         suggestAcion :: Maybe T.Text -> Range -> Range-    | Just [name, typ] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)"-    = newDefinitionAction ideOptions parsedModule _range name typ-    | Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps"-    , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ-    = [(label, mkRenameEdit contents _range name : newDefinitionEdits)]-    | otherwise = []-    where-      message = unifySpaces _message--newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text -> [(T.Text, [TextEdit])]-newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ-    | Range _ lastLineP : _ <--      [ realSrcSpanToRange sp-      | (L (locA -> l@(RealSrcSpan sp _)) _) <- hsmodDecls-      , _start `isInsideSrcSpan` l]-    , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0}-    = [ ("Define " <> sig-        , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = _"])]-        )]-    | otherwise = []-  where-    colon = if optNewColonConvention then " : " else " :: "-    sig = name <> colon <> T.dropWhileEnd isSpace typ-    ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule--suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)]-suggestFillTypeWildcard Diagnostic{_range=_range,..}--- Foo.hs:3:8: error:---     * Found type wildcard `_' standing for `p -> p1 -> p'--    | "Found type wildcard" `T.isInfixOf` _message-    , " standing for " `T.isInfixOf` _message-    , typeSignature <- extractWildCardTypeSignature _message-        =  [("Use type signature: ‘" <> typeSignature <> "’", TextEdit _range typeSignature)]-    | otherwise = []--{- Handles two variants with different formatting--1. Could not find module ‘Data.Cha’-   Perhaps you meant Data.Char (from base-4.12.0.0)--2. Could not find module ‘Data.I’-   Perhaps you meant-      Data.Ix (from base-4.14.3.0)-      Data.Eq (from base-4.14.3.0)-      Data.Int (from base-4.14.3.0)--}-suggestModuleTypo :: Diagnostic -> [(T.Text, TextEdit)]-suggestModuleTypo Diagnostic{_range=_range,..}-    | "Could not find module" `T.isInfixOf` _message =-      case T.splitOn "Perhaps you meant" _message of-          [_, stuff] ->-              [ ("replace with " <> modul, TextEdit _range modul)-              | modul <- mapMaybe extractModule (T.lines stuff)-              ]-          _ -> []-    | otherwise = []-  where-    extractModule line = case T.words line of-        [modul, "(from", _] -> Just modul-        _                   -> Nothing---suggestFillHole :: Diagnostic -> [(T.Text, TextEdit)]-suggestFillHole Diagnostic{_range=_range,..}-    | Just holeName <- extractHoleName _message-    , (holeFits, refFits) <- processHoleSuggestions (T.lines _message) =-      let isInfixHole = _message =~ addBackticks holeName :: Bool in-        map (proposeHoleFit holeName False isInfixHole) holeFits-        ++ map (proposeHoleFit holeName True isInfixHole) refFits-    | otherwise = []-    where-      extractHoleName = fmap head . flip matchRegexUnifySpaces "Found hole: ([^ ]*)"-      addBackticks text = "`" <> text <> "`"-      addParens text = "(" <> text <> ")"-      proposeHoleFit holeName parenthise isInfixHole name =-        let isInfixOperator = T.head name == '('-            name' = getOperatorNotation isInfixHole isInfixOperator name in-          ( "replace " <> holeName <> " with " <> name-          , TextEdit _range (if parenthise then addParens name' else name')-          )-      getOperatorNotation True False name                    = addBackticks name-      getOperatorNotation True True name                     = T.drop 1 (T.dropEnd 1 name)-      getOperatorNotation _isInfixHole _isInfixOperator name = name--processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text])-processHoleSuggestions mm = (holeSuggestions, refSuggestions)-{--    • Found hole: _ :: LSP.Handlers--      Valid hole fits include def-      Valid refinement hole fits include-        fromMaybe (_ :: LSP.Handlers) (_ :: Maybe LSP.Handlers)-        fromJust (_ :: Maybe LSP.Handlers)-        haskell-lsp-types-0.22.0.0:Language.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams-                                                                                                        LSP.Handlers)-        T.foldl (_ :: LSP.Handlers -> Char -> LSP.Handlers)-                (_ :: LSP.Handlers)-                (_ :: T.Text)-        T.foldl' (_ :: LSP.Handlers -> Char -> LSP.Handlers)-                 (_ :: LSP.Handlers)-                 (_ :: T.Text)--}-  where-    t = id @T.Text-    holeSuggestions = do-      -- get the text indented under Valid hole fits-      validHolesSection <--        getIndentedGroupsBy (=~ t " *Valid (hole fits|substitutions) include") mm-      -- the Valid hole fits line can contain a hole fit-      holeFitLine <--        mapHead-            (mrAfter . (=~ t " *Valid (hole fits|substitutions) include"))-            validHolesSection-      let holeFit = T.strip $ T.takeWhile (/= ':') holeFitLine-      guard (not $ T.null holeFit)-      return holeFit-    refSuggestions = do -- @[]-      -- get the text indented under Valid refinement hole fits-      refinementSection <--        getIndentedGroupsBy (=~ t " *Valid refinement hole fits include") mm-      -- get the text for each hole fit-      holeFitLines <- getIndentedGroups (tail refinementSection)-      let holeFit = T.strip $ T.unwords holeFitLines-      guard $ not $ holeFit =~ t "Some refinement hole fits suppressed"-      return holeFit--    mapHead f (a:aa) = f a : aa-    mapHead _ []     = []---- > getIndentedGroups [" H1", "  l1", "  l2", " H2", "  l3"] = [[" H1,", "  l1", "  l2"], [" H2", "  l3"]]-getIndentedGroups :: [T.Text] -> [[T.Text]]-getIndentedGroups [] = []-getIndentedGroups ll@(l:_) = getIndentedGroupsBy ((== indentation l) . indentation) ll--- |--- > getIndentedGroupsBy (" H" `isPrefixOf`) [" H1", "  l1", "  l2", " H2", "  l3"] = [[" H1", "  l1", "  l2"], [" H2", "  l3"]]-getIndentedGroupsBy :: (T.Text -> Bool) -> [T.Text] -> [[T.Text]]-getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of-    (l:ll) -> case span (\l' -> indentation l < indentation l') ll of-        (indented, rest) -> (l:indented) : getIndentedGroupsBy pred rest-    _ -> []--indentation :: T.Text -> Int-indentation = T.length . T.takeWhile isSpace--suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, CodeActionKind, Rewrite)]-suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_range,..}-    | Just [binding, mod, srcspan] <--      matchRegexUnifySpaces _message-      "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$"-    = suggestions hsmodImports binding mod srcspan-    | Just (binding, mod_srcspan) <--      matchRegExMultipleImports _message-    = mod_srcspan >>= uncurry (suggestions hsmodImports binding)-    | otherwise = []-    where-        canUseDatacon = case extractNotInScopeName _message of-                            Just NotInScopeTypeConstructorOrClass{} -> False-                            _                                       -> True--        suggestions decls binding mod srcspan-          | range <- case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of-                [s] -> let x = realSrcSpanToRange s-                   in x{_end = (_end x){_character = succ (_character (_end x))}}-                _ -> error "bug in srcspan parser",-            Just decl <- findImportDeclByRange decls range,-            Just ident <- lookupExportMap binding mod-          = [ ( "Add " <> renderImportStyle importStyle <> " to the import list of " <> mod-              , quickFixImportKind' "extend" importStyle-              , uncurry extendImport (unImportStyle importStyle) decl-              )-            | importStyle <- NE.toList $ importStyles ident-            ]-          | otherwise = []-        lookupExportMap binding mod-          | Just match <- Map.lookup binding (getExportsMap exportsMap)-          -- Only for the situation that data constructor name is same as type constructor name,-          -- let ident with parent be in front of the one without.-          , sortedMatch <- sortBy (\ident1 ident2 -> parent ident2 `compare` parent ident1) (Set.toList match)-          , idents <- filter (\ident -> moduleNameText ident == mod && (canUseDatacon || not (isDatacon ident))) sortedMatch-          , (not . null) idents -- Ensure fallback while `idents` is empty-          , ident <- head idents-          = Just ident--            -- fallback to using GHC suggestion even though it is not always correct-          | otherwise-          = Just IdentInfo-                { name = mkVarOcc $ T.unpack binding-                , rendered = binding-                , parent = Nothing-                , isDatacon = False-                , moduleNameText = mod}--data HidingMode-    = HideOthers [ModuleTarget]-    | ToQualified-        Bool-        -- ^ Parenthesised?-        ModuleName--data ModuleTarget-    = ExistingImp (NonEmpty (LImportDecl GhcPs))-    | ImplicitPrelude [LImportDecl GhcPs]--targetImports :: ModuleTarget -> [LImportDecl GhcPs]-targetImports (ExistingImp ne)     = NE.toList ne-targetImports (ImplicitPrelude xs) = xs--oneAndOthers :: [a] -> [(a, [a])]-oneAndOthers = go-    where-        go []       = []-        go (x : xs) = (x, xs) : map (second (x :)) (go xs)--isPreludeImplicit :: DynFlags -> Bool-isPreludeImplicit = xopt Lang.ImplicitPrelude---- | Suggests disambiguation for ambiguous symbols.-suggestImportDisambiguation ::-    DynFlags ->-    Maybe T.Text ->-    ParsedSource ->-    T.Text ->-    Diagnostic ->-    [(T.Text, [Either TextEdit Rewrite])]-suggestImportDisambiguation df (Just txt) ps@(L _ HsModule {hsmodImports}) fileContents diag@Diagnostic {..}-    | Just [ambiguous] <--        matchRegexUnifySpaces-            _message-            "Ambiguous occurrence ‘([^’]+)’"-      , Just modules <--            map last-                <$> allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’"-      , local <- matchRegexUnifySpaces _message "defined at .+:[0-9]+:[0-9]+" =-        suggestions ambiguous modules (isJust local)-    | otherwise = []-    where-        locDic =-            fmap (NE.fromList . DL.toList) $-            Map.fromListWith (<>) $-                map-                    ( \i@(L _ idecl) ->-                        ( T.pack $ moduleNameString $ unLoc $ ideclName idecl-                        , DL.singleton i-                        )-                    )-                    hsmodImports-        toModuleTarget "Prelude"-            | isPreludeImplicit df-             = Just $ ImplicitPrelude $-                maybe [] NE.toList (Map.lookup "Prelude" locDic)-        toModuleTarget mName = ExistingImp <$> Map.lookup mName locDic-        parensed =-            "(" `T.isPrefixOf` T.strip (textInRange _range txt)-        -- > removeAllDuplicates [1, 1, 2, 3, 2] = [3]-        removeAllDuplicates = map head . filter ((==1) <$> length) . group . sort-        hasDuplicate xs = length xs /= length (S.fromList xs)-        suggestions symbol mods local-          | hasDuplicate mods = case mapM toModuleTarget (removeAllDuplicates mods) of-                                  Just targets -> suggestionsImpl symbol (map (, []) targets) local-                                  Nothing      -> []-          | otherwise         = case mapM toModuleTarget mods of-                                  Just targets -> suggestionsImpl symbol (oneAndOthers targets) local-                                  Nothing      -> []-        suggestionsImpl symbol targetsWithRestImports local =-            sortOn fst-            [ ( renderUniquify mode modNameText symbol False-              , disambiguateSymbol ps fileContents diag symbol mode-              )-            | (modTarget, restImports) <- targetsWithRestImports-            , let modName = targetModuleName modTarget-                  modNameText = T.pack $ moduleNameString modName-            , mode <--                [ ToQualified parensed qual-                | ExistingImp imps <- [modTarget]-#if MIN_VERSION_ghc(9,0,0)-                {- HLINT ignore suggestImportDisambiguation "Use nubOrd" -}-                -- TODO: The use of nub here is slow and maybe wrong for UnhelpfulLocation-                -- nubOrd can't be used since SrcSpan is intentionally no Ord-                , L _ qual <- nub $ mapMaybe (ideclAs . unLoc)-#else-                , L _ qual <- nubOrd $ mapMaybe (ideclAs . unLoc)-#endif-                    $ NE.toList imps-                ]-                ++ [ToQualified parensed modName-                    | any (occursUnqualified symbol . unLoc)-                        (targetImports modTarget)-                    || case modTarget of-                        ImplicitPrelude{} -> True-                        _                 -> False-                    ]-                ++ [HideOthers restImports | not (null restImports)]-            ] ++ [ ( renderUniquify mode T.empty symbol True-              , disambiguateSymbol ps fileContents diag symbol mode-              ) | local, not (null targetsWithRestImports)-                , let mode = HideOthers (uncurry (:) (head targetsWithRestImports))-            ]-        renderUniquify HideOthers {} modName symbol local =-            "Use " <> (if local then "local definition" else modName) <> " for " <> symbol <> ", hiding other imports"-        renderUniquify (ToQualified _ qual) _ symbol _ =-            "Replace with qualified: "-                <> T.pack (moduleNameString qual)-                <> "."-                <> symbol-suggestImportDisambiguation _ _ _ _ _ = []--occursUnqualified :: T.Text -> ImportDecl GhcPs -> Bool-occursUnqualified symbol ImportDecl{..}-    | isNothing ideclAs = Just False /=-            -- I don't find this particularly comprehensible,-            -- but HLint suggested me to do so...-        (ideclHiding <&> \(isHiding, L _ ents) ->-            let occurs = any ((symbol `symbolOccursIn`) . unLoc) ents-            in isHiding && not occurs || not isHiding && occurs-        )-occursUnqualified _ _ = False--symbolOccursIn :: T.Text -> IE GhcPs -> Bool-symbolOccursIn symb = any ((== symb). printOutputable) . ieNames--targetModuleName :: ModuleTarget -> ModuleName-targetModuleName ImplicitPrelude{} = mkModuleName "Prelude"-targetModuleName (ExistingImp (L _ ImportDecl{..} :| _)) =-    unLoc ideclName-targetModuleName (ExistingImp _) =-    error "Cannot happen!"--disambiguateSymbol ::-    ParsedSource ->-    T.Text ->-    Diagnostic ->-    T.Text ->-    HidingMode ->-    [Either TextEdit Rewrite]-disambiguateSymbol pm fileContents Diagnostic {..} (T.unpack -> symbol) = \case-    (HideOthers hiddens0) ->-        [ Right $ hideSymbol symbol idecl-        | ExistingImp idecls <- hiddens0-        , idecl <- NE.toList idecls-        ]-            ++ mconcat-                [ if null imps-                    then maybeToList $ Left . snd <$> newImportToEdit (hideImplicitPreludeSymbol $ T.pack symbol) pm fileContents-                    else Right . hideSymbol symbol <$> imps-                | ImplicitPrelude imps <- hiddens0-                ]-    (ToQualified parensed qualMod) ->-        let occSym = mkVarOcc symbol-            rdr = Qual qualMod occSym-         in Right <$> [ if parensed-                then Rewrite (rangeToSrcSpan "<dummy>" _range) $ \df ->-                    liftParseAST @(HsExpr GhcPs) df $-                    T.unpack $ printOutputable $-                        HsVar @GhcPs noExtField $-                            reLocA $ L (mkGeneralSrcSpan  "") rdr-                else Rewrite (rangeToSrcSpan "<dummy>" _range) $ \df ->-                    liftParseAST @RdrName df $-                    T.unpack $ printOutputable $ L (mkGeneralSrcSpan  "") rdr-            ]-findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs)-findImportDeclByRange xs range = find (\(L (locA -> l) _)-> srcSpanToRange l == Just range) xs--suggestFixConstructorImport :: Diagnostic -> [(T.Text, TextEdit)]-suggestFixConstructorImport Diagnostic{_range=_range,..}-    -- ‘Success’ is a data constructor of ‘Result’-    -- To import it use-    -- import Data.Aeson.Types( Result( Success ) )-    -- or-    -- import Data.Aeson.Types( Result(..) ) (lsp-ui)-  | Just [constructor, typ] <--    matchRegexUnifySpaces _message-    "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use"-  = let fixedImport = typ <> "(" <> constructor <> ")"-    in [("Fix import of " <> fixedImport, TextEdit _range fixedImport)]-  | otherwise = []---- | Suggests a constraint for a declaration for which a constraint is missing.-suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)]-suggestConstraint df (makeDeltaAst -> parsedModule) diag@Diagnostic {..}-  | Just missingConstraint <- findMissingConstraint _message-  = let codeAction = if _message =~ ("the type signature for:" :: String)-                        then suggestFunctionConstraint df parsedModule-                        else suggestInstanceConstraint df parsedModule-     in codeAction diag missingConstraint-  | otherwise = []-    where-      findMissingConstraint :: T.Text -> Maybe T.Text-      findMissingConstraint t =-        let regex = "(No instance for|Could not deduce) \\((.+)\\) arising from" -- a use of / a do statement-            regexImplicitParams = "Could not deduce: (\\?.+) arising from a use of"-            match = matchRegexUnifySpaces t regex-            matchImplicitParams = matchRegexUnifySpaces t regexImplicitParams-        in match <|> matchImplicitParams <&> last---- | Suggests a constraint for an instance declaration for which a constraint is missing.-suggestInstanceConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)]--suggestInstanceConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint-  | Just instHead <- instanceHead-  = [(actionTitle missingConstraint , appendConstraint (T.unpack missingConstraint) instHead)]-  | otherwise = []-    where-      instanceHead-        -- Suggests a constraint for an instance declaration with no existing constraints.-        -- • No instance for (Eq a) arising from a use of ‘==’-        --   Possible fix: add (Eq a) to the context of the instance declaration-        -- • In the expression: x == y-        --   In an equation for ‘==’: (Wrap x) == (Wrap y) = x == y-        --   In the instance declaration for ‘Eq (Wrap a)’-        | Just [instanceDeclaration] <- matchRegexUnifySpaces _message "In the instance declaration for ‘([^`]*)’"-        , Just instHead <- findInstanceHead df (T.unpack instanceDeclaration) hsmodDecls-        = Just instHead-        -- Suggests a constraint for an instance declaration with one or more existing constraints.-        -- • Could not deduce (Eq b) arising from a use of ‘==’-        --   from the context: Eq a-        --     bound by the instance declaration at /path/to/Main.hs:7:10-32-        --   Possible fix: add (Eq b) to the context of the instance declaration-        -- • In the second argument of ‘(&&)’, namely ‘x' == y'’-        --   In the expression: x == y && x' == y'-        --   In an equation for ‘==’:-        --       (Pair x x') == (Pair y y') = x == y && x' == y'-        | Just [instanceLineStr, constraintFirstCharStr]-            <- matchRegexUnifySpaces _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)"-#if !MIN_VERSION_ghc(9,2,0)-        , Just (L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = HsIB{hsib_body}})))-#else-        , Just (L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = (unLoc -> HsSig{sig_body = hsib_body})})))-#endif-            <- findDeclContainingLoc (Position (readPositionNumber instanceLineStr) (readPositionNumber constraintFirstCharStr)) hsmodDecls-        = Just hsib_body-        | otherwise-        = Nothing--      readPositionNumber :: T.Text -> UInt-      readPositionNumber = T.unpack >>> read @Integer >>> fromIntegral--      actionTitle :: T.Text -> T.Text-      actionTitle constraint = "Add `" <> constraint-        <> "` to the context of the instance declaration"--suggestImplicitParameter ::-  ParsedSource ->-  Diagnostic ->-  [(T.Text, Rewrite)]-suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _range}-  | Just [implicitT] <- matchRegexUnifySpaces _message "Unbound implicit parameter \\(([^:]+::.+)\\) arising",-    Just (L _ (ValD _ FunBind {fun_id = L _ funId})) <- findDeclContainingLoc (_start _range) hsmodDecls,-#if !MIN_VERSION_ghc(9,2,0)-    Just (TypeSig _ _ HsWC {hswc_body = HsIB {hsib_body}})-#else-    Just (TypeSig _ _ HsWC {hswc_body = (unLoc -> HsSig {sig_body = hsib_body})})-#endif-      <- findSigOfDecl (== funId) hsmodDecls-    =-      [( "Add " <> implicitT <> " to the context of " <> T.pack (printRdrName funId)-        , appendConstraint (T.unpack implicitT) hsib_body)]-  | otherwise = []--findTypeSignatureName :: T.Text -> Maybe T.Text-findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head---- | Suggests a constraint for a type signature with any number of existing constraints.-suggestFunctionConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)]--suggestFunctionConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint--- • No instance for (Eq a) arising from a use of ‘==’---   Possible fix:---     add (Eq a) to the context of---       the type signature for:---         eq :: forall a. a -> a -> Bool--- • In the expression: x == y---   In an equation for ‘eq’: eq x y = x == y---- • Could not deduce (Eq b) arising from a use of ‘==’---   from the context: Eq a---     bound by the type signature for:---                eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool---     at Main.hs:5:1-42---   Possible fix:---     add (Eq b) to the context of---       the type signature for:---         eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool--- • In the second argument of ‘(&&)’, namely ‘y == y'’---   In the expression: x == x' && y == y'---   In an equation for ‘eq’:---       eq (Pair x y) (Pair x' y') = x == x' && y == y'-  | Just typeSignatureName <- findTypeSignatureName _message-#if !MIN_VERSION_ghc(9,2,0)-  , Just (TypeSig _ _ HsWC{hswc_body = HsIB {hsib_body = sig}})-#else-  , Just (TypeSig _ _ HsWC{hswc_body = (unLoc -> HsSig {sig_body = sig})})-#endif-    <- findSigOfDecl ((T.unpack typeSignatureName ==) . showSDoc df . ppr) hsmodDecls-  , title <- actionTitle missingConstraint typeSignatureName-  = [(title, appendConstraint (T.unpack missingConstraint) sig)]-  | otherwise-  = []-    where-      actionTitle :: T.Text -> T.Text -> T.Text-      actionTitle constraint typeSignatureName = "Add `" <> constraint-        <> "` to the context of the type signature for `" <> typeSignatureName <> "`"---- | Suggests the removal of a redundant constraint for a type signature.-removeRedundantConstraints :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)]-removeRedundantConstraints df (L _ HsModule {hsmodDecls}) Diagnostic{..}--- • Redundant constraint: Eq a--- • In the type signature for:---      foo :: forall a. Eq a => a -> a--- • Redundant constraints: (Monoid a, Show a)--- • In the type signature for:---      foo :: forall a. (Num a, Monoid a, Eq a, Show a) => a -> Bool-  -- Account for both "Redundant constraint" and "Redundant constraints".-  | "Redundant constraint" `T.isInfixOf` _message-  , Just typeSignatureName <- findTypeSignatureName _message-#if !MIN_VERSION_ghc(9,2,0)-  , Just (TypeSig _ _ HsWC{hswc_body = HsIB {hsib_body = sig}})-#else-  , Just (TypeSig _ _ HsWC{hswc_body = (unLoc -> HsSig {sig_body = sig})})-#endif-    <- fmap(traceAst "redundantConstraint") $ findSigOfDeclRanged _range hsmodDecls-  , Just redundantConstraintList <- findRedundantConstraints _message-  , rewrite <- removeConstraint (toRemove df redundantConstraintList) sig-      = [(actionTitle redundantConstraintList typeSignatureName, rewrite)]-  | otherwise = []-    where-      toRemove df list a = showSDoc df (ppr a) `elem` (T.unpack <$> list)--      parseConstraints :: T.Text -> [T.Text]-      parseConstraints t = t-        & (T.strip >>> stripConstraintsParens >>> T.splitOn ",")-        <&> T.strip--      stripConstraintsParens :: T.Text -> T.Text-      stripConstraintsParens constraints =-        if "(" `T.isPrefixOf` constraints-           then constraints & T.drop 1 & T.dropEnd 1 & T.strip-           else constraints--{--9.2: "message": "/private/var/folders/4m/d38fhm3936x_gy_9883zbq8h0000gn/T/extra-dir-53173393699/Testing.hs:4:1: warning:-    ⢠Redundant constraints: (Eq a, Show a)-    ⢠In the type signature for:-               foo :: forall a. (Eq a, Show a) => a -> Bool",--9.0: "message": "⢠Redundant constraints: (Eq a, Show a)-    ⢠In the type signature for:-           foo :: forall a. (Eq a, Show a) => a -> Bool",--}-      findRedundantConstraints :: T.Text -> Maybe [T.Text]-      findRedundantConstraints t = t-        & T.lines-        -- In <9.2 it's the first line, in 9.2 it' the second line-        & take 2-        & mapMaybe ((`matchRegexUnifySpaces` "Redundant constraints?: (.+)") . T.strip)-        & listToMaybe-        <&> (head >>> parseConstraints)--      formatConstraints :: [T.Text] -> T.Text-      formatConstraints [] = ""-      formatConstraints [constraint] = constraint-      formatConstraints constraintList = constraintList-        & T.intercalate ", "-        & \cs -> "(" <> cs <> ")"--      actionTitle :: [T.Text] -> T.Text -> T.Text-      actionTitle constraintList typeSignatureName =-        "Remove redundant constraint" <> (if length constraintList == 1 then "" else "s") <> " `"-        <> formatConstraints constraintList-        <> "` from the context of the type signature for `" <> typeSignatureName <> "`"-----------------------------------------------------------------------------------------------------suggestNewOrExtendImportForClassMethod :: ExportsMap -> ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, [Either TextEdit Rewrite])]-suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnostic {_message}-  | Just [methodName, className] <--      matchRegexUnifySpaces-        _message-        "‘([^’]*)’ is not a \\(visible\\) method of class ‘([^’]*)’",-    idents <--      maybe [] (Set.toList . Set.filter (\x -> parent x == Just className)) $-        Map.lookup methodName $ getExportsMap packageExportsMap =-    mconcat $ suggest <$> idents-  | otherwise = []-  where-    suggest identInfo@IdentInfo {moduleNameText}-      | importStyle <- NE.toList $ importStyles identInfo,-        mImportDecl <- findImportDeclByModuleName (hsmodImports $ unLoc ps) (T.unpack moduleNameText) =-        case mImportDecl of-          -- extend-          Just decl ->-            [ ( "Add " <> renderImportStyle style <> " to the import list of " <> moduleNameText,-                quickFixImportKind' "extend" style,-                [Right $ uncurry extendImport (unImportStyle style) decl]-              )-              | style <- importStyle-            ]-          -- new-          _-            | Just (range, indent) <- newImportInsertRange ps fileContents-            ->-             (\(kind, unNewImport -> x) -> (x, kind, [Left $ TextEdit range (x <> "\n" <> T.replicate indent " ")])) <$>-            [ (quickFixImportKind' "new" style, newUnqualImport moduleNameText rendered False)-              | style <- importStyle,-                let rendered = renderImportStyle style-            ]-              <> [(quickFixImportKind "new.all", newImportAll moduleNameText)]-            | otherwise -> []--suggestNewImport :: ExportsMap -> ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)]-suggestNewImport packageExportsMap ps@(L _ HsModule {..}) fileContents Diagnostic{_message}-  | msg <- unifySpaces _message-  , Just thingMissing <- extractNotInScopeName msg-  , qual <- extractQualifiedModuleName msg-  , qual' <--      extractDoesNotExportModuleName msg-        >>= (findImportDeclByModuleName hsmodImports . T.unpack)-        >>= ideclAs . unLoc-        <&> T.pack . moduleNameString . unLoc-  , Just (range, indent) <- newImportInsertRange ps fileContents-  , extendImportSuggestions <- matchRegexUnifySpaces msg-    "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"-  = sortOn fst3 [(imp, kind, TextEdit range (imp <> "\n" <> T.replicate indent " "))-    | (kind, unNewImport -> imp) <- constructNewImportSuggestions packageExportsMap (qual <|> qual', thingMissing) extendImportSuggestions-    ]-suggestNewImport _ _ _ _ = []--constructNewImportSuggestions-  :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> [(CodeActionKind, NewImport)]-constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules = nubOrdOn snd-  [ suggestion-  | Just name <- [T.stripPrefix (maybe "" (<> ".") qual) $ notInScope thingMissing]-  , identInfo <- maybe [] Set.toList $ Map.lookup name (getExportsMap exportsMap)-  , canUseIdent thingMissing identInfo-  , moduleNameText identInfo `notElem` fromMaybe [] notTheseModules-  , suggestion <- renderNewImport identInfo-  ]- where-  renderNewImport :: IdentInfo -> [(CodeActionKind, NewImport)]-  renderNewImport identInfo-    | Just q <- qual-    = [(quickFixImportKind "new.qualified", newQualImport m q)]-    | otherwise-    = [(quickFixImportKind' "new" importStyle, newUnqualImport m (renderImportStyle importStyle) False)-      | importStyle <- NE.toList $ importStyles identInfo] ++-      [(quickFixImportKind "new.all", newImportAll m)]-    where-        m = moduleNameText identInfo--newtype NewImport = NewImport {unNewImport :: T.Text}-  deriving (Show, Eq, Ord)--newImportToEdit :: NewImport -> ParsedSource -> T.Text -> Maybe (T.Text, TextEdit)-newImportToEdit (unNewImport -> imp) ps fileContents-  | Just (range, indent) <- newImportInsertRange ps fileContents-  = Just (imp, TextEdit range (imp <> "\n" <> T.replicate indent " "))-  | otherwise = Nothing---- | Finds the next valid position for inserting a new import declaration--- * If the file already has existing imports it will be inserted under the last of these,--- it is assumed that the existing last import declaration is in a valid position--- * If the file does not have existing imports, but has a (module ... where) declaration,--- the new import will be inserted directly under this declaration (accounting for explicit exports)--- * If the file has neither existing imports nor a module declaration,--- the import will be inserted at line zero if there are no pragmas,--- * otherwise inserted one line after the last file-header pragma-newImportInsertRange :: ParsedSource -> T.Text -> Maybe (Range, Int)-newImportInsertRange (L _ HsModule {..}) fileContents-  |  Just ((l, c), col) <- case hsmodImports of-      [] -> findPositionNoImports (fmap reLoc hsmodName) (fmap reLoc hsmodExports) fileContents-      _  -> findPositionFromImportsOrModuleDecl (map reLoc hsmodImports) last True-  , let insertPos = Position (fromIntegral l) (fromIntegral c)-    = Just (Range insertPos insertPos, col)-  | otherwise = Nothing---- | Insert the import under the Module declaration exports if they exist, otherwise just under the module declaration.--- If no module declaration exists, then no exports will exist either, in that case--- insert the import after any file-header pragmas or at position zero if there are no pragmas-findPositionNoImports :: Maybe (Located ModuleName) -> Maybe (Located [LIE name]) -> T.Text -> Maybe ((Int, Int), Int)-findPositionNoImports Nothing _ fileContents = findNextPragmaPosition fileContents-findPositionNoImports _ (Just hsmodExports) _ = findPositionFromImportsOrModuleDecl hsmodExports id False-findPositionNoImports (Just hsmodName) _ _ = findPositionFromImportsOrModuleDecl hsmodName id False--findPositionFromImportsOrModuleDecl :: HasSrcSpan a => t -> (t -> a) -> Bool -> Maybe ((Int, Int), Int)-findPositionFromImportsOrModuleDecl hsField f hasImports = case getLoc (f hsField) of-  RealSrcSpan s _ ->-    let col = calcCol s-     in Just ((srcLocLine (realSrcSpanEnd s), col), col)-  _ -> Nothing-  where calcCol s = if hasImports then srcLocCol (realSrcSpanStart s) - 1 else 0---- | Find the position one after the last file-header pragma--- Defaults to zero if there are no pragmas in file-findNextPragmaPosition :: T.Text -> Maybe ((Int, Int), Int)-findNextPragmaPosition contents = Just ((lineNumber, 0), 0)-  where-    lineNumber = afterLangPragma . afterOptsGhc $ afterShebang-    afterLangPragma = afterPragma "LANGUAGE" contents'-    afterOptsGhc = afterPragma "OPTIONS_GHC" contents'-    afterShebang = lastLineWithPrefix (T.isPrefixOf "#!") contents' 0-    contents' = T.lines contents--afterPragma :: T.Text -> [T.Text] -> Int -> Int-afterPragma name contents lineNum = lastLineWithPrefix (checkPragma name) contents lineNum--lastLineWithPrefix :: (T.Text -> Bool) -> [T.Text] -> Int -> Int-lastLineWithPrefix p contents lineNum = max lineNum next-  where-    next = maybe lineNum succ $ listToMaybe . reverse $ findIndices p contents--checkPragma :: T.Text -> T.Text -> Bool-checkPragma name = check-  where-    check l = isPragma l && getName l == name-    getName l = T.take (T.length name) $ T.dropWhile isSpace $ T.drop 3 l-    isPragma = T.isPrefixOf "{-#"---- | Construct an import declaration with at most one symbol-newImport-  :: T.Text -- ^ module name-  -> Maybe T.Text -- ^  the symbol-  -> Maybe T.Text -- ^ qualified name-  -> Bool -- ^ the symbol is to be imported or hidden-  -> NewImport-newImport modName mSymbol mQual hiding = NewImport impStmt-  where-     symImp-            | Just symbol <- mSymbol-              , symOcc <- mkVarOcc $ T.unpack symbol =-              " (" <> printOutputable (parenSymOcc symOcc $ ppr symOcc) <> ")"-            | otherwise = ""-     impStmt =-       "import "-         <> maybe "" (const "qualified ") mQual-         <> modName-         <> (if hiding then " hiding" else "")-         <> symImp-         <> maybe "" (\qual -> if modName == qual then "" else " as " <> qual) mQual--newQualImport :: T.Text -> T.Text -> NewImport-newQualImport modName qual = newImport modName Nothing (Just qual) False--newUnqualImport :: T.Text -> T.Text -> Bool -> NewImport-newUnqualImport modName symbol = newImport modName (Just symbol) Nothing--newImportAll :: T.Text -> NewImport-newImportAll modName = newImport modName Nothing Nothing False--hideImplicitPreludeSymbol :: T.Text -> NewImport-hideImplicitPreludeSymbol symbol = newUnqualImport "Prelude" symbol True--canUseIdent :: NotInScope -> IdentInfo -> Bool-canUseIdent NotInScopeDataConstructor{}        = isDatacon-canUseIdent NotInScopeTypeConstructorOrClass{} = not . isDatacon-canUseIdent _                                  = const True--data NotInScope-    = NotInScopeDataConstructor T.Text-    | NotInScopeTypeConstructorOrClass T.Text-    | NotInScopeThing T.Text-    deriving Show--notInScope :: NotInScope -> T.Text-notInScope (NotInScopeDataConstructor t)        = t-notInScope (NotInScopeTypeConstructorOrClass t) = t-notInScope (NotInScopeThing t)                  = t--extractNotInScopeName :: T.Text -> Maybe NotInScope-extractNotInScopeName x-  | Just [name] <- matchRegexUnifySpaces x "Data constructor not in scope: ([^ ]+)"-  = Just $ NotInScopeDataConstructor name-  | Just [name] <- matchRegexUnifySpaces x "Not in scope: data constructor [^‘]*‘([^’]*)’"-  = Just $ NotInScopeDataConstructor name-  | Just [name] <- matchRegexUnifySpaces x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"-  = Just $ NotInScopeTypeConstructorOrClass name-  | Just [name] <- matchRegexUnifySpaces x "ot in scope: \\(([^‘ ]+)\\)"-  = Just $ NotInScopeThing name-  | Just [name] <- matchRegexUnifySpaces x "ot in scope: ([^‘ ]+)"-  = Just $ NotInScopeThing name-  | Just [name] <- matchRegexUnifySpaces x "ot in scope:[^‘]*‘([^’]*)’"-  = Just $ NotInScopeThing name-  | otherwise-  = Nothing--extractQualifiedModuleName :: T.Text -> Maybe T.Text-extractQualifiedModuleName x-  | Just [m] <- matchRegexUnifySpaces x "module named [^‘]*‘([^’]*)’"-  = Just m-  | otherwise-  = Nothing---- | If a module has been imported qualified, and we want to ues the same qualifier for other modules--- which haven't been imported, 'extractQualifiedModuleName' won't work. Thus we need extract the qualifier--- from the imported one.------ For example, we write f = T.putStrLn, where putStrLn comes from Data.Text.IO, with the following import(s):--- 1.--- import qualified Data.Text as T------ Module ‘Data.Text’ does not export ‘putStrLn’.------ 2.--- import qualified Data.Text as T--- import qualified Data.Functor as T------ Neither ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’.------ 3.--- import qualified Data.Text as T--- import qualified Data.Functor as T--- import qualified Data.Function as T------ Neither ‘Data.Function’,---         ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’.-extractDoesNotExportModuleName :: T.Text -> Maybe T.Text-extractDoesNotExportModuleName x-  | Just [m] <--    matchRegexUnifySpaces x "Module ‘([^’]*)’ does not export"-      <|> matchRegexUnifySpaces x "nor ‘([^’]*)’ exports"-  = Just m-  | otherwise-  = Nothing-----------------------------------------------------------------------------------------------------mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit-mkRenameEdit contents range name =-    if maybeIsInfixFunction == Just True-      then TextEdit range ("`" <> name <> "`")-      else TextEdit range name-  where-    maybeIsInfixFunction = do-      curr <- textInRange range <$> contents-      pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr----- | Extract the type and surround it in parentheses except in obviously safe cases.------ Inferring when parentheses are actually needed around the type signature would--- require understanding both the precedence of the context of the hole and of--- the signature itself. Inserting them (almost) unconditionally is ugly but safe.-extractWildCardTypeSignature :: T.Text -> T.Text-extractWildCardTypeSignature msg = (if enclosed || not application then id else bracket) signature-  where-    msgSigPart = snd $ T.breakOnEnd "standing for " msg-    signature = T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') $ msgSigPart-    -- parenthesize type applications, e.g. (Maybe Char)-    application = any isSpace . T.unpack $ signature-    -- do not add extra parentheses to lists, tuples and already parenthesized types-    enclosed = not (T.null signature) && (T.head signature, T.last signature) `elem` [('(',')'), ('[',']')]-    bracket = ("(" `T.append`) . (`T.append` ")")--extractRenamableTerms :: T.Text -> [T.Text]-extractRenamableTerms msg-  -- Account for both "Variable not in scope" and "Not in scope"-  | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg-  | otherwise = []-  where-    extractSuggestions = map getEnclosed-                       . concatMap singleSuggestions-                       . filter isKnownSymbol-                       . T.lines-    singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited-    isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t-    getEnclosed = T.dropWhile (== '‘')-                . T.dropWhileEnd (== '’')-                . T.dropAround (\c -> c /= '‘' && c /= '’')---- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace--- between the end of the range and the next newline), extend the range to take up the whole line.-extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range-extendToWholeLineIfPossible contents range@Range{..} =-    let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents-        extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line-    in if extend then Range _start (Position (_line _end + 1) 0) else range--splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)-splitTextAtPosition (Position (fromIntegral -> row) (fromIntegral -> col)) x-    | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x-    , (preCol, postCol) <- T.splitAt col mid-        = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)-    | otherwise = (x, T.empty)---- | Returns [start .. end[-textInRange :: Range -> T.Text -> T.Text-textInRange (Range (Position (fromIntegral -> startRow) (fromIntegral -> startCol)) (Position (fromIntegral -> endRow) (fromIntegral -> endCol))) text =-    case compare startRow endRow of-      LT ->-        let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine-            (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of-              [] -> ("", [])-              firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)-            maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines-        in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)-      EQ ->-        let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)-        in T.take (endCol - startCol) (T.drop startCol line)-      GT -> ""-    where-      linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)---- | Returns the ranges for a binding in an import declaration-rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range]-rangesForBindingImport ImportDecl{ideclHiding = Just (False, L _ lies)} b =-    concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies-  where-    b' = wrapOperatorInParens b-rangesForBindingImport _ _ = []--wrapOperatorInParens :: String -> String-wrapOperatorInParens x =-  case uncons x of-    Just (h, _t) -> if is_ident h then x else "(" <> x <> ")"-    Nothing      -> mempty--smallerRangesForBindingExport :: [LIE GhcPs] -> String -> [Range]-smallerRangesForBindingExport lies b =-    concatMap (mapMaybe srcSpanToRange . ranges') lies-  where-    unqualify = snd . breakOnEnd "."-    b' = wrapOperatorInParens . unqualify $ b-#if !MIN_VERSION_ghc(9,2,0)-    ranges' (L _ (IEThingWith _ thing _  inners labels))-      | T.unpack (printOutputable thing) == b' = []-      | otherwise =-          [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b']-          ++ [ l' | L l' x <- labels, T.unpack (printOutputable x) == b']-#else-    ranges' (L _ (IEThingWith _ thing _  inners))-      | T.unpack (printOutputable thing) == b' = []-      | otherwise =-          [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b']-#endif-    ranges' _ = []--rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]-rangesForBinding' b (L (locA -> l) x@IEVar{}) | T.unpack (printOutputable x) == b = [l]-rangesForBinding' b (L (locA -> l) x@IEThingAbs{}) | T.unpack (printOutputable x) == b = [l]-rangesForBinding' b (L (locA -> l) (IEThingAll _ x)) | T.unpack (printOutputable x) == b = [l]-#if !MIN_VERSION_ghc(9,2,0)-rangesForBinding' b (L l (IEThingWith _ thing _  inners labels))-#else-rangesForBinding' b (L (locA -> l) (IEThingWith _ thing _  inners))-#endif-    | T.unpack (printOutputable thing) == b = [l]-    | otherwise =-        [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b]-#if !MIN_VERSION_ghc(9,2,0)-        ++ [ l' | L l' x <- labels, T.unpack (printOutputable x) == b]-#endif-rangesForBinding' _ _ = []---- | 'matchRegex' combined with 'unifySpaces'-matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text]-matchRegexUnifySpaces message = matchRegex (unifySpaces message)---- | 'allMatchRegex' combined with 'unifySpaces'-allMatchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [[T.Text]]-allMatchRegexUnifySpaces message =-    allMatchRegex (unifySpaces message)---- | Returns Just (the submatches) for the first capture, or Nothing.-matchRegex :: T.Text -> T.Text -> Maybe [T.Text]-matchRegex message regex = case message =~~ regex of-    Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings-    Nothing                                                -> Nothing---- | Returns Just (all matches) for the first capture, or Nothing.-allMatchRegex :: T.Text -> T.Text -> Maybe [[T.Text]]-allMatchRegex message regex = message =~~ regex---unifySpaces :: T.Text -> T.Text-unifySpaces    = T.unwords . T.words---- functions to help parse multiple import suggestions---- | Returns the first match if found-regexSingleMatch :: T.Text -> T.Text -> Maybe T.Text-regexSingleMatch msg regex = case matchRegexUnifySpaces msg regex of-    Just (h:_) -> Just h-    _          -> Nothing---- | Parses tuples like (‘Data.Map’, (app/ModuleB.hs:2:1-18)) and--- | return (Data.Map, app/ModuleB.hs:2:1-18)-regExPair :: (T.Text, T.Text) -> Maybe (T.Text, T.Text)-regExPair (modname, srcpair) = do-  x <- regexSingleMatch modname "‘([^’]*)’"-  y <- regexSingleMatch srcpair "\\((.*)\\)"-  return (x, y)---- | Process a list of (module_name, filename:src_span) values--- | Eg. [(Data.Map, app/ModuleB.hs:2:1-18), (Data.HashMap.Strict, app/ModuleB.hs:3:1-29)]-regExImports :: T.Text -> Maybe [(T.Text, T.Text)]-regExImports msg = result-  where-    parts = T.words msg-    isPrefix = not . T.isPrefixOf "("-    (mod, srcspan) = partition isPrefix  parts-    -- check we have matching pairs like (Data.Map, (app/src.hs:1:2-18))-    result = if length mod == length srcspan then-               regExPair `traverse` zip mod srcspan-             else Nothing--matchRegExMultipleImports :: T.Text -> Maybe (T.Text, [(T.Text, T.Text)])-matchRegExMultipleImports message = do-  let pat = T.pack "Perhaps you want to add ‘([^’]*)’ to one of these import lists: *(‘.*\\))$"-  (binding, imports) <- case matchRegexUnifySpaces message pat of-                            Just [x, xs] -> Just (x, xs)-                            _            -> Nothing-  imps <- regExImports imports-  return (binding, imps)---- | Possible import styles for an 'IdentInfo'.------ The first 'Text' parameter corresponds to the 'rendered' field of the--- 'IdentInfo'.-data ImportStyle-    = ImportTopLevel T.Text-      -- ^ Import a top-level export from a module, e.g., a function, a type, a-      -- class.-      ---      -- > import M (?)-      ---      -- Some exports that have a parent, like a type-class method or an-      -- associated type/data family, can still be imported as a top-level-      -- import.-      ---      -- Note that this is not the case for constructors, they must always be-      -- imported as part of their parent data type.--    | ImportViaParent T.Text T.Text-      -- ^ Import an export (first parameter) through its parent (second-      -- parameter).-      ---      -- import M (P(?))-      ---      -- @P@ and @?@ can be a data type and a constructor, a class and a method,-      -- a class and an associated type/data family, etc.--    | ImportAllConstructors T.Text-      -- ^ Import all constructors for a specific data type.-      ---      -- import M (P(..))-      ---      -- @P@ can be a data type or a class.-  deriving Show--importStyles :: IdentInfo -> NonEmpty ImportStyle-importStyles IdentInfo {parent, rendered, isDatacon}-  | Just p <- parent-    -- Constructors always have to be imported via their parent data type, but-    -- methods and associated type/data families can also be imported as-    -- top-level exports.-  = ImportViaParent rendered p-      :| [ImportTopLevel rendered | not isDatacon]-      <> [ImportAllConstructors p]-  | otherwise-  = ImportTopLevel rendered :| []---- | Used for adding new imports-renderImportStyle :: ImportStyle -> T.Text-renderImportStyle (ImportTopLevel x)   = x-renderImportStyle (ImportViaParent x p@(T.uncons -> Just ('(', _))) = "type " <> p <> "(" <> x <> ")"-renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")"-renderImportStyle (ImportAllConstructors p) = p <> "(..)"---- | Used for extending import lists-unImportStyle :: ImportStyle -> (Maybe String, String)-unImportStyle (ImportTopLevel x)    = (Nothing, T.unpack x)-unImportStyle (ImportViaParent x y) = (Just $ T.unpack y, T.unpack x)-unImportStyle (ImportAllConstructors x) = (Just $ T.unpack x, wildCardSymbol)---quickFixImportKind' :: T.Text -> ImportStyle -> CodeActionKind-quickFixImportKind' x (ImportTopLevel _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.topLevel"-quickFixImportKind' x (ImportViaParent _ _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.withParent"-quickFixImportKind' x (ImportAllConstructors _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.allConstructors"--quickFixImportKind :: T.Text -> CodeActionKind-quickFixImportKind x = CodeActionUnknown $ "quickfix.import." <> x
− src/Development/IDE/Plugin/CodeAction/Args.hs 
@@ -1,283 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE FlexibleInstances #-}--module Development.IDE.Plugin.CodeAction.Args-  ( CodeActionTitle,-    CodeActionPreferred,-    GhcideCodeActionResult,-    GhcideCodeAction,-    mkGhcideCAPlugin,-    mkGhcideCAsPlugin,-    ToTextEdit (..),-    ToCodeAction (..),-    wrap,-    mkCA,-  )-where--import           Control.Concurrent.STM.Stats                 (readTVarIO)-import           Control.Monad.Reader-import           Control.Monad.Trans.Maybe-import           Data.Either                                  (fromRight)-import qualified Data.HashMap.Strict                          as Map-import           Data.IORef.Extra-import           Data.Maybe                                   (fromMaybe)-import qualified Data.Text                                    as T-import           Development.IDE                              hiding-                                                              (pluginHandlers)-import           Development.IDE.Core.Shake-import           Development.IDE.GHC.Compat-import           Development.IDE.GHC.ExactPrint-import           Development.IDE.Plugin.CodeAction.ExactPrint (Rewrite,-                                                               rewriteToEdit)-import           Development.IDE.Plugin.TypeLenses            (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs),-                                                               GlobalBindingTypeSigsResult)-import           Development.IDE.Spans.LocalBindings          (Bindings)-import           Development.IDE.Types.Exports                (ExportsMap)-import           Development.IDE.Types.Options                (IdeOptions)-import           Ide.Plugin.Config                            (Config)-import           Ide.Types-import qualified Language.LSP.Server                          as LSP-import           Language.LSP.Types--type CodeActionTitle = T.Text--type CodeActionPreferred = Bool--type GhcideCodeActionResult = [(CodeActionTitle, Maybe CodeActionKind, Maybe CodeActionPreferred, [TextEdit])]--type GhcideCodeAction = ReaderT CodeActionArgs IO GhcideCodeActionResult-----------------------------------------------------------------------------------------------------{-# ANN runGhcideCodeAction ("HLint: ignore Move guards forward" :: String) #-}-runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult-runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = List diags}) codeAction = do-  let mbFile = toNormalizedFilePath' <$> uriToFilePath uri-      runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key-  caaGhcSession <- onceIO $ runRule GhcSession-  caaExportsMap <--    onceIO $-      caaGhcSession >>= \case-        Just env -> do-          pkgExports <- envPackageExports env-          localExports <- readTVarIO (exportsMap $ shakeExtras state)-          pure $ localExports <> pkgExports-        _ -> pure mempty-  caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions-  caaParsedModule <- onceIO $ runRule GetParsedModuleWithComments-  caaContents <--    onceIO $-      runRule GetFileContents >>= \case-        Just (_, txt) -> pure txt-        _             -> pure Nothing-  caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule-  caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource-  caaTmr <- onceIO $ runRule TypeCheck-  caaHar <- onceIO $ runRule GetHieAst-  caaBindings <- onceIO $ runRule GetBindings-  caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs-  liftIO $-    concat-      <$> sequence-        [ runReaderT codeAction caa-          | caaDiagnostic <- diags,-            let caa = CodeActionArgs {..}-        ]--mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction)-mkCA title kind isPreferred diags edit =-  InR $ CodeAction title kind (Just $ List diags) isPreferred Nothing (Just edit) Nothing Nothing--mkGhcideCAPlugin :: GhcideCodeAction -> PluginId -> PluginDescriptor IdeState-mkGhcideCAPlugin codeAction plId =-  (defaultPluginDescriptor plId)-    { pluginHandlers = mkPluginHandler STextDocumentCodeAction $-        \state _ params@(CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext {_diagnostics = List diags}) -> do-          results <- runGhcideCodeAction state params codeAction-          pure $-            Right $-              List-                [ mkCA title kind isPreferred diags edit-                  | (title, kind, isPreferred, tedit) <- results,-                    let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing-                ]-    }--mkGhcideCAsPlugin :: [GhcideCodeAction] -> PluginId -> PluginDescriptor IdeState-mkGhcideCAsPlugin codeActions = mkGhcideCAPlugin $ mconcat codeActions-----------------------------------------------------------------------------------------------------class ToTextEdit a where-  toTextEdit :: CodeActionArgs -> a -> IO [TextEdit]--instance ToTextEdit TextEdit where-  toTextEdit _ = pure . pure--instance ToTextEdit Rewrite where-  toTextEdit CodeActionArgs {..} rw = fmap (fromMaybe []) $-    runMaybeT $ do-      df <- MaybeT caaDf-#if !MIN_VERSION_ghc(9,2,0)-      ps <- MaybeT caaAnnSource-      let r = rewriteToEdit df (annsA ps) rw-#else-      let r = rewriteToEdit df rw-#endif-      pure $ fromRight [] r--instance ToTextEdit a => ToTextEdit [a] where-  toTextEdit caa = foldMap (toTextEdit caa)--instance ToTextEdit a => ToTextEdit (Maybe a) where-  toTextEdit caa = maybe (pure []) (toTextEdit caa)--instance (ToTextEdit a, ToTextEdit b) => ToTextEdit (Either a b) where-  toTextEdit caa = either (toTextEdit caa) (toTextEdit caa)-----------------------------------------------------------------------------------------------------data CodeActionArgs = CodeActionArgs-  { caaExportsMap   :: IO ExportsMap,-    caaGhcSession   :: IO (Maybe HscEnvEq),-    caaIdeOptions   :: IO IdeOptions,-    caaParsedModule :: IO (Maybe ParsedModule),-    caaContents     :: IO (Maybe T.Text),-    caaDf           :: IO (Maybe DynFlags),-    caaAnnSource    :: IO (Maybe (Annotated ParsedSource)),-    caaTmr          :: IO (Maybe TcModuleResult),-    caaHar          :: IO (Maybe HieAstResult),-    caaBindings     :: IO (Maybe Bindings),-    caaGblSigs      :: IO (Maybe GlobalBindingTypeSigsResult),-    caaDiagnostic   :: Diagnostic-  }---- | There's no concurrency in each provider,--- so we don't need to be thread-safe here-onceIO :: MonadIO m => IO a -> m (IO a)-onceIO io = do-  var <- liftIO $ newIORef Nothing-  pure $-    readIORef var >>= \case-      Just x -> pure x-      _      -> io >>= \x -> writeIORef' var (Just x) >> pure x-----------------------------------------------------------------------------------------------------wrap :: (ToCodeAction a) => a -> GhcideCodeAction-wrap = toCodeAction--class ToCodeAction a where-  toCodeAction :: a -> GhcideCodeAction--instance ToCodeAction GhcideCodeAction where-  toCodeAction = id--instance Semigroup GhcideCodeAction where-  a <> b = toCodeAction [a, b]--instance Monoid GhcideCodeAction where-  mempty = pure []--instance ToCodeAction a => ToCodeAction [a] where-  toCodeAction = fmap concat . mapM toCodeAction--instance ToCodeAction a => ToCodeAction (Maybe a) where-  toCodeAction = maybe (pure []) toCodeAction--instance ToTextEdit a => ToCodeAction (CodeActionTitle, a) where-  toCodeAction (title, te) = ReaderT $ \caa -> pure . (title,Just CodeActionQuickFix,Nothing,) <$> toTextEdit caa te--instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, a) where-  toCodeAction (title, kind, te) = ReaderT $ \caa -> pure . (title,Just kind,Nothing,) <$> toTextEdit caa te--instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionPreferred, a) where-  toCodeAction (title, isPreferred, te) = ReaderT $ \caa -> pure . (title,Just CodeActionQuickFix,Just isPreferred,) <$> toTextEdit caa te--instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, CodeActionPreferred, a) where-  toCodeAction (title, kind, isPreferred, te) = ReaderT $ \caa -> pure . (title,Just kind,Just isPreferred,) <$> toTextEdit caa te-----------------------------------------------------------------------------------------------------toCodeAction1 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (Maybe a -> r) -> GhcideCodeAction-toCodeAction1 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f--toCodeAction2 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (a -> r) -> GhcideCodeAction-toCodeAction2 get f = ReaderT $ \caa ->-  get caa >>= \case-    Just x -> flip runReaderT caa . toCodeAction . f $ x-    _      -> pure []--toCodeAction3 :: (ToCodeAction r) => (CodeActionArgs -> IO a) -> (a -> r) -> GhcideCodeAction-toCodeAction3 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f---- | this instance returns a delta AST, useful for exactprint transforms-instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where-  toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} ->-    x >>= \case-      Just s -> flip runReaderT caa . toCodeAction . f . astA $ s-      _      -> pure []--instance ToCodeAction r => ToCodeAction (ExportsMap -> r) where-  toCodeAction = toCodeAction3 caaExportsMap--instance ToCodeAction r => ToCodeAction (IdeOptions -> r) where-  toCodeAction = toCodeAction3 caaIdeOptions--instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where-  toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . toCodeAction $ f x--instance ToCodeAction r => ToCodeAction (Maybe ParsedModule -> r) where-  toCodeAction = toCodeAction1 caaParsedModule--instance ToCodeAction r => ToCodeAction (ParsedModule -> r) where-  toCodeAction = toCodeAction2 caaParsedModule--instance ToCodeAction r => ToCodeAction (Maybe T.Text -> r) where-  toCodeAction = toCodeAction1 caaContents--instance ToCodeAction r => ToCodeAction (T.Text -> r) where-  toCodeAction = toCodeAction2 caaContents--instance ToCodeAction r => ToCodeAction (Maybe DynFlags -> r) where-  toCodeAction = toCodeAction1 caaDf--instance ToCodeAction r => ToCodeAction (DynFlags -> r) where-  toCodeAction = toCodeAction2 caaDf--instance ToCodeAction r => ToCodeAction (Maybe (Annotated ParsedSource) -> r) where-  toCodeAction = toCodeAction1 caaAnnSource--instance ToCodeAction r => ToCodeAction (Annotated ParsedSource -> r) where-  toCodeAction = toCodeAction2 caaAnnSource--instance ToCodeAction r => ToCodeAction (Maybe TcModuleResult -> r) where-  toCodeAction = toCodeAction1 caaTmr--instance ToCodeAction r => ToCodeAction (TcModuleResult -> r) where-  toCodeAction = toCodeAction2 caaTmr--instance ToCodeAction r => ToCodeAction (Maybe HieAstResult -> r) where-  toCodeAction = toCodeAction1 caaHar--instance ToCodeAction r => ToCodeAction (HieAstResult -> r) where-  toCodeAction = toCodeAction2 caaHar--instance ToCodeAction r => ToCodeAction (Maybe Bindings -> r) where-  toCodeAction = toCodeAction1 caaBindings--instance ToCodeAction r => ToCodeAction (Bindings -> r) where-  toCodeAction = toCodeAction2 caaBindings--instance ToCodeAction r => ToCodeAction (Maybe GlobalBindingTypeSigsResult -> r) where-  toCodeAction = toCodeAction1 caaGblSigs--instance ToCodeAction r => ToCodeAction (GlobalBindingTypeSigsResult -> r) where-  toCodeAction = toCodeAction2 caaGblSigs--instance ToCodeAction r => ToCodeAction (Maybe HscEnvEq -> r) where-  toCodeAction = toCodeAction1 caaGhcSession--instance ToCodeAction r => ToCodeAction (Maybe HscEnv -> r) where-  toCodeAction = toCodeAction1 ((fmap.fmap.fmap) hscEnv caaGhcSession)
− src/Development/IDE/Plugin/CodeAction/ExactPrint.hs 
@@ -1,698 +0,0 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GADTs              #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE RankNTypes         #-}-{-# LANGUAGE CPP                #-}-{-# LANGUAGE FlexibleInstances #-}--module Development.IDE.Plugin.CodeAction.ExactPrint (-  Rewrite (..),-  rewriteToEdit,-  rewriteToWEdit,-#if !MIN_VERSION_ghc(9,2,0)-  transferAnn,-#endif--  -- * Utilities-  appendConstraint,-  removeConstraint,-  extendImport,-  hideSymbol,-  liftParseAST,--  wildCardSymbol-) where--import           Control.Applicative-import           Control.Monad-import           Control.Monad.Extra                   (whenJust)-import           Control.Monad.Trans-import           Data.Char                             (isAlphaNum)-import           Data.Data                             (Data)-import           Data.Functor-import           Data.Generics                         (listify)-import qualified Data.Map.Strict                       as Map-import           Data.Maybe                            (fromJust, isNothing,-                                                        mapMaybe)-import qualified Data.Text                             as T-import           Development.IDE.GHC.Compat hiding (Annotation)-import           Development.IDE.GHC.Error-import           Development.IDE.GHC.ExactPrint-import           Development.IDE.Spans.Common-import           GHC.Exts                              (IsList (fromList))-import           Language.Haskell.GHC.ExactPrint-#if !MIN_VERSION_ghc(9,2,0)-import qualified Development.IDE.GHC.Compat.Util       as Util-import           Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP),-                                                        KeywordId (G), mkAnnKey)-#else-import Data.Default-import           GHC (AddEpAnn (..), AnnContext (..), AnnParen (..),-                      DeltaPos (SameLine), EpAnn (..), EpaLocation (EpaDelta),-                      IsUnicodeSyntax (NormalSyntax),-                      NameAdornment (NameParens), NameAnn (..), addAnns, ann, emptyComments,-                      reAnnL, AnnList (..), TrailingAnn (AddCommaAnn), addTrailingAnnToA)-#endif-import           Language.LSP.Types-import Development.IDE.GHC.Util-import Data.Bifunctor (first)-import Control.Lens (_head, _last, over)-import GHC.Stack (HasCallStack)------------------------------------------------------------------------------------ | Construct a 'Rewrite', replacing the node at the given 'SrcSpan' with the---   given 'ast'.-data Rewrite where-  Rewrite ::-#if !MIN_VERSION_ghc(9,2,0)-    Annotate ast =>-#else-    (ExactPrint (GenLocated (Anno ast) ast), ResetEntryDP (Anno ast), Outputable (GenLocated (Anno ast) ast), Data (GenLocated (Anno ast) ast)) =>-#endif-    -- | The 'SrcSpan' that we want to rewrite-    SrcSpan ->-    -- | The ast that we want to graft-#if !MIN_VERSION_ghc(9,2,0)-    (DynFlags -> TransformT (Either String) (Located ast)) ->-#else-    (DynFlags -> TransformT (Either String) (GenLocated (Anno ast) ast)) ->-#endif-    Rewrite---------------------------------------------------------------------------------#if MIN_VERSION_ghc(9,2,0)-class ResetEntryDP ann where-    resetEntryDP :: GenLocated ann ast -> GenLocated ann ast-instance {-# OVERLAPPING #-} Default an => ResetEntryDP (SrcAnn an) where-    -- resetEntryDP = flip setEntryDP (SameLine 0)-    resetEntryDP (L srcAnn x) = setEntryDP (L srcAnn{ann=EpAnnNotUsed} x) (SameLine 0)-instance {-# OVERLAPPABLE #-} ResetEntryDP fallback where-    resetEntryDP = id-#endif---- | Convert a 'Rewrite' into a list of '[TextEdit]'.-rewriteToEdit :: HasCallStack =>-  DynFlags ->-#if !MIN_VERSION_ghc(9,2,0)-  Anns ->-#endif-  Rewrite ->-  Either String [TextEdit]-rewriteToEdit dflags-#if !MIN_VERSION_ghc(9,2,0)-              anns-#endif-              (Rewrite dst f) = do-  (ast, anns , _) <- runTransformT-#if !MIN_VERSION_ghc(9,2,0)-                            anns-#endif-                          $ do-    ast <- f dflags-#if !MIN_VERSION_ghc(9,2,0)-    ast <$ setEntryDPT ast (DP (0, 0))-#else-    pure $ traceAst "REWRITE_result" $ resetEntryDP ast-#endif-  let editMap =-        [ TextEdit (fromJust $ srcSpanToRange dst) $-            T.pack $ exactPrint ast-#if !MIN_VERSION_ghc(9,2,0)-                       (fst anns)-#endif-        ]-  pure editMap---- | Convert a 'Rewrite' into a 'WorkspaceEdit'-rewriteToWEdit :: DynFlags-               -> Uri-#if !MIN_VERSION_ghc(9,2,0)-               -> Anns-#endif-               -> Rewrite-               -> Either String WorkspaceEdit-rewriteToWEdit dflags uri-#if !MIN_VERSION_ghc(9,2,0)-               anns-#endif-               r = do-  edits <- rewriteToEdit dflags-#if !MIN_VERSION_ghc(9,2,0)-                         anns-#endif-                         r-  return $-    WorkspaceEdit-      { _changes = Just (fromList [(uri, List edits)])-      , _documentChanges = Nothing-      , _changeAnnotations = Nothing-      }----------------------------------------------------------------------------------#if !MIN_VERSION_ghc(9,2,0)--- | Fix the parentheses around a type context-fixParens ::-  (Monad m, Data (HsType pass), pass ~ GhcPass p0) =>-  Maybe DeltaPos ->-  Maybe DeltaPos ->-  LHsContext pass ->-  TransformT m [LHsType pass]-fixParens-          openDP closeDP-          ctxt@(L _ elems) = do-  -- Paren annotation for type contexts are usually quite screwed up-  -- we remove duplicates and fix negative DPs-  let parens = Map.fromList [(G AnnOpenP, dp00), (G AnnCloseP, dp00)]-  modifyAnnsT $-    Map.adjust-      ( \x ->-          let annsMap = Map.fromList (annsDP x)-           in x-                { annsDP =-                    Map.toList $-                      Map.alter (\_ -> openDP <|> Just dp00) (G AnnOpenP) $-                        Map.alter (\_ -> closeDP <|> Just dp00) (G AnnCloseP) $-                          annsMap <> parens-                }-      )-      (mkAnnKey ctxt)-  return $ map dropHsParTy elems-#endif--dropHsParTy :: LHsType (GhcPass pass) -> LHsType (GhcPass pass)-dropHsParTy (L _ (HsParTy _ ty)) = ty-dropHsParTy other                = other--removeConstraint ::-  -- | Predicate: Which context to drop.-  (LHsType GhcPs -> Bool) ->-  LHsType GhcPs ->-  Rewrite-removeConstraint toRemove = go . traceAst "REMOVE_CONSTRAINT_input"-  where-    go :: LHsType GhcPs -> Rewrite-#if !MIN_VERSION_ghc(9,2,0)-    go (L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite (locA l) $ \_ -> do-#else-    go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt), hst_body}) = Rewrite (locA l) $ \_ -> do-#endif-      let ctxt' = filter (not . toRemove) ctxt-          removeStuff = (toRemove <$> headMaybe ctxt) == Just True-#if !MIN_VERSION_ghc(9,2,0)-      when removeStuff  $-        setEntryDPT hst_body (DP (0, 0))-      return $ L l $ it{hst_ctxt =  L l' ctxt'}-#else-      let hst_body' = if removeStuff then resetEntryDP hst_body else hst_body-      return $ case ctxt' of-          [] -> hst_body'-          _ -> do-            let ctxt'' = over _last (first removeComma) ctxt'-            L l $ it{ hst_ctxt = Just $ L l' ctxt''-                    , hst_body = hst_body'-                    }-#endif-    go (L _ (HsParTy _ ty)) = go ty-    go (L _ HsForAllTy{hst_body}) = go hst_body-    go (L l other) = Rewrite (locA l) $ \_ -> return $ L l other---- | Append a constraint at the end of a type context.---   If no context is present, a new one will be created.-appendConstraint ::-  -- | The new constraint to append-  String ->-  -- | The type signature where the constraint is to be inserted, also assuming annotated-  LHsType GhcPs ->-  Rewrite-appendConstraint constraintT = go . traceAst "appendConstraint"- where-#if !MIN_VERSION_ghc(9,2,0)-  go (L l it@HsQualTy{hst_ctxt = L l' ctxt}) = Rewrite (locA l) $ \df -> do-#else-  go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt)}) = Rewrite (locA l) $ \df -> do-#endif-    constraint <- liftParseAST df constraintT-#if !MIN_VERSION_ghc(9,2,0)-    setEntryDPT constraint (DP (0, 1))--    -- Paren annotations are usually attached to the first and last constraints,-    -- rather than to the constraint list itself, so to preserve them we need to reposition them-    closeParenDP <- lookupAnn (G AnnCloseP) `mapM` lastMaybe ctxt-    openParenDP <- lookupAnn (G AnnOpenP) `mapM` headMaybe ctxt-    ctxt' <- fixParens-                (join openParenDP) (join closeParenDP)-                (L l' ctxt)-    addTrailingCommaT (last ctxt')-    return $ L l $ it{hst_ctxt = L l' $ ctxt' ++ [constraint]}-#else-    constraint <- pure $ setEntryDP constraint (SameLine 1)-    let l'' = (fmap.fmap) (addParensToCtxt close_dp) l'-    -- For singleton constraints, the close Paren DP is attached to an HsPar wrapping the constraint-    -- we have to reposition it manually into the AnnContext-        close_dp = case ctxt of-            [L _ (HsParTy EpAnn{anns=AnnParen{ap_close}} _)] -> Just ap_close-            _ -> Nothing-        ctxt' = over _last (first addComma) $ map dropHsParTy ctxt-    return $ L l $ it{hst_ctxt = Just $ L l'' $ ctxt' ++ [constraint]}-#endif-  go (L _ HsForAllTy{hst_body}) = go hst_body-  go (L _ (HsParTy _ ty)) = go ty-  go ast@(L l _) = Rewrite (locA l) $ \df -> do-    -- there isn't a context, so we must create one-    constraint <- liftParseAST df constraintT-    lContext <- uniqueSrcSpanT-    lTop <- uniqueSrcSpanT-#if !MIN_VERSION_ghc(9,2,0)-    let context = L lContext [constraint]-    addSimpleAnnT context dp00 $-      (G AnnDarrow, DP (0, 1)) :-      concat-        [ [ (G AnnOpenP, dp00)-          , (G AnnCloseP, dp00)-          ]-        | hsTypeNeedsParens sigPrec $ unLoc constraint-        ]-#else-    let context = Just $ reAnnL annCtxt emptyComments $ L lContext [resetEntryDP constraint]-        annCtxt = AnnContext (Just (NormalSyntax, epl 1)) [epl 0 | needsParens] [epl 0 | needsParens]-        needsParens = hsTypeNeedsParens sigPrec $ unLoc constraint-    ast <- pure $ setEntryDP ast (SameLine 1)-#endif--    return $ reLocA $ L lTop $ HsQualTy noExtField context ast--liftParseAST-    :: forall ast l.  (ASTElement l ast, ExactPrint (LocatedAn l ast))-    => DynFlags -> String -> TransformT (Either String) (LocatedAn l ast)-liftParseAST df s = case parseAST df "" s of-#if !MIN_VERSION_ghc(9,2,0)-  Right (anns, x) -> modifyAnnsT (anns <>) $> x-#else-  Right x ->  pure (makeDeltaAst x)-#endif-  Left _          -> lift $ Left $ "No parse: " <> s--#if !MIN_VERSION_ghc(9,2,0)-lookupAnn :: (Data a, Monad m)-          => KeywordId -> Located a -> TransformT m (Maybe DeltaPos)-lookupAnn comment la = do-  anns <- getAnnsT-  return $ Map.lookup (mkAnnKey la) anns >>= lookup comment . annsDP--dp00 :: DeltaPos-dp00 = DP (0, 0)---- | Copy anns attached to a into b with modification, then delete anns of a-transferAnn :: (Data a, Data b) => Located a -> Located b -> (Annotation -> Annotation) -> TransformT (Either String) ()-transferAnn la lb f = do-  anns <- getAnnsT-  let oldKey = mkAnnKey la-      newKey = mkAnnKey lb-  oldValue <- liftMaybe "Unable to find ann" $ Map.lookup oldKey anns-  putAnnsT $ Map.delete oldKey $ Map.insert newKey (f oldValue) anns--#endif--headMaybe :: [a] -> Maybe a-headMaybe []      = Nothing-headMaybe (a : _) = Just a--lastMaybe :: [a] -> Maybe a-lastMaybe []    = Nothing-lastMaybe other = Just $ last other--liftMaybe :: String -> Maybe a -> TransformT (Either String) a-liftMaybe _ (Just x) = return x-liftMaybe s _        = lift $ Left s---------------------------------------------------------------------------------extendImport :: Maybe String -> String -> LImportDecl GhcPs -> Rewrite-extendImport mparent identifier lDecl@(L l _) =-  Rewrite (locA l) $ \df -> do-    case mparent of-      -- This will also work for `ImportAllConstructors`-      Just parent -> extendImportViaParent df parent identifier lDecl-      _           -> extendImportTopLevel identifier lDecl---- | Add an identifier or a data type to import list. Expects a Delta AST------ extendImportTopLevel "foo" AST:------ import A --> Error--- import A (foo) --> Error--- import A (bar) --> import A (bar, foo)-extendImportTopLevel ::-  -- | rendered-  String ->-  LImportDecl GhcPs ->-  TransformT (Either String) (LImportDecl GhcPs)-extendImportTopLevel thing (L l it@ImportDecl{..})-  | Just (hide, L l' lies) <- ideclHiding-    , hasSibling <- not $ null lies = do-    src <- uniqueSrcSpanT-    top <- uniqueSrcSpanT-    let rdr = reLocA $ L src $ mkRdrUnqual $ mkVarOcc thing-    let alreadyImported =-          printOutputable (occName (unLoc rdr))-            `elem` map (printOutputable @OccName) (listify (const True) lies)-    when alreadyImported $-      lift (Left $ thing <> " already imported")--    let lie = reLocA $ L src $ IEName rdr-        x = reLocA $ L top $ IEVar noExtField lie--    if x `elem` lies-      then lift (Left $ thing <> " already imported")-      else do-#if !MIN_VERSION_ghc(9,2,0)-        when hasSibling $-          addTrailingCommaT (last lies)-        addSimpleAnnT x (DP (0, if hasSibling then 1 else 0)) []-        addSimpleAnnT rdr dp00 [(G AnnVal, dp00)]-        -- Parens are attachted to `lies`, so if `lies` was empty previously,-        -- we need change the ann key from `[]` to `:` to keep parens and other anns.-        unless hasSibling $-          transferAnn (L l' lies) (L l' [x]) id-        return $ L l it{ideclHiding = Just (hide, L l' $ lies ++ [x])}-#else-        lies' <- addCommaInImportList lies x-        return $ L l it{ideclHiding = Just (hide, L l' lies')}-#endif-extendImportTopLevel _ _ = lift $ Left "Unable to extend the import list"--wildCardSymbol :: String-wildCardSymbol = ".."---- | Add an identifier with its parent to import list------ extendImportViaParent "Bar" "Cons" AST:------ import A --> Error--- import A (Bar(..)) --> Error--- import A (Bar(Cons)) --> Error--- import A () --> import A (Bar(Cons))--- import A (Foo, Bar) --> import A (Foo, Bar(Cons))--- import A (Foo, Bar()) --> import A (Foo, Bar(Cons))------ extendImportViaParent "Bar" ".." AST:--- import A () --> import A (Bar(..))--- import A (Foo, Bar) -> import A (Foo, Bar(..))--- import A (Foo, Bar()) -> import A (Foo, Bar(..))-extendImportViaParent ::-  DynFlags ->-  -- | parent (already parenthesized if needs)-  String ->-  -- | rendered child-  String ->-  LImportDecl GhcPs ->-  TransformT (Either String) (LImportDecl GhcPs)-extendImportViaParent df parent child (L l it@ImportDecl{..})-  | Just (hide, L l' lies) <- ideclHiding = go hide l' [] lies- where-  go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie))) : _xs)-    | parent == unIEWrappedName ie = lift . Left $ child <> " already included in " <> parent <> " imports"-  go hide l' pre (lAbs@(L ll' (IEThingAbs _ absIE@(L _ ie))) : xs)-    -- ThingAbs ie => ThingWith ie child-    | parent == unIEWrappedName ie = do-      srcChild <- uniqueSrcSpanT-      let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child-          childLIE = reLocA $ L srcChild $ IEName childRdr-#if !MIN_VERSION_ghc(9,2,0)-          x :: LIE GhcPs = L ll' $ IEThingWith noExtField absIE NoIEWildcard [childLIE] []-      -- take anns from ThingAbs, and attatch parens to it-      transferAnn lAbs x $ \old -> old{annsDP = annsDP old ++ [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, dp00)]}-      addSimpleAnnT childRdr dp00 [(G AnnVal, dp00)]-#else-          x :: LIE GhcPs = L ll' $ IEThingWith (addAnns mempty [AddEpAnn AnnOpenP (EpaDelta (SameLine 1) []), AddEpAnn AnnCloseP def] emptyComments) absIE NoIEWildcard [childLIE]-#endif-      return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [x] ++ xs)}-#if !MIN_VERSION_ghc(9,2,0)-  go hide l' pre ((L l'' (IEThingWith _ twIE@(L _ ie) _ lies' _)) : xs)-#else-  go hide l' pre ((L l'' (IEThingWith l''' twIE@(L _ ie) _ lies')) : xs)-#endif-    -- ThingWith ie lies' => ThingWith ie (lies' ++ [child])-    | parent == unIEWrappedName ie-    , child == wildCardSymbol = do-#if MIN_VERSION_ghc(9,2,0)-        let it' = it{ideclHiding = Just (hide, lies)}-            thing = IEThingWith newl twIE (IEWildcard 2) []-            newl = (\ann -> ann ++ [(AddEpAnn AnnDotdot d0)]) <$> l'''-            lies = L l' $ reverse pre ++ [L l'' thing] ++ xs-        return $ L l it'-#else-        let thing = L l'' (IEThingWith noExtField twIE (IEWildcard 2)  [] [])-        modifyAnnsT (Map.map (\ann -> ann{annsDP = (G AnnDotdot, dp00) : annsDP ann}))-        return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [thing] ++ xs)}-#endif-    | parent == unIEWrappedName ie-    , hasSibling <- not $ null lies' =-      do-        srcChild <- uniqueSrcSpanT-        let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child-#if MIN_VERSION_ghc(9,2,0)-        childRdr <- pure $ setEntryDP childRdr $ SameLine $ if hasSibling then 1 else 0-#endif-        let alreadyImported =-              printOutputable (occName (unLoc childRdr))-                `elem` map (printOutputable @OccName) (listify (const True) lies')-        when alreadyImported $-          lift (Left $ child <> " already included in " <> parent <> " imports")--        let childLIE = reLocA $ L srcChild $ IEName childRdr-#if !MIN_VERSION_ghc(9,2,0)-        when hasSibling $-          addTrailingCommaT (last lies')-        addSimpleAnnT childRdr (DP (0, if hasSibling then 1 else 0)) [(G AnnVal, dp00)]-        return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [L l'' (IEThingWith noExtField twIE NoIEWildcard (lies' ++ [childLIE]) [])] ++ xs)}-#else-        let it' = it{ideclHiding = Just (hide, lies)}-            lies = L l' $ reverse pre ++-                [L l'' (IEThingWith l''' twIE NoIEWildcard (over _last fixLast lies' ++ [childLIE]))] ++ xs-            fixLast = if hasSibling then first addComma else id-        return $ L l it'-#endif-  go hide l' pre (x : xs) = go hide l' (x : pre) xs-  go hide l' pre []-    | hasSibling <- not $ null pre = do-      -- [] => ThingWith parent [child]-      l'' <- uniqueSrcSpanT-      srcParent <- uniqueSrcSpanT-      srcChild <- uniqueSrcSpanT-      parentRdr <- liftParseAST df parent-      let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child-          isParentOperator = hasParen parent-#if !MIN_VERSION_ghc(9,2,0)-      when hasSibling $-        addTrailingCommaT (head pre)-      let parentLIE = L srcParent (if isParentOperator then IEType parentRdr else IEName parentRdr)-          childLIE = reLocA $ L srcChild $ IEName childRdr-#else-      let parentLIE = reLocA $ L srcParent $ (if isParentOperator then IEType (epl 0) parentRdr' else IEName parentRdr')-          parentRdr' = modifyAnns parentRdr $ \case-              it@NameAnn{nann_adornment = NameParens} -> it{nann_open = epl 1}-              other -> other-          childLIE = reLocA $ L srcChild $ IEName childRdr-#endif-#if !MIN_VERSION_ghc(9,2,0)-          x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith noExtField parentLIE NoIEWildcard [childLIE] []-      -- Add AnnType for the parent if it's parenthesized (type operator)-      when isParentOperator $-        addSimpleAnnT parentLIE (DP (0, 0)) [(G AnnType, DP (0, 0))]-      addSimpleAnnT parentRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP 1 isParentOperator-      addSimpleAnnT childRdr (DP (0, 0)) [(G AnnVal, dp00)]-      addSimpleAnnT x (DP (0, 0)) [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, DP (0, 0))]-      -- Parens are attachted to `pre`, so if `pre` was empty previously,-      -- we need change the ann key from `[]` to `:` to keep parens and other anns.-      unless hasSibling $-        transferAnn (L l' $ reverse pre) (L l' [x]) id--      let lies' = reverse pre ++ [x]-#else-          listAnn = epAnn srcParent [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)]-          x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith listAnn parentLIE NoIEWildcard [childLIE]--      let hasSibling = not (null pre)-      lies' <- addCommaInImportList (reverse pre) x-#endif-      return $ L l it{ideclHiding = Just (hide, L l' lies')}-extendImportViaParent _ _ _ _ = lift $ Left "Unable to extend the import list via parent"--#if MIN_VERSION_ghc(9,2,0)--- Add an item in an import list, taking care of adding comma if needed.-addCommaInImportList :: Monad m =>-  -- | Initial list-  [LocatedAn AnnListItem a]-  -- | Additionnal item-  -> LocatedAn AnnListItem a-  -> m [LocatedAn AnnListItem a]-addCommaInImportList lies x = do-  let hasSibling = not (null lies)-  -- Add the space before the comma-  x <- pure $ setEntryDP x (SameLine $ if hasSibling then 1 else 0)--  -- Add the comma (if needed)-  let-    fixLast = if hasSibling then first addComma else id-    lies' = over _last fixLast lies ++ [x]--  pure lies'-#endif--unIEWrappedName :: IEWrappedName (IdP GhcPs) -> String-unIEWrappedName (occName -> occ) = T.unpack $ printOutputable $ parenSymOcc occ (ppr occ)--hasParen :: String -> Bool-hasParen ('(' : _) = True-hasParen _         = False--#if !MIN_VERSION_ghc(9,2,0)-unqalDP :: Int -> Bool -> [(KeywordId, DeltaPos)]-unqalDP c paren =-  ( if paren-      then \x -> (G AnnOpenP, DP (0, c)) : x : [(G AnnCloseP, dp00)]-      else pure-  )-    (G AnnVal, dp00)-#endif------------------------------------------------------------------------------------ | Hide a symbol from import declaration-hideSymbol ::-  String -> LImportDecl GhcPs -> Rewrite-hideSymbol symbol lidecl@(L loc ImportDecl{..}) =-  case ideclHiding of-    Nothing -> Rewrite (locA loc) $ extendHiding symbol lidecl Nothing-    Just (True, hides) -> Rewrite (locA loc) $ extendHiding symbol lidecl (Just hides)-    Just (False, imports) -> Rewrite (locA loc) $ deleteFromImport symbol lidecl imports-hideSymbol _ (L _ (XImportDecl _)) =-  error "cannot happen"--extendHiding ::-  String ->-  LImportDecl GhcPs ->-#if !MIN_VERSION_ghc(9,2,0)-  Maybe (Located [LIE GhcPs]) ->-#else-  Maybe (XRec GhcPs [LIE GhcPs]) ->-#endif-  DynFlags ->-  TransformT (Either String) (LImportDecl GhcPs)-extendHiding symbol (L l idecls) mlies df = do-  L l' lies <- case mlies of-#if !MIN_VERSION_ghc(9,2,0)-    Nothing -> flip L [] <$> uniqueSrcSpanT-#else-    Nothing -> do-        src <- uniqueSrcSpanT-        let ann = noAnnSrcSpanDP0 src-            ann' = flip (fmap.fmap) ann $ \x -> x-                {al_rest = [AddEpAnn AnnHiding (epl 1)]-                ,al_open = Just $ AddEpAnn AnnOpenP (epl 1)-                ,al_close = Just $ AddEpAnn AnnCloseP (epl 0)-                }-        return $ L ann' []-#endif-    Just pr -> pure pr-  let hasSibling = not $ null lies-  src <- uniqueSrcSpanT-  top <- uniqueSrcSpanT-  rdr <- liftParseAST df symbol-#if MIN_VERSION_ghc(9,2,0)-  rdr <- pure $ modifyAnns rdr $ addParens (isOperator $ unLoc rdr)-#endif-  let lie = reLocA $ L src $ IEName rdr-      x = reLocA $ L top $ IEVar noExtField lie-#if MIN_VERSION_ghc(9,2,0)-  x <- pure $ if hasSibling then first addComma x else x-  lies <- pure $ over _head (`setEntryDP` SameLine 1) lies-#endif-#if !MIN_VERSION_ghc(9,2,0)-      singleHide = L l' [x]-  when (isNothing mlies) $ do-    addSimpleAnnT-      singleHide-      dp00-      [ (G AnnHiding, DP (0, 1))-      , (G AnnOpenP, DP (0, 1))-      , (G AnnCloseP, DP (0, 0))-      ]-  addSimpleAnnT x (DP (0, 0)) []-  addSimpleAnnT rdr dp00 $ unqalDP 0 $ isOperator $ unLoc rdr-  if hasSibling-    then do-      addTrailingCommaT x-      addSimpleAnnT (head lies) (DP (0, 1)) []-      unless (null $ tail lies) $-        addTrailingCommaT (head lies) -- Why we need this?-    else forM_ mlies $ \lies0 -> do-      transferAnn lies0 singleHide id-#endif-  return $ L l idecls{ideclHiding = Just (True, L l' $ x : lies)}- where-  isOperator = not . all isAlphaNum . occNameString . rdrNameOcc--deleteFromImport ::-  String ->-  LImportDecl GhcPs ->-#if !MIN_VERSION_ghc(9,2,0)-  Located [LIE GhcPs] ->-#else-  XRec GhcPs [LIE GhcPs] ->-#endif-  DynFlags ->-  TransformT (Either String) (LImportDecl GhcPs)-deleteFromImport (T.pack -> symbol) (L l idecl) llies@(L lieLoc lies) _ = do-  let edited = L lieLoc deletedLies-      lidecl' =-        L l $-          idecl-            { ideclHiding = Just (False, edited)-            }-#if !MIN_VERSION_ghc(9,2,0)-  -- avoid import A (foo,)-  whenJust (lastMaybe deletedLies) removeTrailingCommaT-  when (not (null lies) && null deletedLies) $ do-    transferAnn llies edited id-    addSimpleAnnT-      edited-      dp00-      [ (G AnnOpenP, DP (0, 1))-      , (G AnnCloseP, DP (0, 0))-      ]-#endif-  pure lidecl'- where-  deletedLies =-#if MIN_VERSION_ghc(9,2,0)-    over _last removeTrailingComma $-#endif-    mapMaybe killLie lies-  killLie :: LIE GhcPs -> Maybe (LIE GhcPs)-  killLie v@(L _ (IEVar _ (L _ (unqualIEWrapName -> nam))))-    | nam == symbol = Nothing-    | otherwise = Just v-  killLie v@(L _ (IEThingAbs _ (L _ (unqualIEWrapName -> nam))))-    | nam == symbol = Nothing-    | otherwise = Just v-#if !MIN_VERSION_ghc(9,2,0)-  killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons flds))-#else-  killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons))-#endif-    | nam == symbol = Nothing-    | otherwise =-      Just $-        L lieL $-          IEThingWith-            xt-            ty-            wild-            (filter ((/= symbol) . unqualIEWrapName . unLoc) cons)-#if !MIN_VERSION_ghc(9,2,0)-            (filter ((/= symbol) . T.pack . Util.unpackFS . flLabel . unLoc) flds)-#endif-  killLie v = Just v
− src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs 
@@ -1,141 +0,0 @@--- | Position indexed streams of characters-module Development.IDE.Plugin.CodeAction.PositionIndexed-  ( PositionIndexed-  , PositionIndexedString-  , indexedByPosition-  , indexedByPositionStartingFrom-  , extendAllToIncludeCommaIfPossible-  , extendToIncludePreviousNewlineIfPossible-  , mergeRanges-  )-where--import           Data.Char-import           Data.List-import           Language.LSP.Types (Position (Position),-                                     Range (Range, _end, _start))--type PositionIndexed a = [(Position, a)]--type PositionIndexedString = PositionIndexed Char---- | Add position indexing to a String.------   > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡---   >   [ ((0,0),'h')---   >   , ((0,1),'e')---   >   , ((0,2),'y')---   >   , ((0,3),'\n')---   >   , ((1,0),' ')---   >   , ((1,1),'h')---   >   , ((1,2),'o')---   >   ]-indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString-indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where-  f (_, []) = Nothing-  f (p@(Position l _), '\n' : rest) =-    Just ((p, '\n'), (Position (l + 1) 0, rest))-  f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest))---- | Add position indexing to a String.------   > indexedByPosition = indexedByPositionStartingFrom (Position 0 0)-indexedByPosition :: String -> PositionIndexedString-indexedByPosition = indexedByPositionStartingFrom (Position 0 0)---- | Returns a tuple (before, contents, after) if the range is present.---   The range is present only if both its start and end positions are present-unconsRange-  :: Range-  -> PositionIndexed a-  -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a)-unconsRange Range {..} indexedString-  | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString-  , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest-  = Just (before, mid, after)-  | otherwise-  = Nothing---- | Strips out all the positions included in the range.---   Returns 'Nothing' if the start or end of the range are not included in the input.-stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a)-stripRange r s = case unconsRange r s of-  Just (b, _, a) -> Just (b ++ a)-  Nothing        -> Nothing---- | Returns the smallest possible set of disjoint ranges that is equivalent to the input.---   Assumes input ranges are sorted on the start positions.-mergeRanges :: [Range] -> [Range]-mergeRanges (r : r' : rest)-  |-    -- r' is contained in r-    _end r > _end r'   = mergeRanges (r : rest)-  |-    -- r and r' are overlapping-    _end r > _start r' = mergeRanges (r { _end = _end r' } : rest)--  | otherwise          = r : mergeRanges (r' : rest)-mergeRanges other = other---- | Returns a sorted list of ranges with extended selections including preceding or trailing commas------ @---   a, |b|,  c  ===> a|, b|,  c---   a,  b,  |c| ===> a,  b|,  c|---   a, |b|, |c| ===> a|, b||, c|--- @------ If 'acceptNoComma' is enabled, additional ranges are returned------ @---   |a|       ===> |a|---   |a|,  |b| ===> |a,|  |b|--- @-extendAllToIncludeCommaIfPossible :: Bool -> PositionIndexedString -> [Range] -> [Range]-extendAllToIncludeCommaIfPossible acceptNoComma indexedString =-  mergeRanges . go indexedString . sortOn _start- where-  go _ [] = []-  go input (r : rr)-    | r' : _ <- extendToIncludeCommaIfPossible acceptNoComma input r-    , Just input' <- stripRange r' input-    = r' : go input' rr-    | otherwise-    = go input rr--extendToIncludeCommaIfPossible :: Bool -> PositionIndexedString -> Range -> [Range]-extendToIncludeCommaIfPossible acceptNoComma indexedString range-  | Just (before, _, after) <- unconsRange range indexedString-  , after' <- dropWhile (isSpace . snd) after-  , before' <- dropWhile (isSpace . snd) (reverse before)-  =-    -- a, |b|, c ===> a|, b|, c-    [ range { _start = start' } | (start', ',') : _ <- [before'] ]-    ++-    -- a, |b|, c ===> a, |b, |c-    [ range { _end = end' }-    | (_, ',') : rest <- [after']-    , (end', _) : _ <- pure $ dropWhile (isSpace . snd) rest-    ]-    ++-    ([range | acceptNoComma])-  | otherwise-  = [range]--extendToIncludePreviousNewlineIfPossible :: PositionIndexedString -> Range -> Range-extendToIncludePreviousNewlineIfPossible indexedString range-  | Just (before, _, _) <- unconsRange range indexedString-  , maybeFirstSpacePos <- lastSpacePos $ reverse before-  = case maybeFirstSpacePos of-      Nothing  -> range-      Just pos -> range { _start = pos }-  | otherwise = range-  where-    lastSpacePos :: PositionIndexedString -> Maybe Position-    lastSpacePos [] = Nothing-    lastSpacePos ((pos, c):xs) =-      if not $ isSpace c-      then Nothing -- didn't find any space-      else case xs of-              (y:ys) | isSpace $ snd y -> lastSpacePos (y:ys)-              _                        -> Just pos
src/Development/IDE/Plugin/Completions.hs view
@@ -1,96 +1,111 @@-{-# LANGUAGE CPP          #-}-{-# LANGUAGE RankNTypes   #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP              #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TypeFamilies     #-}  module Development.IDE.Plugin.Completions     ( descriptor     , Log(..)+    , ghcideCompletionsPluginPriority     ) where -import           Control.Concurrent.Async                     (concurrently)-import           Control.Concurrent.STM.Stats                 (readTVarIO)-import           Control.Monad.Extra+import           Control.Concurrent.Async                 (concurrently)+import           Control.Concurrent.STM.Stats             (readTVarIO)+import           Control.Lens                             ((&), (.~), (?~)) import           Control.Monad.IO.Class-import           Control.Monad.Trans.Maybe-import           Data.Aeson-import qualified Data.HashMap.Strict                          as Map-import qualified Data.HashSet                                 as Set-import           Data.List                                    (find)+import           Control.Monad.Trans.Except               (ExceptT (ExceptT),+                                                           withExceptT)+import qualified Data.HashMap.Strict                      as Map+import qualified Data.HashSet                             as Set import           Data.Maybe-import qualified Data.Text                                    as T+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-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.Core.Service             hiding (Log, LogShake)+import           Development.IDE.Core.Shake               hiding (Log,+                                                           knownTargets)+import qualified Development.IDE.Core.Shake               as Shake import           Development.IDE.GHC.Compat-import           Development.IDE.GHC.Error                    (rangeToSrcSpan)-import           Development.IDE.GHC.ExactPrint               (GetAnnotatedParsedSource (GetAnnotatedParsedSource))-import           Development.IDE.GHC.Util                     (printOutputable)+import           Development.IDE.GHC.Util import           Development.IDE.Graph-import           Development.IDE.Plugin.CodeAction            (newImport,-                                                               newImportToEdit)-import           Development.IDE.Plugin.CodeAction.ExactPrint import           Development.IDE.Plugin.Completions.Logic import           Development.IDE.Plugin.Completions.Types+import           Development.IDE.Spans.Common+import           Development.IDE.Spans.Documentation import           Development.IDE.Types.Exports-import           Development.IDE.Types.HscEnvEq               (HscEnvEq (envPackageExports),-                                                               hscEnv)-import qualified Development.IDE.Types.KnownTargets           as KT+import           Development.IDE.Types.HscEnvEq           (HscEnvEq (envPackageExports, envVisibleModuleNames),+                                                           hscEnv)+import qualified Development.IDE.Types.KnownTargets       as KT import           Development.IDE.Types.Location-import           Development.IDE.Types.Logger                 (Pretty (pretty),-                                                               Recorder,-                                                               WithPriority,-                                                               cmapWithPrio)-import           GHC.Exts                                     (fromList, toList)-import           Ide.Plugin.Config                            (Config)+import           Ide.Logger                               (Pretty (pretty),+                                                           Recorder,+                                                           WithPriority,+                                                           cmapWithPrio)+import           Ide.Plugin.Error import           Ide.Types-import qualified Language.LSP.Server                          as LSP-import           Language.LSP.Types-import qualified Language.LSP.VFS                             as VFS-import           Text.Fuzzy.Parallel                          (Scored (..))+import qualified Language.LSP.Protocol.Lens               as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import           Numeric.Natural+import           Prelude                                  hiding (mod)+import           Text.Fuzzy.Parallel                      (Scored (..)) +import           Development.IDE.Core.Rules               (usePropertyAction)++import qualified Ide.Plugin.Config                        as Config++import qualified GHC.LanguageExtensions                   as LangExt+ data Log = LogShake Shake.Log deriving Show  instance Pretty Log where   pretty = \case-    LogShake log -> pretty log+    LogShake msg -> pretty msg +ghcideCompletionsPluginPriority :: Natural+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 STextDocumentCompletion getCompletionsLSP-  , pluginCommands = [extendImportCommand]+  , 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 () produceCompletions recorder = do     define (cmapWithPrio LogShake recorder) $ \LocalCompletions file -> do         let uri = fromNormalizedUri $ normalizedFilePathToUri file-        pm <- useWithStale GetParsedModule file-        case pm of+        mbPm <- useWithStale GetParsedModule file+        case mbPm of             Just (pm, _) -> do                 let cdata = localCompletionsForParsedModule uri pm                 return ([], Just cdata)             _ -> return ([], Nothing)     define (cmapWithPrio LogShake recorder) $ \NonLocalCompletions file -> do         -- For non local completions we avoid depending on the parsed module,-        -- synthetizing a fake module with an empty body from the buffer+        -- synthesizing a fake module with an empty body from the buffer         -- in the ModSummary, which preserves all the imports         ms <- fmap fst <$> useWithStale GetModSummaryWithoutTimestamps file-        sess <- fmap fst <$> useWithStale GhcSessionDeps file+        mbSess <- fmap fst <$> useWithStale GhcSessionDeps file -        case (ms, sess) of+        case (ms, mbSess) of             (Just ModSummaryResult{..}, Just sess) -> do               let env = hscEnv sess               -- We do this to be able to provide completions of items that are not restricted to the explicit list               (global, inScope) <- liftIO $ tcRnImportDecls env (dropListFromImportDecl <$> msrImports) `concurrently` tcRnImportDecls env msrImports               case (global, inScope) of                   ((_, Just globalEnv), (_, Just inScopeEnv)) -> do+                      visibleMods <- liftIO $ fmap (fromMaybe []) $ envVisibleModuleNames sess                       let uri = fromNormalizedUri $ normalizedFilePathToUri file-                      cdata <- liftIO $ cacheDataProducer uri sess (ms_mod msrModSummary) globalEnv inScopeEnv msrImports+                      let cdata = cacheDataProducer uri visibleMods (ms_mod msrModSummary) globalEnv inScopeEnv msrImports                       return ([], Just cdata)                   (_diag, _) ->                       return ([], Nothing)@@ -99,35 +114,66 @@ -- Drop any explicit imports in ImportDecl if not hidden dropListFromImportDecl :: LImportDecl GhcPs -> LImportDecl GhcPs dropListFromImportDecl iDecl = let-    f d@ImportDecl {ideclHiding} = case ideclHiding of-        Just (False, _) -> d {ideclHiding=Nothing}+    f d@ImportDecl {ideclImportList} = case ideclImportList of+        Just (Exactly, _) -> d {ideclImportList=Nothing}         -- if hiding or Nothing just return d-        _               -> d+        _                 -> d     f x = x     in f <$> iDecl +resolveCompletion :: ResolveFunction IdeState CompletionResolveData Method_CompletionItemResolve+resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} uri (CompletionResolveData _ needType (NameDetails mod occ)) =+  do+    file <- getNormalizedFilePathE uri+    (sess,_) <- withExceptT (const PluginStaleResolve)+                  $ runIdeActionE "CompletionResolve.GhcSessionDeps" (shakeExtras ide)+                  $ useWithStaleFastE GhcSessionDeps file+    let nc = ideNc $ shakeExtras ide+    name <- liftIO $ lookupNameCache nc mod occ+    mdkm <- liftIO $ runIdeAction "CompletionResolve.GetDocMap" (shakeExtras ide) $ useWithStaleFast GetDocMap file+    let (dm,km) = case mdkm of+          Just (DKMap docMap tyThingMap _argDocMap, _) -> (docMap,tyThingMap)+          Nothing                                      -> (mempty, mempty)+    doc <- case lookupNameEnv dm name of+      Just doc -> pure $ spanDocToMarkdown doc+      Nothing -> liftIO $ spanDocToMarkdown . fst <$> getDocumentationTryGhc (hscEnv sess) name+    typ <- case lookupNameEnv km name of+      _ | not needType -> pure Nothing+      Just ty -> pure (safeTyThingType True ty)+      Nothing -> do+        (safeTyThingType True =<<) <$> liftIO (lookupName (hscEnv sess) name)+    let det1 = case typ of+          Just ty -> Just (":: " <> printOutputable (stripForall ty) <> "\n")+          Nothing -> Nothing+        doc1 = case _documentation of+          Just (InR (MarkupContent MarkupKind_Markdown old)) ->+            InR $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator (old:doc)+          _ -> InR $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator doc+    pure  (comp & L.detail .~ (det1 <> _detail)+                & L.documentation ?~ doc1)+  where+    stripForall ty = case splitForAllTyCoVars ty of+      (_,res) -> res+ -- | Generate code actions.-getCompletionsLSP-    :: IdeState-    -> PluginId-    -> CompletionParams-    -> LSP.LspM Config (Either ResponseError (ResponseResult TextDocumentCompletion))+getCompletionsLSP :: PluginMethodHandler IdeState Method_TextDocumentCompletion getCompletionsLSP ide plId   CompletionParams{_textDocument=TextDocumentIdentifier uri                   ,_position=position-                  ,_context=completionContext} = do-    contents <- LSP.getVirtualFile $ toNormalizedUri uri-    fmap Right $ case (contents, uriToFilePath' uri) of+                  ,_context=completionContext} = ExceptT $ do+    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) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do+        (ideOpts, compls, moduleExports, astres) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do             opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide             localCompls <- useWithStaleFast LocalCompletions npath             nonLocalCompls <- useWithStaleFast NonLocalCompletions npath             pm <- useWithStaleFast GetParsedModule npath             binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath             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@@ -136,26 +182,42 @@             let exportsMap = fromMaybe mempty packageExportsMap <> projectExportsMap              let moduleExports = getModuleExportsMap exportsMap-                exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . Map.elems . getExportsMap $ exportsMap+                exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . nonDetOccEnvElts . getExportsMap $ exportsMap                 exportsCompls = mempty{anyQualCompls = exportsCompItems}             let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls <> Just lModules -            pure (opts, fmap (,pm,binds) compls, moduleExports)+            -- get HieAst if OverloadedRecordDot is enabled+            let uses_overloaded_record_dot (ms_hspp_opts . msrModSummary -> dflags) = xopt LangExt.OverloadedRecordDot dflags+            ms <- fmap fst <$> useWithStaleFast GetModSummaryWithoutTimestamps npath+            astres <- case ms of+              Just ms' | uses_overloaded_record_dot ms'+                ->  useWithStaleFast GetHieAst npath+              _ -> return Nothing++            pure (opts, fmap (,pm,binds) compls, moduleExports, astres)         case compls of           Just (cci', parsedMod, bindMap) -> do-            pfix <- VFS.getCompletionPrefix position cnts+            let pfix = getCompletionPrefixFromRope position cnts             case (pfix, completionContext) of-              (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})-                -> return (InL $ List [])-              (Just pfix', _) -> do+              (PosPrefixInfo _ "" _ _, Just CompletionContext { _triggerCharacter = Just "."})+                -> return (InL [])+              (_, _) -> do                 let clientCaps = clientCapabilities $ shakeExtras ide-                config <- getCompletionsConfig plId-                allCompletions <- liftIO $ getCompletions plId ideOpts cci' parsedMod bindMap pfix' clientCaps config moduleExports-                pure $ InL (List $ orderedCompletions allCompletions)-              _ -> return (InL $ List [])-          _ -> return (InL $ List [])-      _ -> return (InL $ List [])+                    plugins = idePlugins $ shakeExtras ide+                config <- liftIO $ runAction "" ide $ getCompletionsConfig plId +                let allCompletions = getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports uri+                pure $ InL (orderedCompletions allCompletions)+          _ -> return (InL [])+      _ -> return (InL [])++getCompletionsConfig :: PluginId -> Action CompletionsConfig+getCompletionsConfig pId =+  CompletionsConfig+    <$> usePropertyAction #snippetsOn pId properties+    <*> usePropertyAction #autoExtendOn pId properties+    <*> (Config.maxCompletions <$> getClientConfigAction)+ {- COMPLETION SORTING    We return an ordered set of completions (local -> nonlocal -> global).    Ordering is important because local/nonlocal are import aware, whereas@@ -195,79 +257,3 @@ toModueNameText target = case target of   KT.TargetModule m -> T.pack $ moduleNameString m   _                 -> T.empty--extendImportCommand :: PluginCommand IdeState-extendImportCommand =-  PluginCommand (CommandId extendImportCommandId) "additional edits for a completion" extendImportHandler--extendImportHandler :: CommandFunction IdeState ExtendImport-extendImportHandler ideState edit@ExtendImport {..} = do-  res <- liftIO $ runMaybeT $ extendImportHandler' ideState edit-  whenJust res $ \(nfp, wedit@WorkspaceEdit {_changes}) -> do-    let (_, List (head -> TextEdit {_range})) = fromJust $ _changes >>= listToMaybe . toList-        srcSpan = rangeToSrcSpan nfp _range-    LSP.sendNotification SWindowShowMessage $-      ShowMessageParams MtInfo $-        "Import "-          <> maybe ("‘" <> newThing) (\x -> "‘" <> x <> " (" <> newThing <> ")") thingParent-          <> "’ from "-          <> importName-          <> " (at "-          <> printOutputable srcSpan-          <> ")"-    void $ LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())-  return $ Right Null--extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit)-extendImportHandler' ideState ExtendImport {..}-  | Just fp <- uriToFilePath doc,-    nfp <- toNormalizedFilePath' fp =-    do-      (ModSummaryResult {..}, ps, contents) <- MaybeT $ liftIO $-        runAction "extend import" ideState $-          runMaybeT $ do-            -- We want accurate edits, so do not use stale data here-            msr <- MaybeT $ use GetModSummaryWithoutTimestamps nfp-            ps <- MaybeT $ use GetAnnotatedParsedSource nfp-            (_, contents) <- MaybeT $ use GetFileContents nfp-            return (msr, ps, contents)-      let df = ms_hspp_opts msrModSummary-          wantedModule = mkModuleName (T.unpack importName)-          wantedQual = mkModuleName . T.unpack <$> importQual-          existingImport = find (isWantedModule wantedModule wantedQual) msrImports-      case existingImport of-        Just imp -> do-            fmap (nfp,) $ liftEither $-              rewriteToWEdit df doc-#if !MIN_VERSION_ghc(9,2,0)-                (annsA ps)-#endif-                $-                  extendImport (T.unpack <$> thingParent) (T.unpack newThing) (makeDeltaAst imp)-        Nothing -> do-            let n = newImport importName sym importQual False-                sym = if isNothing importQual then Just it else Nothing-                it = case thingParent of-                  Nothing -> newThing-                  Just p  -> p <> "(" <> newThing <> ")"-            t <- liftMaybe $ snd <$> newImportToEdit-                n-                (astA ps)-                (fromMaybe "" contents)-            return (nfp, WorkspaceEdit {_changes=Just (fromList [(doc,List [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing})-  | otherwise =-    mzero--isWantedModule :: ModuleName -> Maybe ModuleName -> GenLocated l (ImportDecl GhcPs) -> Bool-isWantedModule wantedModule Nothing (L _ it@ImportDecl{ideclName, ideclHiding = Just (False, _)}) =-    not (isQualifiedImport it) && unLoc ideclName == wantedModule-isWantedModule wantedModule (Just qual) (L _ ImportDecl{ideclAs, ideclName, ideclHiding = Just (False, _)}) =-    unLoc ideclName == wantedModule && (wantedModule == qual || (unLoc . reLoc <$> ideclAs) == Just qual)-isWantedModule _ _ _ = False--liftMaybe :: Monad m => Maybe a -> MaybeT m a-liftMaybe a = MaybeT $ pure a--liftEither :: Monad m => Either e a -> MaybeT m a-liftEither (Left _)  = mzero-liftEither (Right x) = return x
src/Development/IDE/Plugin/Completions/Logic.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE CPP        #-}-{-# LANGUAGE GADTs      #-}-{-# LANGUAGE MultiWayIf #-}-+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiWayIf            #-}  -- Mostly taken from "haskell-ide-engine" module Development.IDE.Plugin.Completions.Logic (@@ -10,62 +10,74 @@ , localCompletionsForParsedModule , getCompletions , fromIdentInfo+, getCompletionPrefix+, getCompletionPrefixFromRope ) where  import           Control.Applicative-import           Data.Char                                (isUpper)+import           Control.Lens                             hiding (Context,+                                                           parts)+import           Data.Char                                (isAlphaNum, isUpper)+import           Data.Default                             (def) import           Data.Generics import           Data.List.Extra                          as List hiding                                                                   (stripPrefix) import qualified Data.Map                                 as Map+import           Prelude                                  hiding (mod)  import           Data.Maybe                               (fromMaybe, isJust,+                                                           isNothing,+                                                           listToMaybe,                                                            mapMaybe) import qualified Data.Text                                as T import qualified Text.Fuzzy.Parallel                      as Fuzzy  import           Control.Monad import           Data.Aeson                               (ToJSON (toJSON))-import           Data.Either                              (fromRight) import           Data.Function                            (on)-import           Data.Functor-import qualified Data.HashMap.Strict                      as HM+ 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.Compile import           Development.IDE.Core.PositionMapping-import           Development.IDE.GHC.Compat               hiding (ppr)+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.Error import           Development.IDE.GHC.Util import           Development.IDE.Plugin.Completions.Types-import           Development.IDE.Spans.Common-import           Development.IDE.Spans.Documentation import           Development.IDE.Spans.LocalBindings import           Development.IDE.Types.Exports-import           Development.IDE.Types.HscEnvEq import           Development.IDE.Types.Options--#if MIN_VERSION_ghc(9,2,0)-import           GHC.Plugins                              (Depth (AllTheWay),-                                                           defaultSDocContext,-                                                           mkUserStyle,-                                                           neverQualify,-                                                           renderWithContext,-                                                           sdocStyle)-#endif+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.LSP.Types-import           Language.LSP.Types.Capabilities+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.Mixed               as Rope+import           Development.IDE                          hiding (line)++import           Development.IDE.Spans.AtPoint            (pointCommand)+++import qualified Development.IDE.Plugin.Completions.Types as C+import           GHC.Plugins                              (Depth (AllTheWay),+                                                           mkUserStyle,+                                                           neverQualify,+                                                           sdocStyle)++-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++ -- Chunk size used for parallelizing fuzzy matching chunkSize :: Int chunkSize = 1000@@ -129,60 +141,60 @@         importGo :: GHC.LImportDecl GhcPs -> Maybe Context         importGo (L (locA -> r) impDecl)           | pos `isInsideSrcSpan` r-          = importInline importModuleName (fmap (fmap reLoc) $ ideclHiding impDecl)+          = importInline importModuleName (fmap (fmap reLoc) $ ideclImportList impDecl)           <|> Just (ImportContext importModuleName)            | otherwise = Nothing           where importModuleName = moduleNameString $ unLoc $ ideclName impDecl -        importInline :: String -> Maybe (Bool,  GHC.Located [LIE GhcPs]) -> Maybe Context-        importInline modName (Just (True, L r _))+        -- importInline :: String -> Maybe (Bool,  GHC.Located [LIE GhcPs]) -> Maybe Context+        importInline modName (Just (EverythingBut, L r _))           | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName           | otherwise = Nothing-        importInline modName (Just (False, L r _))++        importInline modName (Just (Exactly, L r _))           | pos `isInsideSrcSpan` r = Just $ ImportListContext modName           | otherwise = Nothing+         importInline _ _ = Nothing -occNameToComKind :: Maybe T.Text -> OccName -> CompletionItemKind-occNameToComKind ty oc+occNameToComKind :: OccName -> CompletionItemKind+occNameToComKind oc   | isVarOcc  oc = case occNameString oc of-                     i:_ | isUpper i -> CiConstructor-                     _               -> CiFunction-  | isTcOcc   oc = case ty of-                     Just t-                       | "Constraint" `T.isSuffixOf` t-                       -> CiInterface-                     _ -> CiStruct-  | isDataOcc oc = CiConstructor-  | otherwise    = CiVariable+                     i:_ | isUpper i -> CompletionItemKind_Constructor+                     _               -> CompletionItemKind_Function+  | isTcOcc   oc = CompletionItemKind_Struct+  | isDataOcc oc = CompletionItemKind_Constructor+  | otherwise    = CompletionItemKind_Variable   showModName :: ModuleName -> T.Text showModName = T.pack . moduleNameString -mkCompl :: PluginId -> IdeOptions -> CompItem -> CompletionItem+mkCompl :: Maybe PluginId -- ^ Plugin to use for the extend import command+        -> IdeOptions -> Uri -> CompItem -> CompletionItem mkCompl   pId-  IdeOptions {..}+  _ideOptions+  uri   CI     { compKind,       isInfix,       insertText,       provenance,-      typeText,       label,-      docs,-      additionalTextEdits+      typeText,+      additionalTextEdits,+      nameDetails     } = do-  let mbCommand = mkAdditionalEditsCommand pId `fmap` additionalTextEdits+  let mbCommand = mkAdditionalEditsCommand pId =<< additionalTextEdits   let ci = CompletionItem                  {_label = label,                   _kind = kind,                   _tags = Nothing,                   _detail =                       case (typeText, provenance) of-                          (Just t,_) | not(T.null t) -> Just $ colon <> t+                          (Just t,_) | not(T.null t) -> Just $ ":: " <> t                           (_, ImportedFrom mod)      -> Just $ "from " <> mod                           (_, DefinedIn mod)         -> Just $ "from " <> mod                           _                          -> Nothing,@@ -191,25 +203,26 @@                   _preselect = Nothing,                   _sortText = Nothing,                   _filterText = Nothing,-                  _insertText = Just insertText,-                  _insertTextFormat = Just Snippet,+                  _insertText = Just $ snippetToText insertText,+                  _insertTextFormat = Just InsertTextFormat_Snippet,                   _insertTextMode = Nothing,                   _textEdit = Nothing,                   _additionalTextEdits = Nothing,                   _commitCharacters = Nothing,                   _command = mbCommand,-                  _xdata = Nothing}+                  _data_ = toJSON <$> fmap (CompletionResolveData uri (isNothing typeText)) nameDetails,+                  _labelDetails = Nothing,+                  _textEditText = Nothing}   removeSnippetsWhen (isJust isInfix) ci    where kind = Just compKind-        docs' = imported : spanDocToMarkdown docs+        docs' = [imported]         imported = case provenance of           Local pos  -> "*Defined at " <> pprLineCol (srcSpanStart pos) <> " in this module*\n"           ImportedFrom mod -> "*Imported from '" <> mod <> "'*\n"           DefinedIn mod -> "*Defined in '" <> mod <> "'*\n"-        colon = if optNewColonConvention then ": " else ":: "-        documentation = Just $ CompletionDocMarkup $-                        MarkupContent MkMarkdown $+        documentation = Just $ InR $+                        MarkupContent MarkupKind_Markdown $                         T.intercalate sectionSeparator docs'         pprLineCol :: SrcLoc -> T.Text         pprLineCol (UnhelpfulLoc fs) = T.pack $ unpackFS fs@@ -217,26 +230,23 @@             "line " <> printOutputable (srcLocLine loc) <> ", column " <> printOutputable (srcLocCol loc)  -mkAdditionalEditsCommand :: PluginId -> ExtendImport -> Command-mkAdditionalEditsCommand pId edits =-  mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits])+mkAdditionalEditsCommand :: Maybe PluginId -> ExtendImport -> Maybe Command+mkAdditionalEditsCommand (Just pId) edits = Just $ mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits])+mkAdditionalEditsCommand _ _ = Nothing -mkNameCompItem :: Uri -> Maybe T.Text -> OccName -> Provenance -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem-mkNameCompItem doc thingParent origName provenance thingType isInfix docs !imp = CI {..}+mkNameCompItem :: Uri -> Maybe T.Text -> OccName -> Provenance -> Maybe Backtick -> Maybe (LImportDecl GhcPs) -> Maybe Module -> CompItem+mkNameCompItem doc thingParent origName provenance isInfix !imp mod = CI {..}   where-    compKind = occNameToComKind typeText origName+    isLocalCompletion = True+    nameDetails = NameDetails <$> mod <*> pure origName+    compKind = occNameToComKind origName     isTypeCompl = isTcOcc origName-    label = stripPrefix $ printOutputable origName-    insertText = case isInfix of-            Nothing -> case getArgText <$> thingType of-                            Nothing      -> label-                            Just argText -> if T.null argText then label else label <> " " <> argText-            Just LeftSide -> label <> "`"-+    typeText = Nothing+    label = stripOccNamePrefix $ printOutputable origName+    insertText = snippetText $ case isInfix of+            Nothing         -> label+            Just LeftSide   -> label <> "`"             Just Surrounded -> label-    typeText-          | Just t <- thingType = Just . stripForall $ printOutputable t-          | otherwise = Nothing     additionalTextEdits =       imp <&> \x ->         ExtendImport@@ -247,109 +257,66 @@             newThing = printOutputable origName           } -    stripForall :: T.Text -> T.Text-    stripForall t-      | T.isPrefixOf "forall" t =-        -- We drop 2 to remove the '.' and the space after it-        T.drop 2 (T.dropWhile (/= '.') t)-      | otherwise               = t--    getArgText :: Type -> T.Text-    getArgText typ = argText-      where-        argTypes = getArgs typ-        argText :: T.Text-        argText = mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes-        snippet :: Int -> Type -> T.Text-        snippet i t = case t of-            (TyVarTy _)     -> noParensSnippet-            (LitTy _)       -> noParensSnippet-            (TyConApp _ []) -> noParensSnippet-            _               -> snippetText i ("(" <> showForSnippet t <> ")")-            where-                noParensSnippet = snippetText i (showForSnippet t)-                snippetText i t = "${" <> T.pack (show i) <> ":" <> t <> "}"-        getArgs :: Type -> [Type]-        getArgs t-          | isPredTy t = []-          | isDictTy t = []-          | isForAllTy t = getArgs $ snd (splitForAllTyCoVars t)-          | isFunTy t =-            let (args, ret) = splitFunTys t-              in if isForAllTy ret-                  then getArgs ret-                  else Prelude.filter (not . isDictTy) $ map scaledThing args-          | isPiTy t = getArgs $ snd (splitPiTys t)-#if MIN_VERSION_ghc(8,10,0)-          | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t-          = getArgs t-#else-          | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t)-#endif-          | otherwise = []-- showForSnippet :: Outputable a => a -> T.Text-#if MIN_VERSION_ghc(9,2,0) showForSnippet x = T.pack $ renderWithContext ctxt $ GHC.ppr x -- FIXme     where         ctxt = defaultSDocContext{sdocStyle = mkUserStyle neverQualify AllTheWay}-#else-showForSnippet x = printOutputable x-#endif  mkModCompl :: T.Text -> CompletionItem mkModCompl label =-  CompletionItem label (Just CiModule) Nothing Nothing-    Nothing Nothing Nothing Nothing Nothing Nothing Nothing-    Nothing Nothing Nothing Nothing Nothing Nothing+    defaultCompletionItemWithLabel label+    & L.kind ?~ CompletionItemKind_Module  mkModuleFunctionImport :: T.Text -> T.Text -> CompletionItem mkModuleFunctionImport moduleName label =-  CompletionItem label (Just CiFunction) Nothing (Just moduleName)-    Nothing Nothing Nothing Nothing Nothing Nothing Nothing-    Nothing Nothing Nothing Nothing Nothing Nothing+    defaultCompletionItemWithLabel label+    & L.kind ?~ CompletionItemKind_Function+    & L.detail ?~ moduleName  mkImportCompl :: T.Text -> T.Text -> CompletionItem mkImportCompl enteredQual label =-  CompletionItem m (Just CiModule) Nothing (Just label)-    Nothing Nothing Nothing Nothing Nothing Nothing Nothing-    Nothing Nothing Nothing Nothing Nothing Nothing+    defaultCompletionItemWithLabel m+    & L.kind ?~ CompletionItemKind_Module+    & L.detail ?~ label   where     m = fromMaybe "" (T.stripPrefix enteredQual label)  mkExtCompl :: T.Text -> CompletionItem mkExtCompl label =-  CompletionItem label (Just CiKeyword) Nothing Nothing-    Nothing Nothing Nothing Nothing Nothing Nothing Nothing-    Nothing Nothing Nothing Nothing Nothing Nothing+    defaultCompletionItemWithLabel label+    & L.kind ?~ CompletionItemKind_Keyword +defaultCompletionItemWithLabel :: T.Text -> CompletionItem+defaultCompletionItemWithLabel label =+    CompletionItem label def def def def def def def def def+                         def def def def def def def def def  fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem-fromIdentInfo doc IdentInfo{..} q = CI-  { compKind= occNameToComKind Nothing name-  , insertText=rendered-  , provenance = DefinedIn moduleNameText-  , typeText=Nothing-  , label=rendered+fromIdentInfo doc identInfo@IdentInfo{..} q = CI+  { compKind= occNameToComKind name+  , insertText= snippetText rend+  , provenance = DefinedIn mod+  , label=rend+  , typeText = Nothing   , isInfix=Nothing-  , docs=emptySpanDoc-  , isTypeCompl= not isDatacon && isUpper (T.head rendered)+  , isTypeCompl= not (isDatacon identInfo) && isUpper (T.head rend)   , additionalTextEdits= Just $         ExtendImport           { doc,-            thingParent = parent,-            importName = moduleNameText,+            thingParent = occNameText <$> parent,+            importName = mod,             importQual = q,-            newThing = rendered+            newThing = rend           }+  , nameDetails = Nothing+  , isLocalCompletion = False   }+  where rend = rendered identInfo+        mod = moduleNameText identInfo -cacheDataProducer :: Uri -> HscEnvEq -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> IO CachedCompletions-cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do-  let-      packageState = hscEnv env-      curModName = moduleName curMod+cacheDataProducer :: Uri -> [ModuleName] -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> CachedCompletions+cacheDataProducer uri visibleMods curMod globalEnv inScopeEnv limports =+  let curModName = moduleName curMod       curModNameText = printOutputable curModName        importMap = Map.fromList [ (l, imp) | imp@(L (locA -> (RealSrcSpan l _)) _) <- limports ]@@ -360,73 +327,76 @@       asNamespace :: ImportDecl GhcPs -> ModuleName       asNamespace imp = maybe (iDeclToModName imp) GHC.unLoc (ideclAs imp)       -- Full canonical names of imported modules-      importDeclerations = map unLoc limports+      importDeclarations = map unLoc limports         -- The given namespaces for the imported modules (ie. full name, or alias if used)-      allModNamesAsNS = map (showModName . asNamespace) importDeclerations+      allModNamesAsNS = map (showModName . asNamespace) importDeclarations        rdrElts = globalRdrEnvElts globalEnv -      foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b-      foldMapM f xs = foldr step return xs mempty where-        step x r z = f x >>= \y -> r $! z `mappend` y+      -- construct a map from Parents(type) to their fields+      fieldMap = Map.fromListWith (++) $ flip mapMaybe rdrElts $ \elt -> do+        par <- greParent_maybe elt+#if MIN_VERSION_ghc(9,7,0)+        flbl <- greFieldLabel_maybe elt+#else+        flbl <- greFieldLabel elt+#endif+        Just (par,[flLabel flbl]) -      getCompls :: [GlobalRdrElt] -> IO ([CompItem],QualCompls)-      getCompls = foldMapM getComplsForOne+      getCompls :: [GlobalRdrElt] -> ([CompItem],QualCompls)+      getCompls = foldMap getComplsForOne -      getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls)+      getComplsForOne :: GlobalRdrElt -> ([CompItem],QualCompls)       getComplsForOne (GRE n par True _) =-          (, mempty) <$> toCompItem par curMod curModNameText n Nothing+          (toCompItem par curMod curModNameText n Nothing, mempty)       getComplsForOne (GRE n par False prov) =-        flip foldMapM (map is_decl prov) $ \spec -> do+        flip foldMap (map is_decl prov) $ \spec ->           let originalImportDecl = do                 -- we don't want to extend import if it's already in scope                 guard . null $ lookupGRE_Name inScopeEnv n                 -- or if it doesn't have a real location                 loc <- realSpan $ is_dloc spec                 Map.lookup loc importMap-          compItem <- toCompItem par curMod (printOutputable $ is_mod spec) n originalImportDecl-          let unqual+              compItem = toCompItem par curMod (printOutputable $ is_mod spec) n originalImportDecl+              unqual                 | is_qual spec = []                 | otherwise = compItem               qual                 | is_qual spec = Map.singleton asMod compItem                 | otherwise = Map.fromList [(asMod,compItem),(origMod,compItem)]               asMod = showModName (is_as spec)+#if MIN_VERSION_ghc(9,8,0)+              origMod = showModName (moduleName $ is_mod spec)+#else               origMod = showModName (is_mod spec)-          return (unqual,QualCompls qual)+#endif+          in (unqual,QualCompls qual) -      toCompItem :: Parent -> Module -> T.Text -> Name -> Maybe (LImportDecl GhcPs) -> IO [CompItem]-      toCompItem par m mn n imp' = do-        docs <- getDocumentationTryGhc packageState curMod n+      toCompItem :: Parent -> Module -> T.Text -> Name -> Maybe (LImportDecl GhcPs) -> [CompItem]+      toCompItem par _ mn n imp' =+        -- docs <- getDocumentationTryGhc packageState curMod n         let (mbParent, originName) = case par of                             NoParent -> (Nothing, nameOccName n)                             ParentIs n' -> (Just . T.pack $ printName n', nameOccName n)-#if !MIN_VERSION_ghc(9,2,0)-                            FldParent n' lbl -> (Just . T.pack $ printName n', maybe (nameOccName n) mkVarOccFS lbl)-#endif-        tys <- catchSrcErrors (hsc_dflags packageState) "completion" $ do-                name' <- lookupName packageState m n-                return ( name' >>= safeTyThingType-                       , guard (isJust mbParent) >> name' >>= safeTyThingForRecord-                       )-        let (ty, record_ty) = fromRight (Nothing, Nothing) tys--        let recordCompls = case record_ty of-                Just (ctxStr, flds) | not (null flds) ->-                    [mkRecordSnippetCompItem uri mbParent ctxStr flds (ImportedFrom mn) docs imp']+            recordCompls = case par of+                ParentIs parent+                  | isDataConName n+                  , Just flds <- Map.lookup parent fieldMap+                  , not (null flds) ->+                    [mkRecordSnippetCompItem uri mbParent (printOutputable originName) (map (T.pack . unpackFS . field_label) flds) (ImportedFrom mn) imp']                 _ -> [] -        return $ mkNameCompItem uri mbParent originName (ImportedFrom mn) ty Nothing docs imp'-               : recordCompls+        in mkNameCompItem uri mbParent originName (ImportedFrom mn) Nothing imp' (nameModule_maybe n)+           : recordCompls -  (unquals,quals) <- getCompls rdrElts+      (unquals,quals) = getCompls rdrElts -  -- The list of all importable Modules from all packages-  moduleNames <- maybe [] (map showModName) <$> envVisibleModuleNames env+      -- The list of all importable Modules from all packages+      moduleNames = map showModName visibleMods -  return $ CC+  in CC     { allModNamesAsNS = allModNamesAsNS     , unqualCompls = unquals     , qualCompls = quals@@ -445,75 +415,72 @@         }   where     typeSigIds = Set.fromList-        [ id+        [ identifier             | L _ (SigD _ (TypeSig _ ids _)) <- hsmodDecls-            , L _ id <- ids+            , L _ identifier <- ids             ]     hasTypeSig = (`Set.member` typeSigIds) . unLoc      compls = concat         [ case decl of             SigD _ (TypeSig _ ids typ) ->-                [mkComp id CiFunction (Just $ showForSnippet typ) | id <- ids]+                [mkComp identifier CompletionItemKind_Function (Just $ showForSnippet typ) | identifier <- ids]             ValD _ FunBind{fun_id} ->-                [ mkComp fun_id CiFunction Nothing+                [ mkComp fun_id CompletionItemKind_Function Nothing                 | not (hasTypeSig fun_id)                 ]             ValD _ PatBind{pat_lhs} ->-                [mkComp id CiVariable Nothing-                | VarPat _ id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs]-            TyClD _ ClassDecl{tcdLName, tcdSigs} ->-                mkComp tcdLName CiInterface (Just $ showForSnippet tcdLName) :-                [ mkComp id CiFunction (Just $ showForSnippet typ)+                [mkComp identifier CompletionItemKind_Variable Nothing+                | VarPat _ identifier <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs]+            TyClD _ ClassDecl{tcdLName, tcdSigs, tcdATs} ->+                mkComp tcdLName CompletionItemKind_Interface (Just $ showForSnippet tcdLName) :+                [ mkComp identifier CompletionItemKind_Function (Just $ showForSnippet typ)                 | L _ (ClassOpSig _ _ ids typ) <- tcdSigs-                , id <- ids]+                , identifier <- ids] +++                [ mkComp fdLName CompletionItemKind_Struct (Just $ showForSnippet fdLName)+                | L _ (FamilyDecl{fdLName}) <- tcdATs]             TyClD _ x ->-                let generalCompls = [mkComp id cl (Just $ showForSnippet $ tyClDeclLName x)-                        | id <- listify (\(_ :: LIdP GhcPs) -> True) x-                        , let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)]+                let generalCompls = [mkComp identifier cl (Just $ showForSnippet $ tyClDeclLName x)+                        | identifier <- listify (\(_ :: LIdP GhcPs) -> True) x+                        , let cl = occNameToComKind (rdrNameOcc $ unLoc identifier)]                     -- here we only have to look at the outermost type-                    recordCompls = findRecordCompl uri pm (Local pos) x+                    recordCompls = findRecordCompl uri (Local pos) x                 in                    -- the constructors and snippets will be duplicated here giving the user 2 choices.                    generalCompls ++ recordCompls             ForD _ ForeignImport{fd_name,fd_sig_ty} ->-                [mkComp fd_name CiVariable (Just $ showForSnippet fd_sig_ty)]+                [mkComp fd_name CompletionItemKind_Variable (Just $ showForSnippet fd_sig_ty)]             ForD _ ForeignExport{fd_name,fd_sig_ty} ->-                [mkComp fd_name CiVariable (Just $ showForSnippet fd_sig_ty)]+                [mkComp fd_name CompletionItemKind_Variable (Just $ showForSnippet fd_sig_ty)]             _ -> []             | L (locA -> pos) decl <- hsmodDecls,             let mkComp = mkLocalComp pos         ]      mkLocalComp pos n ctyp ty =-        CI ctyp pn (Local pos) ensureTypeText pn Nothing doc (ctyp `elem` [CiStruct, CiInterface]) Nothing+        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-        -- when sorting completions, we use the presence of typeText-        -- to tell local completions and global completions apart-        -- instead of using the empty string here, we should probably introduce a new field...-        ensureTypeText = Just $ fromMaybe "" ty+        occ = rdrNameOcc $ unLoc n         pn = showForSnippet n-        doc = SpanDocText (getDocumentation [pm] $ reLoc n) (SpanDocUris Nothing Nothing)+        sn = snippetText pn -findRecordCompl :: Uri -> ParsedModule -> Provenance -> TyClDecl GhcPs -> [CompItem]-findRecordCompl uri pmod mn DataDecl {tcdLName, tcdDataDefn} = result+findRecordCompl :: Uri -> Provenance -> TyClDecl GhcPs -> [CompItem]+findRecordCompl uri mn DataDecl {tcdLName, tcdDataDefn} = result     where         result = [mkRecordSnippetCompItem uri (Just $ printOutputable $ unLoc tcdLName)-                        (printOutputable . unLoc $ con_name) field_labels mn doc Nothing-                 | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn+                        (printOutputable . unLoc $ con_name) field_labels mn Nothing+                 | ConDeclH98{..} <- unLoc <$> (extract_cons $ dd_cons tcdDataDefn)                  , Just  con_details <- [getFlds con_args]                  , let field_names = concatMap extract con_details                  , let field_labels = printOutputable <$> field_names                  , (not . List.null) field_labels                  ]-        doc = SpanDocText (getDocumentation [pmod] $ reLoc tcdLName) (SpanDocUris Nothing Nothing)          getFlds conArg = case conArg of                              RecCon rec  -> Just $ unLoc <$> unLoc rec                              PrefixCon{} -> Just []                              _           -> Nothing -        extract ConDeclField{..}             -- NOTE: 'cd_fld_names' is grouped so that the fields             -- sharing the same type declaration to fit in the same group; e.g.             --@@ -523,17 +490,25 @@             --             -- is encoded as @[[arg1, arg2], [arg3], [arg4]]@             -- Hence, we must concat nested arguments into one to get all the fields.-            = map (rdrNameFieldOcc . unLoc) cd_fld_names+#if MIN_VERSION_ghc(9,13,0)+        extract HsConDeclRecField{..}+            = map (foLabel . unLoc) cdrf_names+        -- XConDeclRecField+        extract _ = []+#else+        extract ConDeclField{..}+            = map (foLabel . unLoc) cd_fld_names         -- XConDeclField         extract _ = []-findRecordCompl _ _ _ _ = []+#endif+findRecordCompl _ _ _ = []  toggleSnippets :: ClientCapabilities -> CompletionsConfig -> CompletionItem -> CompletionItem toggleSnippets ClientCapabilities {_textDocument} CompletionsConfig{..} =   removeSnippetsWhen (not $ enableSnippets && supported)   where     supported =-      Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)+      Just True == (_textDocument >>= _completion >>= view L.completionItem >>= view L.snippetSupport)  toggleAutoExtend :: CompletionsConfig -> CompItem -> CompItem toggleAutoExtend CompletionsConfig{enableAutoExtend=False} x = x {additionalTextEdits = Nothing}@@ -544,31 +519,77 @@   if condition     then       x-        { _insertTextFormat = Just PlainText,+        { _insertTextFormat = Just InsertTextFormat_PlainText,           _insertText = Nothing         }     else x  -- | Returns the cached completions for the given module and position. getCompletions-    :: PluginId+    :: IdePlugins a     -> IdeOptions     -> CachedCompletions     -> Maybe (ParsedModule, PositionMapping)+    -> Maybe (HieAstResult, PositionMapping)     -> (Bindings, PositionMapping)-    -> VFS.PosPrefixInfo+    -> PosPrefixInfo     -> ClientCapabilities     -> CompletionsConfig-    -> HM.HashMap T.Text (HashSet.HashSet IdentInfo)-    -> IO [Scored CompletionItem]-getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules}-               maybe_parsed (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do-  let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo-      enteredQual = if T.null prefixModule then "" else prefixModule <> "."+    -> ModuleNameEnv (HashSet.HashSet IdentInfo)+    -> Uri+    -> [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        -- Boolean labels to tag suggestions as qualified (or not)-      qual = not(T.null prefixModule)+      qual = not(T.null prefixScope)       notQual = False        {- correct the position by moving 'foo :: Int -> String ->    '@@ -576,7 +597,7 @@           to                             'foo :: Int -> String ->    '                                                               ^       -}-      pos = VFS.cursorPos prefixInfo+      pos = cursorPos prefixInfo        maxC = maxCompletions config @@ -586,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@@ -599,8 +618,47 @@                   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.+          -- Requiring fresh hieast is fine for normal workflows, because it is generated while the user edits.+          recordDotSyntaxCompls :: [(Bool, CompItem)]+          recordDotSyntaxCompls = case maybe_ast_res of+            Just (HAR {hieAst = hieast, hieKind = HieFresh},_) -> concat $ pointCommand hieast (completionPrefixPos prefixInfo) nodeCompletions+            _ -> []+            where+              nodeCompletions :: HieAST Type -> [(Bool, CompItem)]+              nodeCompletions node = concatMap g (nodeType $ nodeInfo node)+              g :: Type -> [(Bool, CompItem)]+              g (TyConApp theTyCon _) = map (dotFieldSelectorToCompl (printOutputable $ GHC.tyConName theTyCon)) $ getSels theTyCon+              g _ = []+              getSels :: GHC.TyCon -> [T.Text]+              getSels tycon = let f fieldLabel = printOutputable fieldLabel+                              in map f $ tyConFieldLabels tycon+              -- Completions can return more information that just the completion itself, but it will+              -- require more than what GHC currently gives us in the HieAST, since it only gives the Type+              -- of the fields, not where they are defined, etc. So for now the extra fields remain empty.+              -- Also: additionalTextEdits is a todo, since we may want to import the record. It requires a way+              -- to get the record's module, which isn't included in the type information used to get the fields.+              dotFieldSelectorToCompl :: T.Text -> T.Text -> (Bool, CompItem)+              dotFieldSelectorToCompl recname label = (True, CI+                { compKind = CompletionItemKind_Field+                , insertText = snippetText label+                , provenance = DefinedIn recname+                , label = label+                , typeText = Nothing+                , isInfix = Nothing+                , isTypeCompl = False+                , additionalTextEdits = Nothing+                , nameDetails = Nothing+                , isLocalCompletion = False+                })+           -- 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@@ -609,83 +667,72 @@           ctxCompls = (fmap.fmap) (\comp -> toggleAutoExtend config $ comp { isInfix = infixCompls }) ctxCompls'            infixCompls :: Maybe Backtick-          infixCompls = isUsedAsInfix fullLine prefixModule prefixText pos+          infixCompls = isUsedAsInfix fullLine prefixScope prefixText pos            PositionMapping bDelta = bmapping-          oldPos = fromDelta bDelta $ VFS.cursorPos prefixInfo+          oldPos = fromDelta bDelta $ cursorPos prefixInfo           startLoc = lowerRange oldPos           endLoc = upperRange oldPos           localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc           localBindsToCompItem :: Name -> Maybe Type -> CompItem-          localBindsToCompItem name typ = CI ctyp pn thisModName ty pn Nothing emptySpanDoc (not $ isValOcc occ) Nothing+          localBindsToCompItem name typ = CI ctyp (snippetText pn) thisModName pn ty Nothing (not $ isValOcc occ) Nothing dets True             where               occ = nameOccName name-              ctyp = occNameToComKind Nothing occ+              ctyp = occNameToComKind occ               pn = showForSnippet name               ty = showForSnippet <$> typ               thisModName = Local $ nameSrcSpan name+              dets = NameDetails <$> nameModule_maybe name <*> pure (nameOccName name) -          compls = if T.null prefixModule-            then map (notQual,) localCompls ++ map (qual,) unqualCompls ++ ((notQual,) . ($Nothing) <$> anyQualCompls)-            else ((qual,) <$> Map.findWithDefault [] prefixModule (getQualCompls qualCompls))-                 ++ ((notQual,) . ($ Just prefixModule) <$> anyQualCompls)+          -- When record-dot-syntax completions are available, we return them exclusively.+          -- They are only available when we write i.e. `myrecord.` with OverloadedRecordDot enabled.+          -- Anything that isn't a field is invalid, so those completion don't make sense.+          compls+            | T.null prefixScope = map (notQual,) localCompls ++ map (qual,) unqualCompls ++ map (\compl -> (notQual, compl Nothing)) anyQualCompls+            | not $ null recordDotSyntaxCompls = recordDotSyntaxCompls+            | otherwise = ((qual,) <$> Map.findWithDefault [] prefixScope (getQualCompls qualCompls))+                 ++ map (\compl -> (notQual, compl (Just prefixScope))) anyQualCompls -      filtListWith f list =+      filtListWith f xs =         [ fmap f label-        | label <- Fuzzy.simpleFilter chunkSize maxC fullPrefix list+        | label <- Fuzzy.simpleFilter chunkSize maxC fullPrefix xs         , 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 prefixModule = filtListWith mkExtCompl (optKeywords ideOpts)+          | 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 = T.pack $ words (T.unpack fullLine) !! 1-          funcs = HM.lookupDefault HashSet.empty moduleName moduleExportsMap-          funs = map (show . name) $ HashSet.toList funcs-      return $ filterModuleExports moduleName $ map T.pack 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 plId ideOpts) uniqueFiltCompls-        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)   + uniqueCompl :: CompItem -> CompItem -> Ordering uniqueCompl candidate unique =   case compare (label candidate, compKind candidate)@@ -693,22 +740,18 @@     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 (typeText candidate == typeText unique && 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-      isLocalCompletion ci = isJust(typeText ci)-       importedFrom :: CompItem -> T.Text       importedFrom (provenance -> ImportedFrom m) = m       importedFrom (provenance -> DefinedIn m)    = m       importedFrom (provenance -> Local _)        = "local"-#if __GLASGOW_HASKELL__ < 810-      importedFrom _                              = ""-#endif  -- --------------------------------------------------------------------- -- helper functions for infix backticks@@ -747,80 +790,16 @@  -- --------------------------------------------------------------------- --- | 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)) prefixes---- | Prefixes that can occur in a GHC OccName-prefixes :: [T.Text]-prefixes =-  [-    -- long ones-    "$con2tag_"-  , "$tag2con_"-  , "$maxtag_"--  -- four chars-  , "$sel:"-  , "$tc'"--  -- three chars-  , "$dm"-  , "$co"-  , "$tc"-  , "$cp"-  , "$fx"--  -- two chars-  , "$W"-  , "$w"-  , "$m"-  , "$b"-  , "$c"-  , "$d"-  , "$i"-  , "$s"-  , "$f"-  , "$r"-  , "C:"-  , "N:"-  , "D:"-  , "$p"-  , "$L"-  , "$f"-  , "$t"-  , "$c"-  , "$m"-  ]---safeTyThingForRecord :: TyThing -> Maybe (T.Text, [T.Text])-safeTyThingForRecord (AnId _) = Nothing-safeTyThingForRecord (AConLike dc) =-    let ctxStr = printOutputable . occName . conLikeName $ dc-        field_names = T.pack . unpackFS . flLabel <$> conLikeFieldLabels dc-    in-        Just (ctxStr, field_names)-safeTyThingForRecord _ = Nothing--mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> Provenance -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem-mkRecordSnippetCompItem uri parent ctxStr compl importedFrom docs imp = r+mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> Provenance -> Maybe (LImportDecl GhcPs) -> CompItem+mkRecordSnippetCompItem uri parent ctxStr compl importedFrom imp = r   where       r  = CI {-            compKind = CiSnippet+            compKind = CompletionItemKind_Snippet           , insertText = buildSnippet           , provenance = importedFrom           , typeText = Nothing           , label = ctxStr           , isInfix = Nothing-          , docs = docs           , isTypeCompl = False           , additionalTextEdits = imp <&> \x ->             ExtendImport@@ -830,12 +809,15 @@                   importQual = getImportQual x,                   newThing = ctxStr                 }+          , nameDetails = Nothing+          , isLocalCompletion = True           }        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)@@ -882,3 +864,37 @@         []     -> []         [xs]   -> xs         lists' -> merge_lists lists'++-- |From the given cursor position, gets the prefix module or record for autocompletion+getCompletionPrefix :: Position -> VFS.VirtualFile -> PosPrefixInfo+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 $ 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+        curWord <-+            if | T.null beforePos        -> Just ""+               | T.last beforePos == ' ' -> Just "" -- don't count abc as the curword in 'abc '+               | otherwise               -> lastMaybe (T.words beforePos)++        let parts = T.split (=='.')+                      $ T.takeWhileEnd (\x -> isAlphaNum x || x `elem` ("._'"::String)) curWord+        case reverse parts of+          [] -> Nothing+          (x:xs) -> do+            let modParts = reverse $ filter (not .T.null) xs+                -- 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+completionPrefixPos PosPrefixInfo { cursorPos = Position ln co, prefixText = str} = Position ln (co - (fromInteger . toInteger . T.length $ str) - 1)
src/Development/IDE/Plugin/Completions/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP                #-} {-# LANGUAGE DeriveAnyClass     #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs              #-}@@ -11,33 +12,34 @@ import qualified Data.Map                     as Map import qualified Data.Text                    as T -import           Data.Aeson                   (FromJSON, ToJSON)+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           Development.IDE.Spans.Common () import           GHC.Generics                 (Generic)-import           Ide.Plugin.Config            (Config)-import qualified Ide.Plugin.Config            as Config+import qualified GHC.Types.Name.Occurrence    as Occ import           Ide.Plugin.Properties-import           Ide.PluginUtils              (getClientConfig, usePropertyLsp)-import           Ide.Types                    (PluginId)-import           Language.LSP.Server          (MonadLsp)-import           Language.LSP.Types           (CompletionItemKind (..), Uri)+import           Language.LSP.Protocol.Types  (CompletionItemKind (..), Uri)+import qualified Language.LSP.Protocol.Types  as J  -- | 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 @@ -50,8 +52,8 @@ extendImportCommandId = "extendImport"  properties :: Properties-  '[ 'PropertyKey "autoExtendOn" 'TBoolean,-     'PropertyKey "snippetsOn" 'TBoolean]+  '[ 'PropertyKey "autoExtendOn" TBoolean,+     'PropertyKey "snippetsOn" TBoolean] properties = emptyProperties   & defineBooleanProperty #snippetsOn     "Inserts snippets when using code completions"@@ -60,14 +62,7 @@     "Extends the import list automatically when completing a out-of-scope identifier"     True -getCompletionsConfig :: (MonadLsp Config m) => PluginId -> m CompletionsConfig-getCompletionsConfig pId =-  CompletionsConfig-    <$> usePropertyLsp #snippetsOn pId properties-    <*> usePropertyLsp #autoExtendOn pId properties-    <*> (Config.maxCompletions <$> getClientConfig) - data CompletionsConfig = CompletionsConfig {   enableSnippets   :: Bool,   enableAutoExtend :: Bool,@@ -90,17 +85,69 @@     | 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.-  , typeText            :: Maybe T.Text   -- ^ Available type information.   , label               :: T.Text         -- ^ Label to display to the user.+  , typeText            :: Maybe T.Text   , isInfix             :: Maybe Backtick -- ^ Did the completion happen                                    -- in the context of an infix notation.-  , docs                :: SpanDoc        -- ^ Available documentation.   , isTypeCompl         :: Bool   , additionalTextEdits :: Maybe ExtendImport+  , nameDetails         :: Maybe NameDetails -- ^ For resolving purposes+  , isLocalCompletion   :: Bool              -- ^ Is it from this module?   }   deriving (Eq, Show) @@ -136,3 +183,80 @@ instance Semigroup CachedCompletions where     CC a b c d e <> CC a' b' c' d' e' =         CC (a<>a') (b<>b') (c<>c') (d<>d') (e<>e')+++-- | Describes the line at the current cursor position+data PosPrefixInfo = PosPrefixInfo+  { fullLine    :: !T.Text+    -- ^ The full contents of the line the cursor is at++  , prefixScope :: !T.Text+    -- ^ If any, the module name that was typed right before the cursor position.+    --  For example, if the user has typed "Data.Maybe.from", then this property+    --  will be "Data.Maybe"+    -- If OverloadedRecordDot is enabled, "Shape.rect.width" will be+    -- "Shape.rect"++  , prefixText  :: !T.Text+    -- ^ The word right before the cursor position, after removing the module part.+    -- For example if the user has typed "Data.Maybe.from",+    -- then this property will be "from"+  , cursorPos   :: !J.Position+    -- ^ The cursor position+  } deriving (Show,Eq)+++-- | This is a JSON serialisable representation of a GHC Name that we include in+-- completion responses so that we can recover the original name corresponding+-- to the completion item. This is used to resolve additional details on demand+-- about the item like its type and documentation.+data NameDetails+  = NameDetails Module OccName+  deriving (Eq)++-- NameSpace is abstract so need these+nsJSON :: NameSpace -> Value+nsJSON ns+  | isVarNameSpace ns = String "v"+  | isDataConNameSpace ns = String "c"+  | isTcClsNameSpace ns  = String "t"+  | isTvNameSpace ns = String "z"+  | otherwise = error "namespace not recognized"++parseNs :: Value -> Parser NameSpace+parseNs (String "v") = pure Occ.varName+parseNs (String "c") = pure dataName+parseNs (String "t") = pure tcClsName+parseNs (String "z") = pure tvName+parseNs _            = mempty++instance FromJSON NameDetails where+  parseJSON v@(Array _)+    = do+      [modname,modid,namesp,occname] <- parseJSON v+      mn  <- parseJSON modname+      mid <- parseJSON modid+      ns <- parseNs namesp+      occn <- parseJSON occname+      pure $ NameDetails (mkModule (stringToUnit mid) (mkModuleName mn)) (mkOccName ns occn)+  parseJSON _ = mempty+instance ToJSON NameDetails where+  toJSON (NameDetails mdl occ) = toJSON [toJSON mname,toJSON mid,nsJSON ns,toJSON occs]+    where+      mname = moduleNameString $ moduleName mdl+      mid = unitIdString $ moduleUnitId mdl+      ns = occNameSpace occ+      occs = occNameString occ+instance Show NameDetails where+  show = show . toJSON++-- | The data that is actually sent for resolve support+-- We need the URI to be able to reconstruct the GHC environment+-- in the file the completion was triggered in.+data CompletionResolveData = CompletionResolveData+  { itemFile      :: Uri+  , itemNeedsType :: Bool -- ^ Do we need to lookup a type for this item?+  , itemName      :: NameDetails+  }+  deriving stock Generic+  deriving anyclass (FromJSON, ToJSON)
src/Development/IDE/Plugin/HLS.hs view
@@ -1,71 +1,150 @@ {-# LANGUAGE DataKinds         #-} {-# LANGUAGE GADTs             #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds         #-}  module Development.IDE.Plugin.HLS     (       asGhcIdePlugin+    , toResponseError     , Log(..)     ) where -import           Control.Exception            (SomeException)+import           Control.Exception                (SomeException)+import           Control.Lens                     ((^.)) import           Control.Monad-import qualified Data.Aeson                   as J-import           Data.Bifunctor-import           Data.Dependent.Map           (DMap)-import qualified Data.Dependent.Map           as DMap+import 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.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 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           Development.IDE.Types.Logger+import qualified Development.IDE.Plugin           as P+import           Ide.Logger import           Ide.Plugin.Config-import           Ide.PluginUtils              (getClientConfig)-import           Ide.Types                    as HLS-import qualified Language.LSP.Server          as LSP+import           Ide.Plugin.Error+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           Language.LSP.VFS-import           Language.LSP.Types-import qualified Language.LSP.Types           as J-import           Text.Regex.TDFA.Text         ()-import           UnliftIO                     (MonadUnliftIO)-import           UnliftIO.Async               (forConcurrently)-import           UnliftIO.Exception           (catchAny)+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-  = LogNoEnabledPlugins-  deriving Show+    =  LogPluginError PluginId PluginError+    | 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-    LogNoEnabledPlugins ->-      "extensibleNotificationPlugins no enabled plugins"+    LogPluginError (PluginId pId) err ->+      pretty pId <> ":" <+> pretty err+    LogResponseError (PluginId pId) err ->+      pretty pId <> ":" <+> pretty err+    LogNoPluginForMethod (Some 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 +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 = TResponseError (InR ErrorCodes_MethodNotFound) msg Nothing+      msg = noPluginHandlesMsg m fs'+  return $ Left err+  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"++commandDoesntExist :: CommandId -> PluginId -> [PluginCommand ideState] -> Text+commandDoesntExist (CommandId com) (PluginId pid) legalCmds =+    "Command " <> com <> " isn't defined for plugin " <> pid <> ". Legal commands are: "+        <> (T.intercalate ", " $ map (\(PluginCommand{commandId = CommandId cid}) -> cid) legalCmds)++failedToParseArgs :: CommandId  -- ^ command that failed to parse+                    -> PluginId -- ^ Plugin that created the command+                    -> String   -- ^ The JSON Error message+                    -> A.Value  -- ^ The Argument Values+                    -> Text+failedToParseArgs (CommandId com) (PluginId pid) err arg =+    "Error while parsing args for " <> com <> " in plugin " <> pid <> ": "+        <> T.pack err <> ", arg = " <> T.pack (show arg)++exceptionInPlugin :: PluginId -> SMethod m -> SomeException -> Text+exceptionInPlugin plId method exception =+    "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 :: 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 = TResponseError errCode msg Nothing+    logWith recorder Warning $ LogResponseError p err+    pure $ Left err+ -- | Map a set of plugins to the underlying ghcide engine. asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin Config asGhcIdePlugin recorder (IdePlugins ls) =     mkPlugin rulesPlugins HLS.pluginRules <>-    mkPlugin executeCommandPlugins HLS.pluginCommands <>-    mkPlugin extensiblePlugins HLS.pluginHandlers <>-    mkPlugin (extensibleNotificationPlugins recorder) HLS.pluginNotificationHandlers <>-    mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags+    mkPlugin (executeCommandPlugins recorder) HLS.pluginCommands <>+    mkPlugin (extensiblePlugins recorder) id <>+    mkPlugin (extensibleNotificationPlugins recorder) id <>+    mkPluginFromDescriptor dynFlagsPlugins HLS.pluginModifyDynflags     where+        mkPlugin f = mkPluginFromDescriptor (f . map (first pluginId)) -        mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> b) -> Plugin Config-        mkPlugin maker selector =-          case map (second selector) ls of+        mkPluginFromDescriptor+            :: ([(PluginDescriptor IdeState, b)]+            -> Plugin Config)+            -> (PluginDescriptor IdeState -> b)+            -> Plugin Config+        mkPluginFromDescriptor maker selector =+          case map (\p -> (p, selector p)) ls of             -- If there are no plugins that provide a descriptor, use mempty to             -- create the plugin – otherwise we we end up declaring handlers for             -- capabilities that there are no plugins for@@ -79,7 +158,7 @@     where         rules = foldMap snd rs -dynFlagsPlugins :: [(PluginId, DynFlagsModifications)] -> Plugin Config+dynFlagsPlugins :: [(PluginDescriptor c, DynFlagsModifications)] -> Plugin Config dynFlagsPlugins rs = mempty   { P.pluginModifyDynflags =       flip foldMap rs $ \(plId, dflag_mods) cfg ->@@ -91,13 +170,13 @@  -- --------------------------------------------------------------------- -executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config-executeCommandPlugins ecs = mempty { P.pluginHandlers = executeCommandHandlers ecs }+executeCommandPlugins :: Recorder (WithPriority Log) -> [(PluginId, [PluginCommand IdeState])] -> Plugin Config+executeCommandPlugins recorder ecs = mempty { P.pluginHandlers = executeCommandHandlers recorder ecs } -executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config)-executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd+executeCommandHandlers :: Recorder (WithPriority Log) -> [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config)+executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCommand execCmd   where-    pluginMap = Map.fromList ecs+    pluginMap = Map.fromListWith (++) ecs      parseCmdId :: T.Text -> Maybe (PluginId, CommandId)     parseCmdId x = case T.splitOn ":" x of@@ -106,129 +185,259 @@       _                    -> Nothing      -- The parameters to the HLS command are always the first element--    execCmd ide (ExecuteCommandParams _ cmdId args) = do-      let cmdParams :: J.Value+    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 (J.List (x:_)) -> x-            _                   -> J.Null+            Just ((x:_)) -> x+            _            -> A.Null       case parseCmdId cmdId of         -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions         Just ("hls", "fallbackCodeAction") ->-          case J.fromJSON cmdParams of-            J.Success (FallbackCodeActionParams mEdit mCmd) -> do+          case A.fromJSON cmdParams of+            A.Success (FallbackCodeActionParams mEdit mCmd) -> do                -- Send off the workspace request if it has one               forM_ mEdit $ \edit ->-                LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ())+                LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ())                case mCmd of                 -- If we have a command, continue to execute it-                Just (J.Command _ innerCmdId innerArgs)+                Just (Command _ innerCmdId innerArgs)                     -> execCmd ide (ExecuteCommandParams Nothing innerCmdId innerArgs)-                Nothing -> return $ Right J.Null+                -- TODO: This should be a response error?+                Nothing -> return $ Right $ InR Null -            J.Error _str -> return $ Right J.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-        _ -> return $ Left $ ResponseError InvalidParams "Invalid command identifier" Nothing+        _ -> do+            logWith recorder Warning LogInvalidCommandIdentifier+            return $ Left $ TResponseError (InR ErrorCodes_InvalidParams) "Invalid command identifier" Nothing -    runPluginCommand ide p@(PluginId p') com@(CommandId 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 -> return-          (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing)+        Nothing -> logAndReturnError recorder p (InR ErrorCodes_InvalidRequest) (pluginDoesntExist p)         Just xs -> case List.find ((com ==) . commandId) xs of-          Nothing -> return $ Left $-            ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p'-                                          <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing-          Just (PluginCommand _ _ f) -> case J.fromJSON arg of-            J.Error err -> return $ Left $-              ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p'-                                           <> ": " <> T.pack err-                                           <> "\narg = " <> T.pack (show arg)) Nothing-            J.Success a -> f ide a+          Nothing -> logAndReturnError recorder p (InR ErrorCodes_InvalidRequest) (commandDoesntExist com p xs)+          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 <- 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 r)) ->+                  liftIO $ noPluginHandles recorder SMethod_WorkspaceExecuteCommand [(p,DoesNotHandleRequest r)]+                (Left pluginErr) -> do+                  liftIO $ logErrors recorder [(p, pluginErr)]+                  pure $ Left $ toResponseError (p, pluginErr)+                (Right result) -> pure $ Right result  -- --------------------------------------------------------------------- -extensiblePlugins :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config-extensiblePlugins xs = mempty { P.pluginHandlers = handlers }+extensiblePlugins ::  Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config+extensiblePlugins recorder plugins = mempty { P.pluginHandlers = handlers }   where-    IdeHandlers handlers' = foldMap bakePluginId xs-    bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers-    bakePluginId (pid,PluginHandlers hs) = IdeHandlers $ DMap.map-      (\(PluginHandler f) -> IdeHandler [(pid,f pid)])+    IdeHandlers handlers' = foldMap bakePluginId plugins+    bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeHandlers+    bakePluginId (pid,pluginDesc) = IdeHandlers $ DMap.map+      (\(PluginHandler f) -> IdeHandler [(pid,pluginDesc,f pid)])       hs+      where+        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-        let fs = filter (\(pid,_) -> pluginEnabled m pid 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 -> pure $ Left $ ResponseError InvalidRequest-            ("No plugin enabled for " <> T.pack (show m) <> ", available: " <> T.pack (show $ map fst fs))-            Nothing-          Just fs -> do-            let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e)-            es <- runConcurrently msg (show m) fs ide params-            let (errs,succs) = partitionEithers $ toList es+          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 <- 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             case nonEmpty succs of-              Nothing -> pure $ Left $ combineErrors errs+              Nothing -> do+                let noRefused (_, PluginRequestRefused _) = False+                    noRefused (_, _)                      = True+                    (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-                caps <- LSP.getClientCapabilities                 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, PluginNotificationHandlers IdeState)] -> Plugin Config+extensibleNotificationPlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config extensibleNotificationPlugins recorder xs = mempty { P.pluginHandlers = handlers }   where     IdeNotificationHandlers handlers' = foldMap bakePluginId xs-    bakePluginId :: (PluginId, PluginNotificationHandlers IdeState) -> IdeNotificationHandlers-    bakePluginId (pid,PluginNotificationHandlers hs) = IdeNotificationHandlers $ DMap.map-      (\(PluginNotificationHandler f) -> IdeNotificationHandler [(pid,f pid)])+    bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeNotificationHandlers+    bakePluginId (pid,pluginDesc) = IdeNotificationHandlers $ DMap.map+      (\(PluginNotificationHandler f) -> IdeNotificationHandler [(pid,pluginDesc,f pid)])       hs+      where PluginNotificationHandlers hs = HLS.pluginNotificationHandlers pluginDesc     handlers = mconcat $ do       (IdeNotification m :=> IdeNotificationHandler fs') <- DMap.assocs handlers'       pure $ notificationHandler m $ \ide vfs params -> do         config <- Ide.PluginUtils.getClientConfig-        let fs = filter (\(pid,_) -> plcGlobalOn $ configForPlugin config pid) 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 Info LogNoEnabledPlugins-              pure ()-          Just fs -> do+            logWith recorder Warning (LogNoPluginForMethod $ Some m)+          Just neFs -> do             -- We run the notifications in order, so the core ghcide provider             -- (which restarts the shake process) hopefully comes last-              mapM_ (\(pid,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params) fs+            mapM_ (\(pid,_,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params+                                    `catchAny` -- See Note [Exception handling in plugins]+                                    (\e -> logWith recorder Warning (ExceptionInPlugin pid (Some m) e))) neFs + -- ---------------------------------------------------------------------  runConcurrently   :: MonadUnliftIO m-  => (SomeException -> PluginId -> T.Text)-  -> String -- ^ label-  -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))+  => (PluginId -> SMethod method -> SomeException -> T.Text)+  -> SMethod method -- ^ Method (used for errors and tracing)+  -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either PluginError d)))+  -- ^ Enabled plugin actions that we are allowed to run   -> a   -> b-  -> m (NonEmpty (Either ResponseError d))-runConcurrently msg method fs a b = fmap join $ forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do-  f a b-    `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing)+  -> m (NonEmpty(NonEmpty (Either PluginError d)))+runConcurrently msg method fs a b = forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString (show method)) $ do+  f a b  -- See Note [Exception handling in plugins]+     `catchAny` (\e -> pure $ pure $ Left $ PluginInternalError (msg pid method e)) -combineErrors :: [ResponseError] -> ResponseError-combineErrors [x] = x-combineErrors xs  = ResponseError InternalError (T.pack (show xs)) Nothing+combineErrors :: NonEmpty (PluginId, PluginError) -> TResponseError m+combineErrors (x NE.:| []) = toResponseError x+combineErrors xs = toResponseError $ NE.last $ NE.sortWith (toPriority . snd) xs +toResponseError :: (PluginId, PluginError) -> TResponseError m+toResponseError (PluginId plId, err) =+        TResponseError (toErrorCode err) (plId <> ": " <> tPretty err) Nothing+    where tPretty = T.pack . show . pretty++logErrors :: Recorder (WithPriority Log) -> [(PluginId, PluginError)] -> IO ()+logErrors recorder errs = do+  forM_ errs $ \(pId, err) ->+                logIndividualErrors pId err+  where logIndividualErrors plId err =+          logWith recorder (toPriority err) $ LogPluginError plId err++ -- | Combine the 'PluginHandler' for all plugins-newtype IdeHandler (m :: J.Method FromClient Request)-  = IdeHandler [(PluginId,IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))]+newtype IdeHandler (m :: Method ClientToServer Request)+  = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> HandlerM Config (NonEmpty (Either PluginError (MessageResult m))))]  -- | Combine the 'PluginHandler' for all plugins-newtype IdeNotificationHandler (m :: J.Method FromClient Notification)-  = IdeNotificationHandler [(PluginId, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())]--- type NotificationHandler (m :: Method FromClient Notification) = MessageParams m -> IO ()`+newtype IdeNotificationHandler (m :: Method ClientToServer Notification)+  = IdeNotificationHandler [(PluginId, PluginDescriptor IdeState, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())]+-- type NotificationHandler (m :: Method ClientToServer Notification) = MessageParams m -> IO ()`  -- | Combine the 'PluginHandlers' for all plugins newtype IdeHandlers             = IdeHandlers             (DMap IdeMethod       IdeHandler)@@ -237,13 +446,27 @@ instance Semigroup IdeHandlers where   (IdeHandlers a) <> (IdeHandlers b) = IdeHandlers $ DMap.unionWithKey go a b     where-      go _ (IdeHandler a) (IdeHandler b) = IdeHandler (a <> b)+      go _ (IdeHandler c) (IdeHandler d) = IdeHandler (c <> d) instance Monoid IdeHandlers where   mempty = IdeHandlers mempty  instance Semigroup IdeNotificationHandlers where   (IdeNotificationHandlers a) <> (IdeNotificationHandlers b) = IdeNotificationHandlers $ DMap.unionWithKey go a b     where-      go _ (IdeNotificationHandler a) (IdeNotificationHandler b) = IdeNotificationHandler (a <> b)+      go _ (IdeNotificationHandler c) (IdeNotificationHandler d) = IdeNotificationHandler (c <> d) instance Monoid IdeNotificationHandlers where   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,+so we should be robust to it throwing.++We don't want these to bring down HLS. So we catch and log exceptions wherever+we run a handler defined in a plugin.++The flip side of this is that it's okay for plugins to throw exceptions as a+way of signalling failure!+-}
src/Development/IDE/Plugin/HLS/GhcIde.hs view
@@ -7,38 +7,35 @@     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.CodeAction   as CodeAction import qualified Development.IDE.Plugin.Completions  as Completions import qualified Development.IDE.Plugin.TypeLenses   as TypeLenses import           Ide.Types-import           Language.LSP.Server                 (LspM)-import           Language.LSP.Types+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types import           Text.Regex.TDFA.Text                ()  data Log   = LogNotifications Notifications.Log   | LogCompletions Completions.Log   | LogTypeLenses TypeLenses.Log+  | LogHover Hover.Log   deriving Show  instance Pretty Log where   pretty = \case-    LogNotifications log -> pretty log-    LogCompletions log   -> pretty log-    LogTypeLenses log    -> pretty log+    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",-    CodeAction.iePluginDescriptor "ghcide-code-actions-imports-exports",-    CodeAction.typeSigsPluginDescriptor "ghcide-code-actions-type-signatures",-    CodeAction.bindingsPluginDescriptor "ghcide-code-actions-bindings",-    CodeAction.fillHolePluginDescriptor "ghcide-code-actions-fill-holes",+  [ 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"@@ -46,22 +43,28 @@  -- --------------------------------------------------------------------- -descriptor :: PluginId -> PluginDescriptor IdeState-descriptor plId = (defaultPluginDescriptor plId)-  { pluginHandlers = mkPluginHandler STextDocumentHover hover'-                  <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider,-    pluginConfigDescriptor = defaultConfigDescriptor {configEnableGenericConfig = False}+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{..} ->+                      Hover.gotoDefinition recorder ide TextDocumentPositionParams{..})+                  <> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} ->+                      Hover.gotoTypeDefinition recorder ide TextDocumentPositionParams{..})+                  <> mkPluginHandler SMethod_TextDocumentImplementation (\ide _ ImplementationParams{..} ->+                      Hover.gotoImplementation recorder ide TextDocumentPositionParams{..})+                  <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} ->+                      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' :: IdeState -> PluginId -> HoverParams  -> LspM c (Either ResponseError (Maybe Hover))-hover' ideState _ HoverParams{..} = do-    liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ-    hover ideState TextDocumentPositionParams{..}---- ----------------------------------------------------------------------symbolsProvider :: IdeState -> PluginId -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation))-symbolsProvider ide _ params = moduleOutline ide params---- ---------------------------------------------------------------------+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,22 +12,27 @@   ) 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 import           Control.Monad.STM-import           Data.Aeson-import           Data.Aeson.Types+import           Control.Monad.Trans.Class            (MonadTrans (lift))+import           Data.Aeson                           (FromJSON (parseJSON),+                                                       ToJSON (toJSON), Value)+import qualified Data.Aeson.Types                     as A 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 import           Data.Text                            (Text, pack) import           Development.IDE.Core.OfInterest      (getFilesOfInterest)+import           Development.IDE.Core.Rules import           Development.IDE.Core.RuleTypes-import           Development.IDE.Core.Service import           Development.IDE.Core.Shake-import           Development.IDE.Core.Rules import           Development.IDE.GHC.Compat import           Development.IDE.Graph                (Action) import qualified Development.IDE.Graph                as Graph@@ -39,14 +43,16 @@ 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) import           GHC.Generics                         (Generic)-import           Ide.Plugin.Config                    (CheckParents)+import           Ide.Plugin.Error import           Ide.Types-import qualified Language.LSP.Server                  as LSP-import           Language.LSP.Types+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types import qualified "list-t" ListT import qualified StmContainers.Map                    as STM import           System.Time.Extra@@ -58,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]@@ -73,27 +80,27 @@     deriving newtype (FromJSON, ToJSON)  plugin :: PluginDescriptor IdeState-plugin = (defaultPluginDescriptor "test") {-    pluginHandlers = mkPluginHandler (SCustomMethod "test") $ \st _ ->+plugin = (defaultPluginDescriptor "test" "") {+    pluginHandlers = mkPluginHandler (SMethod_CustomMethod (Proxy @"test")) $ \st _ ->         testRequestHandler' st     }   where       testRequestHandler' ide req-        | Just customReq <- parseMaybe parseJSON req-        = testRequestHandler ide customReq+        | Just customReq <- A.parseMaybe parseJSON req+        = ExceptT $ testRequestHandler ide customReq         | otherwise-        = return $ Left-        $ ResponseError InvalidRequest "Cannot parse request" Nothing+        = throwError+        $ PluginInvalidParams "Cannot parse request"   testRequestHandler ::  IdeState                 -> TestRequest-                -> LSP.LspM c (Either ResponseError Value)+                -> HandlerM config (Either PluginError Value) testRequestHandler _ (BlockSeconds secs) = do-    LSP.sendNotification (SCustomMethod "ghcide/blocking/request") $+    pluginSendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/request")) $       toJSON secs     liftIO $ sleep secs-    return (Right Null)+    return (Right A.Null) testRequestHandler s (GetInterfaceFilesDir file) = liftIO $ do     let nfp = fromUri $ toNormalizedUri file     sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp@@ -106,12 +113,23 @@     atomically $ do         n <- countQueue $ actionQueue $ shakeExtras s         when (n>0) retry-    return $ Right Null+    return $ Right A.Null testRequestHandler s (WaitForIdeRule k file) = liftIO $ do     let nfp = fromUri $ toNormalizedUri file     success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp     let res = WaitForIdeRuleResult <$> success-    return $ bimap mkResponseError toJSON res+    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@@ -145,9 +163,6 @@     step <- shakeGetBuildStep db     return [ k | (k, res) <- keys, field res == Step step] -mkResponseError :: Text -> ResponseError-mkResponseError msg = ResponseError InvalidRequest msg Nothing- parseAction :: CI String -> NormalizedFilePath -> Action (Either Text Bool) parseAction "typecheck" fp = Right . isJust <$> use TypeCheck fp parseAction "getLocatedImports" fp = Right . isJust <$> use GetLocatedImports fp@@ -160,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-  LSP.sendNotification (SCustomMethod "ghcide/blocking/command") Null+blockCommandHandler _ideState _ _params = do+  lift $ pluginSendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/command")) A.Null   liftIO $ threadDelay maxBound-  return (Right Null)+  pure $ InR Null
src/Development/IDE/Plugin/TypeLenses.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP              #-} {-# LANGUAGE DeriveAnyClass   #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeFamilies     #-}@@ -13,85 +14,106 @@   Log(..)   ) where -import           Control.Concurrent.STM.Stats        (atomically)-import           Control.DeepSeq                     (rwhnf)-import           Control.Monad                       (mzero)-import           Control.Monad.Extra                 (whenMaybe)-import           Control.Monad.IO.Class              (MonadIO (liftIO))-import           Data.Aeson.Types                    (Value (..), toJSON)-import qualified Data.Aeson.Types                    as A-import qualified Data.HashMap.Strict                 as Map-import           Data.List                           (find)-import           Data.Maybe                          (catMaybes)-import qualified Data.Text                           as T-import           Development.IDE                     (GhcSession (..),-                                                      HscEnvEq (hscEnv),-                                                      RuleResult, Rules, define,-                                                      srcSpanToRange)-import           Development.IDE.Core.Compile        (TcModuleResult (..))-import           Development.IDE.Core.RuleTypes      (GetBindings (GetBindings),-                                                      TypeCheck (TypeCheck))-import           Development.IDE.Core.Rules          (IdeState, runAction)-import           Development.IDE.Core.Service        (getDiagnostics)-import           Development.IDE.Core.Shake          (getHiddenDiagnostics, use)-import qualified Development.IDE.Core.Shake          as Shake+import           Control.Concurrent.STM.Stats         (atomically)+import           Control.DeepSeq                      (rwhnf)+import           Control.Lens                         ((?~), (^?))+import           Control.Monad                        (mzero)+import           Control.Monad.Extra                  (whenMaybe)+import           Control.Monad.IO.Class               (MonadIO (liftIO))+import           Control.Monad.Trans.Class            (MonadTrans (lift))+import           Data.Aeson.Types                     (toJSON)+import qualified Data.Aeson.Types                     as A+import           Data.List                            (find)+import qualified Data.Map                             as Map+import           Data.Maybe                           (catMaybes, isJust,+                                                       maybeToList)+import qualified Data.Text                            as T+import           Development.IDE                      (FileDiagnostic (..),+                                                       GhcSession (..),+                                                       HscEnvEq (hscEnv),+                                                       RuleResult, Rules, Uri,+                                                       _SomeStructuredMessage,+                                                       define,+                                                       fdStructuredMessageL,+                                                       srcSpanToRange,+                                                       usePropertyAction)+import           Development.IDE.Core.Compile         (TcModuleResult (..))+import           Development.IDE.Core.PluginUtils+import           Development.IDE.Core.PositionMapping (PositionMapping,+                                                       fromCurrentRange,+                                                       toCurrentRange)+import           Development.IDE.Core.Rules           (IdeState, runAction)+import           Development.IDE.Core.RuleTypes       (TypeCheck (TypeCheck))+import           Development.IDE.Core.Service         (getDiagnostics)+import           Development.IDE.Core.Shake           (getHiddenDiagnostics,+                                                       use)+import qualified Development.IDE.Core.Shake           as Shake import           Development.IDE.GHC.Compat-import           Development.IDE.GHC.Util            (printName)+import           Development.IDE.GHC.Compat.Error     (_TcRnMessage,+                                                       _TcRnMissingSignature,+                                                       msgEnvelopeErrorL)+import           Development.IDE.GHC.Util             (printName) import           Development.IDE.Graph.Classes-import           Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope)-import           Development.IDE.Types.Location      (Position (Position, _character, _line),-                                                      Range (Range, _end, _start),-                                                      toNormalizedFilePath',-                                                      uriToFilePath')-import           Development.IDE.Types.Logger        (Pretty (pretty), Recorder,-                                                      WithPriority,-                                                      cmapWithPrio)-import           GHC.Generics                        (Generic)-import           Ide.Plugin.Config                   (Config)+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,+                                                       cmapWithPrio)+import           Ide.Plugin.Error import           Ide.Plugin.Properties-import           Ide.PluginUtils                     (mkLspCommand,-                                                      usePropertyLsp)-import           Ide.Types                           (CommandFunction,-                                                      CommandId (CommandId),-                                                      PluginCommand (PluginCommand),-                                                      PluginDescriptor (..),-                                                      PluginId,-                                                      configCustomConfig,-                                                      defaultConfigDescriptor,-                                                      defaultPluginDescriptor,-                                                      mkCustomConfig,-                                                      mkPluginHandler)-import qualified Language.LSP.Server                 as LSP-import           Language.LSP.Types                  (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),-                                                      CodeLens (CodeLens),-                                                      CodeLensParams (CodeLensParams, _textDocument),-                                                      Diagnostic (..),-                                                      List (..), ResponseError,-                                                      SMethod (..),-                                                      TextDocumentIdentifier (TextDocumentIdentifier),-                                                      TextEdit (TextEdit),-                                                      WorkspaceEdit (WorkspaceEdit))-import           Text.Regex.TDFA                     ((=~), (=~~))+import           Ide.PluginUtils                      (mkLspCommand)+import           Ide.Types                            (CommandFunction,+                                                       CommandId (CommandId),+                                                       PluginCommand (PluginCommand),+                                                       PluginDescriptor (..),+                                                       PluginId,+                                                       PluginMethodHandler,+                                                       ResolveFunction,+                                                       configCustomConfig,+                                                       defaultConfigDescriptor,+                                                       defaultPluginDescriptor,+                                                       mkCustomConfig,+                                                       mkPluginHandler,+                                                       mkResolveHandler,+                                                       pluginSendRequest)+import qualified Language.LSP.Protocol.Lens           as L+import           Language.LSP.Protocol.Message        (Method (Method_CodeLensResolve, Method_TextDocumentCodeLens),+                                                       SMethod (..))+import           Language.LSP.Protocol.Types          (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),+                                                       CodeLens (..),+                                                       CodeLensParams (CodeLensParams, _textDocument),+                                                       Command, Diagnostic (..),+                                                       Null (Null),+                                                       TextDocumentIdentifier (TextDocumentIdentifier),+                                                       TextEdit (TextEdit),+                                                       WorkspaceEdit (WorkspaceEdit),+                                                       type (|?) (..))  data Log = LogShake Shake.Log deriving Show  instance Pretty Log where   pretty = \case-    LogShake log -> pretty log+    LogShake msg -> pretty msg + typeLensCommandId :: T.Text typeLensCommandId = "typesignature.add"  descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId =-  (defaultPluginDescriptor plId)-    { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider+  (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 :: Properties '[ 'PropertyKey "mode" (TEnum Mode)] properties = emptyProperties   & defineEnumProperty #mode "Control how type lenses are shown"     [ (Always, "Always displays type lenses of global bindings")@@ -99,109 +121,148 @@     , (Diagnostics, "Follows error messages produced by GHC about missing signatures")     ] Always -codeLensProvider ::-  IdeState ->-  PluginId ->-  CodeLensParams ->-  LSP.LspM Config (Either ResponseError (List CodeLens))+codeLensProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do-  mode <- usePropertyLsp #mode pId properties-  fmap (Right . List) $ case uriToFilePath' uri of-    Just (toNormalizedFilePath' -> filePath) -> liftIO $ do-      env <- fmap hscEnv <$> runAction "codeLens.GhcSession" ideState (use GhcSession filePath)-      tmr <- runAction "codeLens.TypeCheck" ideState (use TypeCheck filePath)-      bindings <- runAction "codeLens.GetBindings" ideState (use GetBindings filePath)-      gblSigs <- runAction "codeLens.GetGlobalBindingTypeSigs" ideState (use GetGlobalBindingTypeSigs filePath)--      diag <- atomically $ getDiagnostics ideState-      hDiag <- atomically $ getHiddenDiagnostics ideState--      let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing-          generateLensForGlobal sig@GlobalBindingTypeSig{..} = do-            range <- srcSpanToRange $ gbSrcSpan sig-            tedit <- gblBindingTypeSigToEdit sig-            let wedit = toWorkSpaceEdit [tedit]-            pure $ generateLens pId range (T.pack gbRendered) wedit-          gblSigs' = maybe [] (\(GlobalBindingTypeSigsResult x) -> x) gblSigs-          generateLensFromDiags f =-            sequence-              [ pure $ generateLens pId _range title edit-              | (dFile, _, dDiag@Diagnostic{_range = _range}) <- diag ++ hDiag-              , dFile == filePath-              , (title, tedit) <- f dDiag-              , let edit = toWorkSpaceEdit tedit-              ]+    mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties+    nfp <- getNormalizedFilePathE uri+    -- We have two ways we can possibly generate code lenses for type lenses.+    -- Different options are with different "modes" of the type-lenses plugin.+    -- (Remember here, as the code lens is not resolved yet, we only really need+    -- the range and any data that will help us resolve it later)+    let -- The first option is to generate lens from diagnostics about+        -- top level bindings.+        generateLensFromGlobalDiags diags =+          -- 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)+            | 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+        -- with PositionMapping.+        -- PositionMapping for diagnostics doesn't make sense, because we always+        -- have fresh diagnostics even if current module parsed failed (the+        -- diagnostic would then be parse failed). See+        -- https://github.com/haskell/haskell-language-server/pull/3558 for this+        -- discussion.+        generateLensFromGlobal sigs mp = do+          [ CodeLens newRange Nothing (Just $ toJSON TypeLensesResolve)+            | sig <- sigs+            , Just range <- [srcSpanToRange (gbSrcSpan sig)]+            , Just newRange <- [toCurrentRange mp range]]+    if mode == Always || mode == Exported+      then do+        -- In this mode we get the global bindings from the+        -- GlobalBindingTypeSigs rule.+        (GlobalBindingTypeSigsResult gblSigs, gblSigsMp) <-+          runActionE "codeLens.GetGlobalBindingTypeSigs" ideState+          $ useWithStaleE GetGlobalBindingTypeSigs nfp+        -- Depending on whether we only want exported or not we filter our list+        -- of signatures to get what we want+        let relevantGlobalSigs =+              if mode == Exported+                then filter gbExported gblSigs+                else gblSigs+        pure $ InL $ generateLensFromGlobal relevantGlobalSigs gblSigsMp+      else do+        -- For this mode we exclusively use diagnostics to create the lenses.+        -- However we will still use the GlobalBindingTypeSigs to resolve them.+        diags <- liftIO $ atomically $ getDiagnostics ideState+        hDiags <- liftIO $ atomically $ getHiddenDiagnostics ideState+        let allDiags = diags <> hDiags+        pure $ InL $ generateLensFromGlobalDiags allDiags -      case mode of-        Always ->-          pure (catMaybes $ generateLensForGlobal <$> gblSigs')-            <> generateLensFromDiags (suggestLocalSignature False env tmr bindings) -- we still need diagnostics for local bindings-        Exported -> pure $ catMaybes $ generateLensForGlobal <$> filter gbExported gblSigs'-        Diagnostics -> generateLensFromDiags $ suggestSignature False env gblSigs tmr bindings-    Nothing -> pure []+codeLensResolveProvider :: ResolveFunction IdeState TypeLensesResolve Method_CodeLensResolve+codeLensResolveProvider ideState pId lens@CodeLens{_range} uri TypeLensesResolve = do+  nfp <- getNormalizedFilePathE uri+  (gblSigs@(GlobalBindingTypeSigsResult _), pm) <-+    runActionE "codeLens.GetGlobalBindingTypeSigs" ideState+    $ useWithStaleE GetGlobalBindingTypeSigs nfp+  -- regardless of how the original lens was generated, we want to get the range+  -- that the global bindings rule would expect here, hence the need to reverse+  -- position map the range, regardless of whether it was position mapped in the+  -- beginning or freshly taken from diagnostics.+  newRange <- handleMaybe PluginStaleResolve (fromCurrentRange pm _range)+  -- We also pass on the PositionMapping so that the generated text edit can+  -- have the range adjusted.+  (title, edit) <-+        handleMaybe PluginStaleResolve $ suggestGlobalSignature' False (Just gblSigs) (Just pm) newRange+  pure $ lens & L.command ?~ generateLensCommand pId uri title edit -generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens-generateLens pId _range title edit =-  let cId = mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit])-   in CodeLens _range (Just cId) Nothing+generateLensCommand :: PluginId -> Uri -> T.Text -> TextEdit -> Command+generateLensCommand pId uri title edit =+  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+-- rule can't be changed as it is also used by the hls-refactor plugin, we can't+-- rely on actions. Because we can't rely on actions it doesn't make sense to+-- recompute the edit upon command. Hence the command here just takes a edit+-- and applies it. commandHandler :: CommandFunction IdeState WorkspaceEdit-commandHandler _ideState wedit = do-  _ <- LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())-  return $ Right Null+commandHandler _ideState _ wedit = do+  _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())+  pure $ InR Null  --------------------------------------------------------------------------------+suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> FileDiagnostic -> [(T.Text, TextEdit)]+suggestSignature isQuickFix mGblSigs diag =+  maybeToList (suggestGlobalSignature isQuickFix mGblSigs diag) -suggestSignature :: Bool -> Maybe HscEnv -> Maybe GlobalBindingTypeSigsResult -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])]-suggestSignature isQuickFix env mGblSigs mTmr mBindings diag =-  suggestGlobalSignature isQuickFix mGblSigs diag <> suggestLocalSignature isQuickFix env mTmr mBindings diag+-- The suggestGlobalSignature is separated into two functions. The main function+-- 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 -> FileDiagnostic -> Maybe (T.Text, TextEdit)+suggestGlobalSignature isQuickFix mGblSigs diag@FileDiagnostic {fdLspDiagnostic = Diagnostic {_range}}+  | isGlobalDiagnostic diag =+    suggestGlobalSignature' isQuickFix mGblSigs Nothing _range+  | otherwise = Nothing -suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, [TextEdit])]-suggestGlobalSignature isQuickFix mGblSigs Diagnostic{_message, _range}-  | _message-      =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text)-    , Just (GlobalBindingTypeSigsResult sigs) <- mGblSigs-    , Just sig <- find (\x -> sameThing (gbSrcSpan x) _range) sigs-    , signature <- T.pack $ gbRendered sig-    , title <- if isQuickFix then "add signature: " <> signature else signature-    , Just action <- gblBindingTypeSigToEdit sig =-    [(title, [action])]-  | otherwise = []+isGlobalDiagnostic :: FileDiagnostic -> Bool+isGlobalDiagnostic diag = diag ^? fdStructuredMessageL+                                  . _SomeStructuredMessage+                                  . msgEnvelopeErrorL+                                  .  _TcRnMessage+                                  . _TcRnMissingSignature+                                & isJust -suggestLocalSignature :: Bool -> Maybe HscEnv -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])]-suggestLocalSignature isQuickFix mEnv mTmr mBindings Diagnostic{_message, _range = _range@Range{..}}-  | Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, [identifier]) <--      (T.unwords . T.words $ _message)-        =~~ ("Polymorphic local binding with no type signature: (.*) ::" :: T.Text)-    , Just bindings <- mBindings-    , Just env <- mEnv-    , localScope <- getFuzzyScope bindings _start _end-    , -- we can't use srcspan to lookup scoped bindings, because the error message reported by GHC includes the entire binding, instead of simply the name-      Just (name, ty) <- find (\(x, _) -> printName x == T.unpack identifier) localScope >>= \(name, mTy) -> (name,) <$> mTy-    , Just TcModuleResult{tmrTypechecked = TcGblEnv{tcg_rdr_env, tcg_sigs}} <- mTmr-    , -- not a top-level thing, to avoid duplication-      not $ name `elemNameSet` tcg_sigs-    , tyMsg <- printSDocQualifiedUnsafe (mkPrintUnqualifiedDefault env tcg_rdr_env) $ pprSigmaType ty-    , signature <- T.pack $ printName name <> " :: " <> tyMsg-    , startCharacter <- _character _start-    , startOfLine <- Position (_line _start) startCharacter-    , beforeLine <- Range startOfLine startOfLine+-- If a PositionMapping is supplied, this function will call+-- gblBindingTypeSigToEdit with it to create a TextEdit in the right location.+suggestGlobalSignature' :: Bool -> Maybe GlobalBindingTypeSigsResult -> Maybe PositionMapping -> Range -> Maybe (T.Text, TextEdit)+suggestGlobalSignature' isQuickFix mGblSigs pm range+  |   Just (GlobalBindingTypeSigsResult sigs) <- mGblSigs+    , Just sig <- find (\x -> sameThing (gbSrcSpan x) range) sigs+    , signature <- T.pack $ gbRendered sig     , title <- if isQuickFix then "add signature: " <> signature else signature-    , action <- TextEdit beforeLine $ signature <> "\n" <> T.replicate (fromIntegral startCharacter) " " =-    [(title, [action])]-  | otherwise = []+    , Just action <- gblBindingTypeSigToEdit sig pm =+    Just (title, action)+  | otherwise = Nothing  sameThing :: SrcSpan -> Range -> Bool sameThing s1 s2 = (_start <$> srcSpanToRange s1) == (_start <$> Just s2) -gblBindingTypeSigToEdit :: GlobalBindingTypeSig -> Maybe TextEdit-gblBindingTypeSigToEdit GlobalBindingTypeSig{..}+gblBindingTypeSigToEdit :: GlobalBindingTypeSig -> Maybe PositionMapping -> Maybe TextEdit+gblBindingTypeSigToEdit GlobalBindingTypeSig{..} mmp   | Just Range{..} <- srcSpanToRange $ getSrcSpan gbName     , startOfLine <- Position (_line _start) 0-    , beforeLine <- Range startOfLine startOfLine =-    Just $ TextEdit beforeLine $ T.pack gbRendered <> "\n"+    , beforeLine <- Range startOfLine startOfLine+    -- If `mmp` is `Nothing`, return the original range,+    -- otherwise we apply `toCurrentRange`, and the guard should fail if `toCurrentRange` failed.+    , Just range <- maybe (Just beforeLine) (flip toCurrentRange beforeLine) mmp+    -- We need to flatten the signature, as otherwise long signatures are+    -- rendered on multiple lines with invalid formatting.+    , renderedFlat <- unwords $ lines gbRendered+    = Just $ TextEdit range $ T.pack renderedFlat <> "\n"   | otherwise = Nothing +-- |We don't need anything to resolve our lens, but a data field is mandatory+-- to get types resolved in HLS+data TypeLensesResolve = TypeLensesResolve+  deriving (Generic, A.FromJSON, A.ToJSON)+ data Mode   = -- | always displays type lenses of global bindings, no matter what GHC flags are set     Always@@ -269,11 +330,15 @@       showDoc = showDocRdrEnv hsc rdrEnv       hasSig :: (Monad m) => Name -> m a -> m (Maybe a)       hasSig name f = whenMaybe (name `elemNameSet` sigs) f-      bindToSig id = do-        let name = idName id+      bindToSig identifier = liftZonkM $ do+        let name = idName identifier         hasSig name $ do           env <- tcInitTidyEnv-          let (_, ty) = tidyOpenType env (idType id)+#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,9 +1,8 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP        #-}-{-# LANGUAGE GADTs      #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP   #-}+{-# LANGUAGE GADTs #-}  -- | Gives information about symbols at a given point in DAML files. -- These are all pure functions that should execute quickly.@@ -11,6 +10,7 @@     atPoint   , gotoDefinition   , gotoTypeDefinition+  , gotoImplementation   , documentHighlight   , pointCommand   , referencesAtPoint@@ -20,23 +20,32 @@   , getNamesAtPoint   , toCurrentLocation   , rowToLoc+  , nameToLocation+  , 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-import           Language.LSP.Types+import           Language.LSP.Protocol.Types          hiding+                                                      (SemanticTokenAbsolute (..))+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,+                                                       printOutputableOneLine) import           Development.IDE.Spans.Common import           Development.IDE.Types.Options-import           Development.IDE.GHC.Util             (printOutputable) -import           Control.Applicative import           Control.Monad.Extra import           Control.Monad.IO.Class import           Control.Monad.Trans.Class@@ -49,18 +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           HieDb                                hiding (pointCommand)+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)) @@ -89,17 +125,17 @@     Just (HAR _ hf _ _ _,mapping) ->       let names = getNamesAtPoint hf pos mapping           adjustedLocs = HM.foldr go [] asts-          go (HAR _ _ rf tr _, mapping) xs = refs ++ typerefs ++ xs+          go (HAR _ _ rf tr _, goMapping) xs = refs ++ typerefs ++ xs             where-              refs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation . fst)-                   $ concat $ mapMaybe (\n -> M.lookup (Right n) rf) names-              typerefs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation)-                   $ concat $ mapMaybe (`M.lookup` tr) names+              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 @@ -129,8 +165,8 @@   typeRefs <- forM names $ \name ->     case nameModule_maybe name of       Just mod | isTcClsNameSpace (occNameSpace $ nameOccName name) -> do-        refs <- liftIO $ withHieDb (\hieDb -> findTypeRefs hieDb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude)-        pure $ mapMaybe typeRowToLoc refs+        refs' <- liftIO $ withHieDb (\hieDb -> findTypeRefs hieDb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude)+        pure $ mapMaybe typeRowToLoc refs'       _ -> pure []   pure $ nubOrd $ foiRefs ++ concat nonFOIRefs ++ concat typeRefs @@ -161,24 +197,25 @@   -> MaybeT m [DocumentHighlight] documentHighlight hf rf pos = pure highlights   where-#if MIN_VERSION_ghc(9,0,1)     -- We don't want to show document highlights for evidence variables, which are supposed to be invisible     notEvidence = not . any isEvidenceContext . identInfo-#else-    notEvidence = const True-#endif-    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 HkWrite-        else HkRead+        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@@ -186,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 @@ -197,67 +234,271 @@   -> 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-  -> Maybe (Maybe Range, [T.Text])-atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ pointCommand hf pos hoverInfo+  -> Util.EnumSet Extension+  -> IO (Maybe (Maybe Range, [T.Text]))+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 ast = (Just range, prettyNames ++ pTypes)+    hoverInfo :: HieAST hietype -> IO (Maybe Range, [T.Text])+    hoverInfo ast = do+        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-          | 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 x = "\n```haskell\n"<>x<>"\n```\n"+        info :: NodeInfo hietype         info = nodeInfoH kind ast-        names = M.assocs $ nodeIdentifiers info-        types = nodeType info -        prettyNames :: [T.Text]-        prettyNames = map prettyName names-        prettyName (Right n, dets) = T.unlines $-          wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind))-          : definedAt n-          ++ maybeToList (prettyPackageName n)-          ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n-                       ]-          where maybeKind = fmap printOutputable $ safeTyThingType =<< lookupNameEnv km n-        prettyName (Left m,_) = printOutputable m+        -- We want evidence variables to be displayed last.+        -- Evidence trees contain information of secondary relevance.+        names :: [(Identifier, IdentifierDetails hietype)]+        names = sortOn (any isEvidenceUse . identInfo . snd) $ M.assocs $ nodeIdentifiers info +        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)++            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 _locationsMap (Left m,_) = packageNameForImportStatement m++        prettyPackageName :: Name -> Maybe T.Text         prettyPackageName n = do           m <- nameModule_maybe n+          pkgTxt <- packageNameWithVersion m+          pure $ "*(" <> pkgTxt <> ")*"++        -- Return the module text itself and+        -- the package(with version) this `ModuleName` belongs to.+        packageNameForImportStatement :: ModuleName -> IO T.Text+        packageNameForImportStatement mod = do+          mpkg <- findImportedModule (setNonHomeFCHook env) mod :: IO (Maybe Module)+          let moduleName = printOutputable mod+          case mpkg >>= packageNameWithVersion of+            Nothing             -> pure moduleName+            Just pkgWithVersion -> pure $ moduleName <> "\n\n" <> pkgWithVersion++        -- Return the package name and version of a module.+        -- For example, given module `Data.List`, it should return something like `base-4.x`.+        packageNameWithVersion :: Module -> Maybe T.Text+        packageNameWithVersion m = do           let pid = moduleUnit m           conf <- lookupUnit env pid           let pkgName = T.pack $ unitPackageNameString conf               version = T.pack $ showVersion (unitPackageVersion conf)-          pure $ " *(" <> pkgName <> "-" <> version <> ")*"+          pure $ pkgName <> "-" <> version -        prettyTypes = map (("_ :: "<>) . prettyType) types-        prettyType t = case kind of-          HieFresh -> printOutputable t-          HieFromDisk full_file -> printOutputable $ hieTypeToIface $ recoverFullType t (hie_types full_file)+        -- Type info for the current node, it may contain several symbols+        -- for one range, like wildcard+        types :: [hietype]+        types = take maxHoverTypes $ nodeType info +        maxHoverTypes :: Int+        maxHoverTypes = 10++        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           -- see the code of 'pprNameDefnLoc' for more information           case nameSrcLoc name of-            UnhelpfulLoc {} | isInternalName name || isSystemName name -> []-            _ -> ["*Defined " <> printOutputable (pprNameDefnLoc name) <> "*"]+            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@@ -266,69 +507,98 @@   -> 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+          getTypes' ts' = flip concatMap (unfold ts') $ \case             HTyVarTy n -> [n]-#if MIN_VERSION_ghc(8,8,0)-            HAppTy a (HieArgs xs) -> getTypes (a : map snd xs)-#else-            HAppTy a b -> getTypes [a,b]-#endif-            HTyConApp tc (HieArgs xs) -> ifaceTyConName tc : getTypes (map snd xs)-            HForAllTy _ a -> getTypes [a]-#if MIN_VERSION_ghc(9,0,1)-            HFunTy a b c -> getTypes [a,b,c]-#else-            HFunTy a b -> getTypes [a,b]-#endif-            HQualTy a b -> getTypes [a,b]-            HCastTy a -> getTypes [a]+            HAppTy a (HieArgs xs) -> getTypes' (a : map snd xs)+            HTyConApp tc (HieArgs xs) -> ifaceTyConName tc : getTypes' (map snd xs)+            HForAllTy _ a -> getTypes' [a]+            HFunTy a b c -> getTypes' [a,b,c]+            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 $@@ -360,8 +630,8 @@           -- This is a hack to make find definition work better with ghcide's nascent multi-component support,           -- where names from a component that has been indexed in a previous session but not loaded in this           -- session may end up with different unit ids-          erow <- liftIO $ withHieDb (\hieDb -> findDef hieDb (nameOccName name) (Just $ moduleName mod) Nothing)-          case erow of+          erow' <- liftIO $ withHieDb (\hieDb -> findDef hieDb (nameOccName name) (Just $ moduleName mod) Nothing)+          case erow' of             [] -> MaybeT $ pure Nothing             xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs         xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs@@ -381,13 +651,15 @@  defRowToSymbolInfo :: Res DefRow -> Maybe SymbolInformation defRowToSymbolInfo (DefRow{..}:.(modInfoSrcFile -> Just srcFile))-  = Just $ SymbolInformation (printOutputable defNameOcc) kind Nothing Nothing loc Nothing+  = Just $ SymbolInformation (printOutputable defNameOcc) kind Nothing Nothing Nothing loc   where     kind-      | isVarOcc defNameOcc = SkVariable-      | isDataOcc defNameOcc = SkConstructor-      | isTcOcc defNameOcc = SkStruct-      | otherwise = SkUnknown 1+      | isVarOcc defNameOcc = SymbolKind_Variable+      | isDataOcc defNameOcc = SymbolKind_Constructor+      | isTcOcc defNameOcc = SymbolKind_Struct+        -- This used to be (SkUnknown 1), buth there is no SymbolKind_Unknown.+        -- Changing this to File, as that is enum representation of 1+      | otherwise = SymbolKind_File     loc   = Location file range     file  = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' $ srcFile     range = Range start end@@ -397,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)@@ -414,6 +686,7 @@  where    sloc fs = mkRealSrcLoc fs (fromIntegral $ line+1) (fromIntegral $ cha+1)    sp fs = mkRealSrcSpan (sloc fs) (sloc fs)+   line :: UInt    line = _line pos    cha = _character pos
src/Development/IDE/Spans/Common.hs view
@@ -4,7 +4,6 @@  module Development.IDE.Spans.Common (   unqualIEWrapName-, safeTyThingId , safeTyThingType , SpanDoc(..) , SpanDocUris(..)@@ -12,48 +11,49 @@ , 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           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.-unqualIEWrapName :: IEWrappedName RdrName -> T.Text+unqualIEWrapName :: IEWrappedName GhcPs -> T.Text 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 data SpanDoc-  = SpanDocString HsDocString SpanDocUris-    -- ^ Extern module doc+  = SpanDocString [HsDocString] SpanDocUris   | SpanDocText   [T.Text] SpanDocUris-    -- ^ Local module doc   deriving stock (Eq, Show, Generic)   deriving anyclass NFData @@ -80,10 +80,16 @@ -- it will result "xxxx---\nyyyy" and can't be rendered as a normal doc. -- Therefore we check every item in the value to make sure they all end with '\\n', -- this makes "xxxx\n---\nyyy\n" and can be rendered correctly.+--+-- Notes:+--+-- To insert a new line in Markdown, we need two '\\n', like ("\\n\\n"), __or__ a section+-- symbol with one '\\n', like ("***\\n"). spanDocToMarkdown :: SpanDoc -> [T.Text] spanDocToMarkdown = \case     (SpanDocString docs uris) ->-        let doc = T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs+        let doc = T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $+                      renderHsDocStrings docs         in  go [doc] uris     (SpanDocText txt uris) -> go txt uris   where@@ -100,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@@ -166,16 +178,19 @@  haddockToMarkdown (H.DocUnorderedList things)   = '\n' : (unlines $ map (("+ " ++) . trimStart . splitForList . haddockToMarkdown) things)-haddockToMarkdown (H.DocOrderedList things)-  = '\n' : (unlines $ map (("1. " ++) . trimStart . splitForList . haddockToMarkdown) things)+haddockToMarkdown (H.DocOrderedList things) =+#if MIN_VERSION_haddock_library(1,11,0)+  '\n' : (unlines $ map ((\(num, str) -> show num ++ ". " ++ str) . second (trimStart . splitForList . haddockToMarkdown)) things)+#else+  '\n' : (unlines $ map (("1. " ++) . trimStart . splitForList . haddockToMarkdown) things)+#endif 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)@@ -202,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,60 +29,66 @@ 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 import           System.FilePath -import           Language.LSP.Types              (filePathToUri, getUri)  mkDocMap   :: HscEnv   -> RefMap a   -> TcGblEnv-  -> IO DocAndKindMap+  -> IO DocAndTyThingMap mkDocMap env rm this_mod =   do-#if MIN_VERSION_ghc(9,2,0)-     (_ , DeclDocMap this_docs, _) <- extractDocs this_mod-#else-     let (_ , DeclDocMap this_docs, _) = extractDocs this_mod-#endif-     d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names+     (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      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 map-      | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist+    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 mod n-      pure $ extendNameEnv map n doc-    getType n map-      | isTcOcc $ occName n = do-        kind <- lookupKind env mod n-        pure $ maybe map (extendNameEnv map n) kind-      | otherwise = pure map+      (doc, _argDoc) <- getDocumentationTryGhc env n+      pure $ extendNameEnv nameMap n doc+    getType n nameMap+      | 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 -lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing)-lookupKind env mod =-    fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod+lookupKind :: HscEnv -> Name -> IO (Maybe TyThing)+lookupKind env =+    fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env -getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc-getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n]+getDocumentationTryGhc :: HscEnv -> Name -> IO (SpanDoc, IntMap SpanDoc)+getDocumentationTryGhc env n =+  (fromMaybe (emptySpanDoc, mempty) . listToMaybe <$> getDocumentationsTryGhc env [n])+    `catch` (\(_ :: IOEnvFailure) -> pure (emptySpanDoc, mempty)) -getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc]-getDocumentationsTryGhc env mod names = do-  res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names-  case res of+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-    unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n+    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@@ -107,81 +113,7 @@  => [ParsedModule] -- ^ All of the possible modules it could be defined in.  ->  name -- ^ The name you want documentation for.  -> [T.Text]--- This finds any documentation between the name you want--- documentation for and the one before it. This is only an--- approximately correct algorithm and there are easily constructed--- cases where it will be wrong (if so then usually slightly but there--- may be edge cases where it is very wrong).--- TODO : Build a version of GHC exactprint to extract this information--- more accurately.--- TODO : Implement this for GHC 9.2 with in-tree annotations---        (alternatively, just remove it and rely soley on GHC's parsing)-getDocumentation sources targetName = fromMaybe [] $ do-#if MIN_VERSION_ghc(9,2,0)-  Nothing-#else-  -- Find the module the target is defined in.-  targetNameSpan <- realSpan $ getLoc targetName-  tc <--    find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)-      $ reverse sources -- TODO : Is reversing the list here really neccessary?--  -- Top level names bound by the module-  let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc-           , L _ (ValD _ hsbind) <- hsmodDecls-           , Just n <- [name_of_bind hsbind]-           ]-  -- Sort the names' source spans.-  let sortedSpans = sortedNameSpans bs-  -- Now go ahead and extract the docs.-  let docs = ann tc-  nameInd <- elemIndex targetNameSpan sortedSpans-  let prevNameSpan =-        if nameInd >= 1-        then sortedSpans !! (nameInd - 1)-        else zeroSpan $ srcSpanFile targetNameSpan-  -- Annoyingly "-- |" documentation isn't annotated with a location,-  -- so you have to pull it out from the elements.-  pure-      $ docHeaders-      $ filter (\(L target _) -> isBetween target prevNameSpan targetNameSpan)-      $ fold-      docs-  where-    -- Get the name bound by a binding. We only concern ourselves with-    -- @FunBind@ (which covers functions and variables).-    name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName)-    name_of_bind FunBind {fun_id} = Just fun_id-    name_of_bind _                = Nothing-    -- Get source spans from names, discard unhelpful spans, remove-    -- duplicates and sort.-    sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]-    sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls)-    isBetween target before after = before <= target && target <= after-#if MIN_VERSION_ghc(9,0,0)-    ann = apiAnnComments . pm_annotations-#else-    ann = fmap filterReal . snd . pm_annotations-    filterReal :: [Located a] -> [RealLocated a]-    filterReal = mapMaybe (\(L l v) -> (`L`v) <$> realSpan l)-#endif-    annotationFileName :: ParsedModule -> Maybe FastString-    annotationFileName = fmap srcSpanFile . listToMaybe . map getRealSrcSpan . fold . ann---- | Shows this part of the documentation-docHeaders :: [RealLocated AnnotationComment]-           -> [T.Text]-docHeaders = mapMaybe (\(L _ x) -> wrk x)-  where-  wrk = \case-    -- When `Opt_Haddock` is enabled.-    AnnDocCommentNext s -> Just $ T.pack s-    -- When `Opt_KeepRawTokenStream` enabled.-    AnnLineComment s  -> if "-- |" `isPrefixOf` s-                            then Just $ T.pack s-                            else Nothing-    _ -> Nothing-#endif+getDocumentation _sources _targetName = []  -- These are taken from haskell-ide-engine's Haddock plugin
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
@@ -6,24 +6,33 @@   ( NextPragmaInfo(..)   , LineSplitTextEdits(..)   , getNextPragmaInfo-  , insertNewPragma ) where+  , insertNewPragma+  , getFirstPragma ) where +import           Control.Lens                    ((&), (.~)) import           Data.Bits                       (Bits (setBit))-import           Data.Function                   ((&)) import qualified Data.List                       as List import qualified Data.Maybe                      as Maybe import           Data.Text                       (Text, pack) import qualified Data.Text                       as Text-import           Development.IDE                 (srcSpanToRange)+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-import           GHC.LanguageExtensions.Type     (Extension)-import qualified Language.LSP.Types              as LSP+import qualified Language.LSP.Protocol.Types    as LSP+import           Control.Monad.IO.Class         (MonadIO (..))+import           Control.Monad.Trans.Except     (ExceptT)+import           Ide.Plugin.Error               (PluginError)+import           Ide.Types                      (PluginId(..))+import qualified Data.Text                      as T+import           Development.IDE.Core.PluginUtils+import qualified Language.LSP.Protocol.Lens     as L -getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo-getNextPragmaInfo dynFlags sourceText =-  if | Just sourceText <- sourceText-     , 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@@ -31,13 +40,22 @@      | otherwise      -> NextPragmaInfo 0 Nothing +showExtension :: Extension -> Text+showExtension ext = pack (show ext)+ insertNewPragma :: NextPragmaInfo -> Extension -> LSP.TextEdit-insertNewPragma (NextPragmaInfo _ (Just (LineSplitTextEdits ins _))) newPragma = ins { LSP._newText = "{-# LANGUAGE " <> pack (show newPragma) <> " #-}\n" } :: LSP.TextEdit-insertNewPragma (NextPragmaInfo nextPragmaLine _) newPragma =  LSP.TextEdit pragmaInsertRange $ "{-# LANGUAGE " <> pack (show newPragma) <> " #-}\n"+insertNewPragma (NextPragmaInfo _ (Just (LineSplitTextEdits ins _))) newPragma = ins & L.newText .~ "{-# LANGUAGE " <> showExtension newPragma <> " #-}\n" :: LSP.TextEdit+insertNewPragma (NextPragmaInfo nextPragmaLine _) newPragma =  LSP.TextEdit pragmaInsertRange $ "{-# LANGUAGE " <> showExtension newPragma <> " #-}\n"     where         pragmaInsertPosition = LSP.Position (fromIntegral nextPragmaLine) 0         pragmaInsertRange = LSP.Range pragmaInsertPosition pragmaInsertPosition +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+  pure $ getNextPragmaInfo sessionDynFlags fileContents+ -- Pre-declaration comments parser -----------------------------------------------------  -- | Each mode represents the "strongest" thing we've seen so far.@@ -78,8 +96,8 @@ -- need to merge tokens that are deleted/inserted into one TextEdit each -- to work around some weird TextEdits applied in reversed order issue updateLineSplitTextEdits :: LSP.Range -> String -> Maybe LineSplitTextEdits -> LineSplitTextEdits-updateLineSplitTextEdits tokenRange tokenString prevLineSplitTextEdits-  | Just prevLineSplitTextEdits <- prevLineSplitTextEdits+updateLineSplitTextEdits tokenRange tokenString mbPrevLineSplitTextEdits+  | Just prevLineSplitTextEdits <- mbPrevLineSplitTextEdits   , let LineSplitTextEdits           { lineSplitInsertTextEdit = prevInsertTextEdit           , lineSplitDeleteTextEdit = prevDeleteTextEdit } = prevLineSplitTextEdits@@ -131,21 +149,13 @@       ModeInitial ->         case token of           ITvarsym "#" -> defaultParserState{ isLastTokenHash = True }-#if !MIN_VERSION_ghc(9,2,0)-          ITlineComment s-#else           ITlineComment s _-#endif             | isDownwardLineHaddock s -> defaultParserState{ mode = ModeHaddock }             | otherwise ->                 defaultParserState                   { nextPragma = NextPragmaInfo (endLine + 1) Nothing                   , mode = ModeComment }-#if !MIN_VERSION_ghc(9,2,0)-          ITblockComment s-#else           ITblockComment s _-#endif             | isPragma s ->                 defaultParserState                   { nextPragma = NextPragmaInfo (endLine + 1) Nothing@@ -161,11 +171,7 @@       ModeComment ->         case token of           ITvarsym "#" -> defaultParserState{ isLastTokenHash = True }-#if !MIN_VERSION_ghc(9,2,0)-          ITlineComment s-#else           ITlineComment s _-#endif             | hasDeleteStartedOnSameLine startLine prevLineSplitTextEdits             , let currLineSplitTextEdits = updateLineSplitTextEdits range s prevLineSplitTextEdits ->                 defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } }@@ -177,11 +183,7 @@                   , mode = ModeHaddock }             | otherwise ->                 defaultParserState { nextPragma = NextPragmaInfo (endLine + 1) Nothing }-#if !MIN_VERSION_ghc(9,2,0)-          ITblockComment s-#else           ITblockComment s _-#endif             | isPragma s ->                 defaultParserState                   { nextPragma = NextPragmaInfo (endLine + 1) Nothing@@ -205,21 +207,13 @@         case token of           ITvarsym "#" ->             defaultParserState{ isLastTokenHash = True }-#if !MIN_VERSION_ghc(9,2,0)-          ITlineComment s-#else           ITlineComment s _-#endif             | hasDeleteStartedOnSameLine startLine prevLineSplitTextEdits             , let currLineSplitTextEdits = updateLineSplitTextEdits range s prevLineSplitTextEdits ->                 defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } }             | otherwise ->                 defaultParserState-#if !MIN_VERSION_ghc(9,2,0)-          ITblockComment s-#else           ITblockComment s _-#endif             | isPragma s ->                 defaultParserState{                   nextPragma = NextPragmaInfo (endLine + 1) Nothing,@@ -233,11 +227,7 @@       ModePragma ->         case token of           ITvarsym "#" -> defaultParserState{ isLastTokenHash = True }-#if !MIN_VERSION_ghc(9,2,0)-          ITlineComment s-#else           ITlineComment s _-#endif             | hasDeleteStartedOnSameLine startLine prevLineSplitTextEdits             , let currLineSplitTextEdits = updateLineSplitTextEdits range s prevLineSplitTextEdits ->                 defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } }@@ -247,11 +237,7 @@                 defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } }             | otherwise ->                 defaultParserState-#if !MIN_VERSION_ghc(9,2,0)-          ITblockComment s-#else           ITblockComment s _-#endif             | isPragma s ->                 defaultParserState{ nextPragma = NextPragmaInfo (endLine + 1) Nothing, lastPragmaLine = endLine }             | hasDeleteStartedOnSameLine startLine prevLineSplitTextEdits@@ -270,8 +256,8 @@   | otherwise = prevParserState   where     hasDeleteStartedOnSameLine :: Int -> Maybe LineSplitTextEdits -> Bool-    hasDeleteStartedOnSameLine line lineSplitTextEdits-      | Just lineSplitTextEdits <- lineSplitTextEdits+    hasDeleteStartedOnSameLine line mbLineSplitTextEdits+      | Just lineSplitTextEdits <- mbLineSplitTextEdits       , let LineSplitTextEdits{ lineSplitDeleteTextEdit } = lineSplitTextEdits       , let LSP.TextEdit deleteRange _ = lineSplitDeleteTextEdit       , let LSP.Range _ deleteEndPosition = deleteRange@@ -282,11 +268,7 @@ lexUntilNextLineIncl :: P (Located Token) lexUntilNextLineIncl = do   PState{ last_loc } <- getPState-#if MIN_VERSION_ghc(9,0,0)   let PsSpan{ psRealSpan = lastRealSrcSpan } = last_loc-#else-  let lastRealSrcSpan = last_loc-#endif   let prevEndLine = lastRealSrcSpan & realSrcSpanEnd & srcLocLine   locatedToken@(L srcSpan _token) <- lexer False pure   if | RealSrcLoc currEndRealSrcLoc _ <- srcSpan & srcSpanEnd@@ -416,26 +398,10 @@     startRealSrcLoc = mkRealSrcLoc "asdf" 1 1     updateDynFlags = flip gopt_unset Opt_Haddock . flip gopt_set Opt_KeepRawTokenStream     finalDynFlags = updateDynFlags dynFlags-#if !MIN_VERSION_ghc(8,8,1)-    pState = mkPState finalDynFlags stringBuffer startRealSrcLoc-    finalPState = pState{ use_pos_prags = False }-#elif !MIN_VERSION_ghc(8,10,1)-    mkLexerParserFlags =-      mkParserFlags'-      <$> warningFlags-      <*> extensionFlags-      <*> homeUnitId_-      <*> safeImportsOn-      <*> gopt Opt_Haddock-      <*> gopt Opt_KeepRawTokenStream-      <*> const False-    finalPState = mkPStatePure (mkLexerParserFlags finalDynFlags) stringBuffer startRealSrcLoc-#else     pState = initParserState (initParserOpts finalDynFlags) stringBuffer startRealSrcLoc     PState{ options = pStateOptions } = pState     finalExtBitsMap = setBit (pExtsBitmap pStateOptions) (fromEnum UsePosPragsBit)     finalPStateOptions = pStateOptions{ pExtsBitmap = finalExtBitsMap }     finalPState = pState{ options = finalPStateOptions }-#endif   in     finalPState
src/Development/IDE/Types/Action.hs view
@@ -11,12 +11,12 @@ where  import           Control.Concurrent.STM-import           Data.HashSet                 (HashSet)-import qualified Data.HashSet                 as Set-import           Data.Hashable                (Hashable (..))-import           Data.Unique                  (Unique)-import           Development.IDE.Graph        (Action)-import           Development.IDE.Types.Logger+import           Data.Hashable          (Hashable (..))+import           Data.HashSet           (HashSet)+import qualified Data.HashSet           as Set+import           Data.Unique            (Unique)+import           Development.IDE.Graph  (Action)+import           Ide.Logger import           Numeric.Natural  data DelayedAction a = DelayedAction@@ -69,13 +69,13 @@ abortQueue x ActionQueue {..} = do   qq <- flushTQueue newActions   mapM_ (writeTQueue newActions) (filter (/= x) qq)-  modifyTVar inProgress (Set.delete x)+  modifyTVar' inProgress (Set.delete x)  -- | Mark an action as complete when called after 'popQueue'. --   Has no effect otherwise doneQueue :: DelayedActionInternal -> ActionQueue -> STM () doneQueue x ActionQueue {..} = do-  modifyTVar inProgress (Set.delete x)+  modifyTVar' inProgress (Set.delete x)  countQueue :: ActionQueue -> STM Natural countQueue ActionQueue{..} = do
src/Development/IDE/Types/Diagnostics.hs view
@@ -1,36 +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,-  List(..),   ideErrorText,   ideErrorWithSource,+  ideErrorFromLspDiag,   showDiagnostics,   showDiagnosticsColored,-  IdeResultNoDiagnosticsEarlyCutoff) where+  showGhcCode,+  IdeResultNoDiagnosticsEarlyCutoff,+  attachReason,+  attachedReason) where  import           Control.DeepSeq-import           Data.Maybe                                as Maybe-import qualified Data.Text                                 as T-import           Data.Text.Prettyprint.Doc-import           Data.Text.Prettyprint.Doc.Render.Terminal (Color (..), color)-import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal-import           Data.Text.Prettyprint.Doc.Render.Text-import           Language.LSP.Diagnostics-import           Language.LSP.Types                        as LSP (Diagnostic (..),-                                                                   DiagnosticSeverity (..),-                                                                   DiagnosticSource,-                                                                   List (..))--import           Data.ByteString                           (ByteString)+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.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,@@ -48,24 +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 DsError)+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 DiagnosticSource+  :: 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-    })+  -> 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.@@ -82,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)@@ -108,23 +270,27 @@ 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.DsError   -> annotate $ color Red-              LSP.DsWarning -> annotate $ color Yellow-              LSP.DsInfo    -> annotate $ color Blue-              LSP.DsHint    -> annotate $ color Magenta+              LSP.DiagnosticSeverity_Error       -> annotate $ color Red+              LSP.DiagnosticSeverity_Warning     -> annotate $ color Yellow+              LSP.DiagnosticSeverity_Information -> annotate $ color Blue+              LSP.DiagnosticSeverity_Hint        -> annotate $ color Magenta             $ stringParagraphs _message         ]     where-        sev = fromMaybe LSP.DsError _severity+        sev = fromMaybe LSP.DiagnosticSeverity_Error _severity   -- | Label a document.@@ -152,3 +318,9 @@  defaultTermWidth :: Int defaultTermWidth = 80++makePrisms ''StructuredMessage++makeLensesWith+    (lensRules & lensField .~ mappingNamer (pure . (++ "L")))+    ''FileDiagnostic
src/Development/IDE/Types/Exports.hs view
@@ -1,155 +1,180 @@ {-# LANGUAGE DeriveAnyClass     #-} {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE RankNTypes         #-} module Development.IDE.Types.Exports (     IdentInfo(..),     ExportsMap(..),+    rendered,+    moduleNameText,+    occNameText,+    renderOcc,+    mkTypeOcc,+    mkVarOrDataOcc,+    isDatacon,     createExportsMap,     createExportsMapMg,-    createExportsMapTc,     buildModuleExportMapFrom,     createExportsMapHieDb,     size,+    exportsMapSize,     updateExportsMapMg     ) where -import           Control.DeepSeq             (NFData (..))+import           Control.DeepSeq             (NFData (..), force, ($!!)) import           Control.Monad-import           Data.Bifunctor              (Bifunctor (second))-import           Data.HashMap.Strict         (HashMap, elems)-import qualified Data.HashMap.Strict         as Map+import           Data.Char                   (isUpper)+import           Data.Hashable               (Hashable) import           Data.HashSet                (HashSet) import qualified Data.HashSet                as Set-import           Data.Hashable               (Hashable)-import           Data.List                   (isSuffixOf, foldl')-import           Data.Text                   (Text, pack)+import           Data.List                   (isSuffixOf)+import           Data.Text                   (Text, uncons)+import           Data.Text.Encoding          (decodeUtf8, encodeUtf8) import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Orphans ()-import           Development.IDE.GHC.Util import           GHC.Generics                (Generic)-import           HieDb+import           HieDb                       hiding (withHieDb)+import           Prelude                     hiding (mod)   data ExportsMap = ExportsMap-    { getExportsMap       :: !(HashMap IdentifierText (HashSet IdentInfo))-    , getModuleExportsMap :: !(HashMap ModuleNameText (HashSet IdentInfo))+    { getExportsMap       :: !(OccEnv (HashSet IdentInfo))+    , getModuleExportsMap :: !(ModuleNameEnv (HashSet IdentInfo))     }-    deriving (Show) -deleteEntriesForModule :: ModuleNameText -> ExportsMap -> ExportsMap-deleteEntriesForModule m em = ExportsMap-    { getExportsMap =-        let moduleIds = Map.lookupDefault mempty m (getModuleExportsMap em)-        in deleteAll-            (rendered <$> Set.toList moduleIds)-            (getExportsMap em)-    , getModuleExportsMap = Map.delete m (getModuleExportsMap em)-    }-    where-        deleteAll keys map = foldr Map.delete map keys+instance NFData ExportsMap where+  rnf (ExportsMap a b) = nonDetFoldOccEnv (\c d -> rnf c `seq` d) (seqEltsUFM rnf b) a +instance Show ExportsMap where+  show (ExportsMap occs mods) =+    unwords [ "ExportsMap { getExportsMap ="+            , printWithoutUniques $ mapOccEnv (textDoc . show) occs+            , "getModuleExportsMap ="+            , printWithoutUniques $ mapUFM (textDoc . show) mods+            , "}"+            ]++-- | `updateExportsMap old new` results in an export map containing+-- the union of old and new, but with all the module entries new overriding+-- those in old.+updateExportsMap :: ExportsMap -> ExportsMap -> ExportsMap+updateExportsMap old new = ExportsMap+  { getExportsMap = delListFromOccEnv (getExportsMap old) old_occs `plusOccEnv` getExportsMap new -- plusOccEnv is right biased+  , getModuleExportsMap = getModuleExportsMap old `plusUFM` getModuleExportsMap new -- plusUFM is right biased+  }+  where old_occs = concat [map name $ Set.toList (lookupWithDefaultUFM_Directly (getModuleExportsMap old) mempty m_uniq)+                          | m_uniq <- nonDetKeysUFM (getModuleExportsMap new)]+ size :: ExportsMap -> Int-size = sum . map length . elems . getExportsMap+size = sum . map Set.size . nonDetOccEnvElts . getExportsMap +mkVarOrDataOcc :: Text -> OccName+mkVarOrDataOcc t = mkOcc $ mkFastStringByteString $ encodeUtf8 t+  where+    mkOcc+      | Just (c,_) <- uncons t+      , c == ':' || isUpper c = mkDataOccFS+      | otherwise = mkVarOccFS++mkTypeOcc :: Text -> OccName+mkTypeOcc t = mkTcOccFS $ mkFastStringByteString $ encodeUtf8 t++exportsMapSize :: ExportsMap -> Int+exportsMapSize = nonDetFoldOccEnv (\_ x -> x+1) 0 . getExportsMap+ instance Semigroup ExportsMap where-  ExportsMap a b <> ExportsMap c d = ExportsMap (Map.unionWith (<>) a c) (Map.unionWith (<>) b d)+  ExportsMap a b <> ExportsMap c d = ExportsMap (plusOccEnv_C (<>) a c) (plusUFM_C (<>) b d)  instance Monoid ExportsMap where-  mempty = ExportsMap Map.empty Map.empty+  mempty = ExportsMap emptyOccEnv emptyUFM -type IdentifierText = Text-type ModuleNameText = Text+rendered :: IdentInfo -> Text+rendered = occNameText . name +-- | Render an identifier as imported or exported style.+-- TODO: pattern synonymoccNameText :: OccName -> Text+occNameText :: OccName -> Text+occNameText name+  | isSymOcc name = "(" <> renderedOcc <> ")"+  | isTcOcc name && isSymOcc name = "type (" <> renderedOcc <> ")"+  | otherwise = renderedOcc+  where+    renderedOcc = renderOcc name++renderOcc :: OccName -> Text+renderOcc = decodeUtf8 . bytesFS . occNameFS++moduleNameText :: IdentInfo -> Text+moduleNameText = moduleNameText' . identModuleName++moduleNameText' :: ModuleName -> Text+moduleNameText' = decodeUtf8 . bytesFS . moduleNameFS+ data IdentInfo = IdentInfo-    { name           :: !OccName-    , rendered       :: Text-    , parent         :: !(Maybe Text)-    , isDatacon      :: !Bool-    , moduleNameText :: !Text+    { name            :: !OccName+    , parent          :: !(Maybe OccName)+    , identModuleName :: !ModuleName     }     deriving (Generic, Show)     deriving anyclass Hashable +isDatacon :: IdentInfo -> Bool+isDatacon = isDataOcc . name+ instance Eq IdentInfo where     a == b = name a == name b           && parent a == parent b-          && isDatacon a == isDatacon b-          && moduleNameText a == moduleNameText b+          && identModuleName a == identModuleName b  instance NFData IdentInfo where     rnf IdentInfo{..} =         -- deliberately skip the rendered field-        rnf name `seq` rnf parent `seq` rnf isDatacon `seq` rnf moduleNameText---- | Render an identifier as imported or exported style.--- TODO: pattern synonym-renderIEWrapped :: Name -> Text-renderIEWrapped n-  | isTcOcc occ && isSymOcc occ = "type " <> pack (printName n)-  | otherwise = pack $ printName n-  where-    occ = occName n+        rnf name `seq` rnf parent `seq` rnf identModuleName -mkIdentInfos :: Text -> AvailInfo -> [IdentInfo]+mkIdentInfos :: ModuleName -> AvailInfo -> [IdentInfo] mkIdentInfos mod (AvailName n) =-    [IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod]+    [IdentInfo (nameOccName n) Nothing mod] mkIdentInfos mod (AvailFL fl) =-    [IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod]+    [IdentInfo (nameOccName n) Nothing mod]     where       n = flSelector fl mkIdentInfos mod (AvailTC parent (n:nn) flds)     -- Following the GHC convention that parent == n if parent is exported     | n == parent-    = [ IdentInfo (nameOccName n) (renderIEWrapped n) (Just $! parentP) (isDataConName n) mod-        | n <- nn ++ map flSelector flds+    = [ IdentInfo (nameOccName name) (Just $! nameOccName parent) mod+        | name <- nn ++ map flSelector flds       ] ++-      [ IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod]-    where-        parentP = pack $ printName parent+      [ IdentInfo (nameOccName n) Nothing mod]  mkIdentInfos mod (AvailTC _ nn flds)-    = [ IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod+    = [ IdentInfo (nameOccName n) Nothing mod         | n <- nn ++ map flSelector flds       ]  createExportsMap :: [ModIface] -> ExportsMap createExportsMap modIface = do   let exportList = concatMap doOne modIface-  let exportsMap = Map.fromListWith (<>) $ map (\(a,_,c) -> (a, c)) exportList-  ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList+  let exportsMap = mkOccEnv_C (<>) $ map (\(a,_,c) -> (a, c)) exportList+  force $ ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList -- UFM is lazy, so need to seq   where     doOne modIFace = do       let getModDetails = unpackAvail $ moduleName $ mi_module modIFace-      concatMap (fmap (second Set.fromList) . getModDetails) (mi_exports modIFace)+      concatMap getModDetails (mi_exports modIFace)  createExportsMapMg :: [ModGuts] -> ExportsMap createExportsMapMg modGuts = do   let exportList = concatMap doOne modGuts-  let exportsMap = Map.fromListWith (<>) $ map (\(a,_,c) -> (a, c)) exportList-  ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList+  let exportsMap = mkOccEnv_C (<>) $ map (\(a,_,c) -> (a, c)) exportList+  force $ ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList -- UFM is lazy, so need to seq   where     doOne mi = do       let getModuleName = moduleName $ mg_module mi-      concatMap (fmap (second Set.fromList) . unpackAvail getModuleName) (mg_exports mi)+      concatMap (unpackAvail getModuleName) (mg_exports mi)  updateExportsMapMg :: [ModGuts] -> ExportsMap -> ExportsMap-updateExportsMapMg modGuts old = old' <> new+updateExportsMapMg modGuts old = updateExportsMap old new     where         new = createExportsMapMg modGuts-        old' = deleteAll old (Map.keys $ getModuleExportsMap new)-        deleteAll = foldl' (flip deleteEntriesForModule) -createExportsMapTc :: [TcGblEnv] -> ExportsMap-createExportsMapTc modIface = do-  let exportList = concatMap doOne modIface-  let exportsMap = Map.fromListWith (<>) $ map (\(a,_,c) -> (a, c)) exportList-  ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList-  where-    doOne mi = do-      let getModuleName = moduleName $ tcg_mod mi-      concatMap (fmap (second Set.fromList) . unpackAvail getModuleName) (tcg_exports mi)- nonInternalModules :: ModuleName -> Bool nonInternalModules = not . (".Internal" `isSuffixOf`) . moduleNameString @@ -158,49 +183,44 @@ createExportsMapHieDb :: WithHieDb -> IO ExportsMap createExportsMapHieDb withHieDb = do     mods <- withHieDb getAllIndexedMods-    idents <- forM (filter (nonInternalModules . modInfoName . hieModInfo) mods) $ \m -> do+    idents' <- forM (filter (nonInternalModules . modInfoName . hieModInfo) mods) $ \m -> do         let mn = modInfoName $ hieModInfo m-            mText = pack $ moduleNameString mn-        fmap (wrap . unwrap mText) <$> withHieDb (\hieDb -> getExportsForModule hieDb mn)-    let exportsMap = Map.fromListWith (<>) (concat idents)-    return $ ExportsMap exportsMap $ buildModuleExportMap (concat idents)+        fmap (unwrap mn) <$> withHieDb (\hieDb -> getExportsForModule hieDb mn)+    let idents = concat idents'+    let exportsMap = mkOccEnv_C (<>) (keyWith name idents)+    return $!! ExportsMap exportsMap $ buildModuleExportMap (keyWith identModuleName idents) -- UFM is lazy so need to seq   where-    wrap identInfo = (rendered identInfo, Set.fromList [identInfo])-    -- unwrap :: ExportRow -> IdentInfo-    unwrap m ExportRow{..} = IdentInfo exportName n p exportIsDatacon m-      where-          n = pack (occNameString exportName)-          p = pack . occNameString <$> exportParent+    unwrap m ExportRow{..} = IdentInfo exportName exportParent m+    keyWith f xs = [(f x, Set.singleton x) | x <- xs] -unpackAvail :: ModuleName -> IfaceExport -> [(Text, Text, [IdentInfo])]+unpackAvail :: ModuleName -> IfaceExport -> [(OccName, ModuleName, HashSet IdentInfo)] unpackAvail mn-  | nonInternalModules mn = map f . mkIdentInfos mod+  | nonInternalModules mn = map f . mkIdentInfos mn   | otherwise = const []   where-    !mod = pack $ moduleNameString mn-    f id@IdentInfo {..} = (printOutputable name, moduleNameText,[id])+    f identInfo@IdentInfo {..} = (name, mn, Set.singleton identInfo)  -identInfoToKeyVal :: IdentInfo -> (ModuleNameText, IdentInfo)+identInfoToKeyVal :: IdentInfo -> (ModuleName, IdentInfo) identInfoToKeyVal identInfo =-  (moduleNameText identInfo, identInfo)+  (identModuleName identInfo, identInfo) -buildModuleExportMap:: [(Text, HashSet IdentInfo)] -> Map.HashMap ModuleNameText (HashSet IdentInfo)+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 -buildModuleExportMapFrom:: [ModIface] -> Map.HashMap Text (HashSet IdentInfo)+buildModuleExportMapFrom:: [ModIface] -> ModuleNameEnv (HashSet IdentInfo) buildModuleExportMapFrom modIfaces = do   let exports = map extractModuleExports modIfaces-  Map.fromListWith (<>) exports+  listToUFM_C (<>) exports -extractModuleExports :: ModIface -> (Text, HashSet IdentInfo)+extractModuleExports :: ModIface -> (ModuleName, HashSet IdentInfo) extractModuleExports modIFace = do-  let modName = pack $ moduleNameString $ moduleName $ mi_module modIFace+  let modName = moduleName $ mi_module modIFace   let functionSet = Set.fromList $ concatMap (mkIdentInfos modName) $ mi_exports modIFace   (modName, functionSet) -sortAndGroup :: [(ModuleNameText, IdentInfo)] -> Map.HashMap ModuleNameText (HashSet IdentInfo)-sortAndGroup assocs = Map.fromListWith (<>) [(k, Set.fromList [v]) | (k, v) <- assocs]+sortAndGroup :: [(ModuleName, IdentInfo)] -> ModuleNameEnv (HashSet IdentInfo)+sortAndGroup assocs = listToUFM_C (<>) [(k, Set.singleton v) | (k, v) <- assocs]
src/Development/IDE/Types/HscEnvEq.hs view
@@ -1,48 +1,38 @@+{-# LANGUAGE CPP #-} module Development.IDE.Types.HscEnvEq (   HscEnvEq,     hscEnv, newHscEnvEq,-    hscEnvWithImportPaths,-    newHscEnvEqPreserveImportPaths,-    newHscEnvEqWithImportPaths,-    envImportPaths,+    updateHscEnvEq,     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+import           Development.IDE.GHC.Compat      hiding (newUnique) import qualified Development.IDE.GHC.Compat.Util as Maybes import           Development.IDE.GHC.Error       (catchSrcErrors) 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'.+--   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,@@ -51,20 +41,45 @@         -- If Nothing, 'listVisibleModuleNames' panic     } --- | 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+updateHscEnvEq :: HscEnvEq -> HscEnv -> IO HscEnvEq+updateHscEnvEq oldHscEnvEq newHscEnv = do+  let update newUnique = oldHscEnvEq { envUnique = newUnique, hscEnv = newHscEnv }+  update <$> Unique.newUnique -    -- Make Absolute since targets are also absolute-    importPathsCanon <--      mapM makeAbsolute $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0)+-- | Wrap an 'HscEnv' into an 'HscEnvEq'.+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 @@ -84,7 +99,7 @@                         -- When module is re-exported from another package,                         -- the origin module is represented by value in Just                         Just otherPkgMod -> otherPkgMod-                        Nothing          -> mkModule (unitInfoId pkg) modName+                        Nothing          -> mkModule (mkUnit pkg) modName                 ]              doOne m = do@@ -106,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) @@ -130,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,24 +1,51 @@ {-# 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 import           Data.HashMap.Strict import qualified Data.HashMap.Strict            as HMap import           Data.HashSet import qualified Data.HashSet                   as HSet-import           Data.Hashable import           Development.IDE.GHC.Compat     (ModuleName) import           Development.IDE.GHC.Orphans    () import           Development.IDE.Types.Location import           GHC.Generics  -- | A mapping of module name to known files-type KnownTargets = HashMap Target (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(..)@@ -31,18 +30,13 @@ import           Data.Hashable                (Hashable (hash)) import           Data.Maybe                   (fromMaybe) import           Data.String+import           Language.LSP.Protocol.Types  (Location (..), Position (..),+                                               Range (..))+import qualified Language.LSP.Protocol.Types  as LSP+import           Text.ParserCombinators.ReadP as ReadP -#if MIN_VERSION_ghc(9,0,0) import           GHC.Data.FastString import           GHC.Types.SrcLoc             as GHC-#else-import           FastString-import           SrcLoc                       as GHC-#endif-import           Language.LSP.Types           (Location (..), Position (..),-                                               Range (..))-import qualified Language.LSP.Types           as LSP-import           Text.ParserCombinators.ReadP as ReadP  toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath -- We want to keep empty paths instead of normalising them to "."@@ -50,11 +44,7 @@ toNormalizedFilePath' fp = LSP.toNormalizedFilePath fp  emptyFilePath :: LSP.NormalizedFilePath-#if MIN_VERSION_lsp_types(1,3,0)-emptyFilePath = LSP.normalizedFilePath emptyPathUri ""-#else-emptyFilePath = LSP.NormalizedFilePath emptyPathUri ""-#endif+emptyFilePath = LSP.emptyNormalizedFilePath  -- | We use an empty string as a filepath when we don’t have a file. -- However, haskell-lsp doesn’t support that in uriToFilePath and given
− src/Development/IDE/Types/Logger.hs 
@@ -1,362 +0,0 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.--- SPDX-License-Identifier: Apache-2.0--{-# LANGUAGE RankNTypes #-}--- | This is a compatibility module that abstracts over the--- concrete choice of logging framework so users can plug in whatever--- framework they want to.-module Development.IDE.Types.Logger-  ( Priority(..)-  , Logger(..)-  , Recorder(..)-  , logError, logWarning, logInfo, logDebug-  , noLogging-  , WithPriority(..)-  , logWith-  , cmap-  , cmapIO-  , cfilter-  , withDefaultRecorder-  , makeDefaultStderrRecorder-  , priorityToHsLoggerPriority-  , LoggingColumn(..)-  , cmapWithPrio-  , withBacklog-  , lspClientMessageRecorder-  , lspClientLogRecorder-  , module PrettyPrinterModule-  , renderStrict-  ) where--import           Control.Concurrent            (myThreadId)-import           Control.Concurrent.Extra      (Lock, newLock, withLock)-import           Control.Concurrent.STM        (atomically,-                                                newTVarIO, writeTVar, readTVarIO, newTBQueueIO, flushTBQueue, writeTBQueue, isFullTBQueue)-import           Control.Exception             (IOException)-import           Control.Monad                 (forM_, when, (>=>), unless)-import           Control.Monad.IO.Class        (MonadIO (liftIO))-import           Data.Foldable                 (for_)-import           Data.Functor.Contravariant    (Contravariant (contramap))-import           Data.Maybe                    (fromMaybe)-import           Data.Text                     (Text)-import qualified Data.Text                     as T-import qualified Data.Text                     as Text-import qualified Data.Text.IO                  as Text-import           Data.Time                     (defaultTimeLocale, formatTime,-                                                getCurrentTime)-import           GHC.Stack                     (CallStack, HasCallStack,-                                                SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine),-                                                callStack, getCallStack,-                                                withFrozenCallStack)-import           Language.LSP.Server-import qualified Language.LSP.Server           as LSP-import           Language.LSP.Types            (LogMessageParams (..),-                                                MessageType (..),-                                                SMethod (SWindowLogMessage, SWindowShowMessage),-                                                ShowMessageParams (..))-import           Prettyprinter                 as PrettyPrinterModule-import           Prettyprinter.Render.Text     (renderStrict)-import           System.IO                     (Handle, IOMode (AppendMode),-                                                hClose, hFlush, hSetEncoding,-                                                openFile, stderr, utf8)-import qualified System.Log.Formatter          as HSL-import qualified System.Log.Handler            as HSL-import qualified System.Log.Handler.Simple     as HSL-import qualified System.Log.Logger             as HsLogger-import           UnliftIO                      (MonadUnliftIO, displayException,-                                                finally, try)--data Priority--- Don't change the ordering of this type or you will mess up the Ord--- instance-    = Debug -- ^ Verbose debug logging.-    | Info  -- ^ Useful information in case an error has to be understood.-    | Warning-      -- ^ These error messages should not occur in a expected usage, and-      -- should be investigated.-    | Error -- ^ Such log messages must never occur in expected usage.-    deriving (Eq, Show, Ord, Enum, Bounded)---- | Note that this is logging actions _of the program_, not of the user.---   You shouldn't call warning/error if the user has caused an error, only---   if our code has gone wrong and is itself erroneous (e.g. we threw an exception).-newtype Logger = Logger {logPriority :: Priority -> T.Text -> IO ()}--instance Semigroup Logger where-    l1 <> l2 = Logger $ \p t -> logPriority l1 p t >> logPriority l2 p t--instance Monoid Logger where-    mempty = Logger $ \_ _ -> pure ()--logError :: Logger -> T.Text -> IO ()-logError x = logPriority x Error--logWarning :: Logger -> T.Text -> IO ()-logWarning x = logPriority x Warning--logInfo :: Logger -> T.Text -> IO ()-logInfo x = logPriority x Info--logDebug :: Logger -> T.Text -> IO ()-logDebug x = logPriority x Debug--noLogging :: Logger-noLogging = Logger $ \_ _ -> return ()--data WithPriority a = WithPriority { priority :: Priority, callStack_ :: CallStack, payload :: a } deriving Functor---- | Note that this is logging actions _of the program_, not of the user.---   You shouldn't call warning/error if the user has caused an error, only---   if our code has gone wrong and is itself erroneous (e.g. we threw an exception).-newtype Recorder msg = Recorder-  { logger_ :: forall m. (MonadIO m) => msg -> m () }--logWith :: (HasCallStack, MonadIO m) => Recorder (WithPriority msg) -> Priority -> msg -> m ()-logWith recorder priority msg = withFrozenCallStack $ logger_ recorder (WithPriority priority callStack msg)--instance Semigroup (Recorder msg) where-  (<>) Recorder{ logger_ = logger_1 } Recorder{ logger_ = logger_2 } =-    Recorder-      { logger_ = \msg -> logger_1 msg >> logger_2 msg }--instance Monoid (Recorder msg) where-  mempty =-    Recorder-      { logger_ = \_ -> pure () }--instance Contravariant Recorder where-  contramap f Recorder{ logger_ } =-    Recorder-      { logger_ = logger_ . f }--cmap :: (a -> b) -> Recorder b -> Recorder a-cmap = contramap--cmapWithPrio :: (a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)-cmapWithPrio f = cmap (fmap f)--cmapIO :: (a -> IO b) -> Recorder b -> Recorder a-cmapIO f Recorder{ logger_ } =-  Recorder-    { logger_ = (liftIO . f) >=> logger_ }--cfilter :: (a -> Bool) -> Recorder a -> Recorder a-cfilter p Recorder{ logger_ } =-  Recorder-    { logger_ = \msg -> when (p msg) (logger_ msg) }--textHandleRecorder :: Handle -> Recorder Text-textHandleRecorder handle =-  Recorder-    { logger_ = \text -> liftIO $ Text.hPutStrLn handle text *> hFlush handle }---- | Priority is actually for hslogger compatibility-makeDefaultStderrRecorder :: MonadIO m => Maybe [LoggingColumn] -> Priority -> m (Recorder (WithPriority (Doc a)))-makeDefaultStderrRecorder columns minPriority = do-  lock <- liftIO newLock-  makeDefaultHandleRecorder columns minPriority lock stderr---- | If no path given then use stderr, otherwise use file.--- Kinda complicated because we also need to setup `hslogger` for--- `hie-bios` log compatibility reasons. If `hie-bios` can be set to use our--- logger instead or if `hie-bios` doesn't use `hslogger` then `hslogger` can--- be removed completely. See `setupHsLogger` comment.-withDefaultRecorder-  :: MonadUnliftIO m-  => Maybe FilePath-  -- ^ Log file path. `Nothing` uses stderr-  -> Maybe [LoggingColumn]-  -- ^ logging columns to display. `Nothing` uses `defaultLoggingColumns`-  -> Priority-  -- ^ min priority for hslogger compatibility-  -> (Recorder (WithPriority (Doc d)) -> m a)-  -- ^ action given a recorder-  -> m a-withDefaultRecorder path columns minPriority action = do-  lock <- liftIO newLock-  let makeHandleRecorder = makeDefaultHandleRecorder columns minPriority lock-  case path of-    Nothing -> do-      recorder <- makeHandleRecorder stderr-      let message = "No log file specified; using stderr."-      logWith recorder Info message-      action recorder-    Just path -> do-      fileHandle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode)-      case fileHandle of-        Left e -> do-          recorder <- makeHandleRecorder stderr-          let exceptionMessage = pretty $ displayException e-          let message = vcat [exceptionMessage, "Couldn't open log file" <+> pretty path <> "; falling back to stderr."]-          logWith recorder Warning message-          action recorder-        Right fileHandle -> finally (makeHandleRecorder fileHandle >>= action) (liftIO $ hClose fileHandle)--makeDefaultHandleRecorder-  :: MonadIO m-  => Maybe [LoggingColumn]-  -- ^ built-in logging columns to display. Nothing uses the default-  -> Priority-  -- ^ min priority for hslogger compatibility-  -> Lock-  -- ^ lock to take when outputting to handle-  -> Handle-  -- ^ handle to output to-  -> m (Recorder (WithPriority (Doc a)))-makeDefaultHandleRecorder columns minPriority lock handle = do-  let Recorder{ logger_ } = textHandleRecorder handle-  let threadSafeRecorder = Recorder { logger_ = \msg -> liftIO $ withLock lock (logger_ msg) }-  let loggingColumns = fromMaybe defaultLoggingColumns columns-  let textWithPriorityRecorder = cmapIO (textWithPriorityToText loggingColumns) threadSafeRecorder-  -- see `setupHsLogger` comment-  liftIO $ setupHsLogger lock handle ["hls", "hie-bios"] (priorityToHsLoggerPriority minPriority)-  pure (cmap docToText textWithPriorityRecorder)-  where-    docToText = fmap (renderStrict . layoutPretty defaultLayoutOptions)--priorityToHsLoggerPriority :: Priority -> HsLogger.Priority-priorityToHsLoggerPriority = \case-  Debug   -> HsLogger.DEBUG-  Info    -> HsLogger.INFO-  Warning -> HsLogger.WARNING-  Error   -> HsLogger.ERROR---- | The purpose of setting up `hslogger` at all is that `hie-bios` uses--- `hslogger` to output compilation logs. The easiest way to merge these logs--- with our log output is to setup an `hslogger` that uses the same handle--- and same lock as our loggers. That way the output from our loggers and--- `hie-bios` don't interleave strangely.--- It may be possible to have `hie-bios` use our logger by decorating the--- `Cradle.cradleOptsProg.runCradle` we get in the Cradle from--- `HieBios.findCradle`, but I remember trying that and something not good--- happened. I'd have to try it again to remember if that was a real issue.--- Once that is figured out or `hie-bios` doesn't use `hslogger`, then all--- references to `hslogger` can be removed entirely.-setupHsLogger :: Lock -> Handle -> [String] -> HsLogger.Priority -> IO ()-setupHsLogger lock handle extraLogNames level = do-  hSetEncoding handle utf8--  logH <- HSL.streamHandler handle level--  let logHandle  = logH-        { HSL.writeFunc = \a s -> withLock lock $ HSL.writeFunc logH a s }-      logFormatter  = HSL.tfLogFormatter logDateFormat logFormat-      logHandler = HSL.setFormatter logHandle logFormatter--  HsLogger.updateGlobalLogger HsLogger.rootLoggerName $ HsLogger.setHandlers ([] :: [HSL.GenericHandler Handle])-  HsLogger.updateGlobalLogger "haskell-lsp" $ HsLogger.setHandlers [logHandler]-  HsLogger.updateGlobalLogger "haskell-lsp" $ HsLogger.setLevel level--  -- Also route the additional log names to the same log-  forM_ extraLogNames $ \logName -> do-    HsLogger.updateGlobalLogger logName $ HsLogger.setHandlers [logHandler]-    HsLogger.updateGlobalLogger logName $ HsLogger.setLevel level-  where-    logFormat = "$time [$tid] $prio $loggername:\t$msg"-    logDateFormat = "%Y-%m-%d %H:%M:%S%Q"--data LoggingColumn-  = TimeColumn-  | ThreadIdColumn-  | PriorityColumn-  | DataColumn-  | SourceLocColumn--defaultLoggingColumns :: [LoggingColumn]-defaultLoggingColumns = [TimeColumn, PriorityColumn, DataColumn]--textWithPriorityToText :: [LoggingColumn] -> WithPriority Text -> IO Text-textWithPriorityToText columns WithPriority{ priority, callStack_, payload } = do-    textColumns <- mapM loggingColumnToText columns-    pure $ Text.intercalate " | " textColumns-    where-      showAsText :: Show a => a -> Text-      showAsText = Text.pack . show--      utcTimeToText utcTime = Text.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime--      priorityToText :: Priority -> Text-      priorityToText = showAsText--      threadIdToText = showAsText--      callStackToSrcLoc :: CallStack -> Maybe SrcLoc-      callStackToSrcLoc callStack =-        case getCallStack callStack of-          (_, srcLoc) : _ -> Just srcLoc-          _               -> Nothing--      srcLocToText = \case-          Nothing -> "<unknown>"-          Just SrcLoc{ srcLocModule, srcLocStartLine, srcLocStartCol } ->-            Text.pack srcLocModule <> "#" <> showAsText srcLocStartLine <> ":" <> showAsText srcLocStartCol--      loggingColumnToText :: LoggingColumn -> IO Text-      loggingColumnToText = \case-        TimeColumn -> do-          utcTime <- getCurrentTime-          pure (utcTimeToText utcTime)-        SourceLocColumn -> pure $ (srcLocToText . callStackToSrcLoc) callStack_-        ThreadIdColumn -> do-          threadId <- myThreadId-          pure (threadIdToText threadId)-        PriorityColumn -> pure (priorityToText priority)-        DataColumn -> pure payload---- | Given a 'Recorder' that requires an argument, produces a 'Recorder'--- that queues up messages until the argument is provided using the callback, at which--- point it sends the backlog and begins functioning normally.-withBacklog :: (v -> Recorder a) -> IO (Recorder a, v -> IO ())-withBacklog recFun = do-  -- Arbitrary backlog capacity-  backlog <- newTBQueueIO 100-  let backlogRecorder = Recorder $ \it -> liftIO $ atomically $ do-          -- If the queue is full just drop the message on the floor. This is most likely-          -- to happen if the callback is just never going to be called; in which case-          -- we want neither to build up an unbounded backlog in memory, nor block waiting-          -- for space!-          full <- isFullTBQueue backlog-          unless full $ writeTBQueue backlog it--  -- The variable holding the recorder starts out holding the recorder that writes-  -- to the backlog.-  recVar <- newTVarIO backlogRecorder-  -- The callback atomically swaps out the recorder for the final one, and flushes-  -- the backlog to it.-  let cb arg = do-        let recorder = recFun arg-        toRecord <- atomically $ writeTVar recVar recorder >> flushTBQueue backlog-        for_ toRecord (logger_ recorder)--  -- The recorder we actually return looks in the variable and uses whatever is there.-  let varRecorder = Recorder $ \it -> do-          r <- liftIO $ readTVarIO recVar-          logger_ r it--  pure (varRecorder, cb)---- | Creates a recorder that sends logs to the LSP client via @window/showMessage@ notifications.-lspClientMessageRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text)-lspClientMessageRecorder env = Recorder $ \WithPriority {..} ->-  liftIO $ LSP.runLspT env $ LSP.sendNotification SWindowShowMessage-      ShowMessageParams-        { _xtype = priorityToLsp priority,-          _message = payload-        }---- | Creates a recorder that sends logs to the LSP client via @window/logMessage@ notifications.-lspClientLogRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text)-lspClientLogRecorder env = Recorder $ \WithPriority {..} ->-  liftIO $ LSP.runLspT env $ LSP.sendNotification SWindowLogMessage-      LogMessageParams-        { _xtype = priorityToLsp priority,-          _message = payload-        }--priorityToLsp :: Priority -> MessageType-priorityToLsp =-  \case-    Debug   -> MtLog-    Info    -> MtInfo-    Warning -> MtWarning-    Error   -> MtError
+ src/Development/IDE/Types/Monitoring.hs view
@@ -0,0 +1,32 @@+module Development.IDE.Types.Monitoring+(Monitoring(..)+) where++import           Data.Int+import           Data.Text (Text)++-- | An abstraction for runtime monitoring inspired by the 'ekg' package+data Monitoring = Monitoring {+    -- | Register an integer-valued metric.+    registerGauge   :: Text -> IO Int64 -> IO (),+    -- | Register a non-negative, monotonically increasing, integer-valued metric.+    registerCounter :: Text -> IO Int64 -> IO (),+    start           :: IO (IO ()) -- ^ Start the monitoring system, returning an action which will stop the system.+  }++instance Semigroup Monitoring where+    a <> b = Monitoring {+        registerGauge   = \n v -> registerGauge a n v >> registerGauge b n v,+        registerCounter = \n v -> registerCounter a n v >> registerCounter b n v,+        start = do+            a' <- start a+            b' <- start b+            return $ a' >> b'+      }++instance Monoid Monitoring where+    mempty = Monitoring {+        registerGauge   = \_ _ -> return (),+        registerCounter = \_ _ -> return (),+        start = return $ return ()+      }
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(..)@@ -19,6 +18,7 @@   , ProgressReportingStyle(..)   ) where +import           Control.Lens import qualified Data.Text                         as T import           Data.Typeable import           Development.IDE.Core.RuleTypes@@ -27,7 +27,8 @@ import           Development.IDE.Types.Diagnostics import           Ide.Plugin.Config import           Ide.Types                         (DynFlagsModifications)-import qualified Language.LSP.Types.Capabilities   as LSP+import qualified Language.LSP.Protocol.Lens        as L+import qualified Language.LSP.Protocol.Types       as LSP  data IdeOptions = IdeOptions   { optPreprocessor       :: GHC.ParsedSource -> IdePreprocessedSource@@ -43,9 +44,6 @@     -- ^ File extensions to search for code, defaults to Haskell sources (including @.hs@)   , optShakeProfiling     :: Maybe FilePath     -- ^ Set to 'Just' to create a directory of profiling reports.-  , optOTMemoryProfiling  :: IdeOTMemoryProfiling-    -- ^ Whether to record profiling information with OpenTelemetry. You must-    --   also enable the -l RTS flag for this to have any effect   , optTesting            :: IdeTesting     -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants   , optReportProgress     :: IdeReportProgress@@ -70,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@@ -83,15 +83,17 @@   , optProgressStyle      :: ProgressReportingStyle   , optRunSubset          :: Bool       -- ^ Experimental feature to re-run only the subset of the Shake graph that has changed+  , optVerifyCoreFile     :: Bool+    -- ^ Verify core files after serialization   }  data OptHaddockParse = HaddockParse | NoHaddockParse   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.@@ -111,7 +113,7 @@  clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress clientSupportsProgress caps = IdeReportProgress $ Just True ==-    (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))+    ((\x -> x ^. L.workDoneProgress) =<< LSP._window (caps :: LSP.ClientCapabilities))  defaultIdeOptions :: Action IdeGhcSession -> IdeOptions defaultIdeOptions session = IdeOptions@@ -121,7 +123,6 @@     ,optPkgLocationOpts = defaultIdePkgLocationOptions     ,optShakeOptions = shakeOptions     ,optShakeProfiling = Nothing-    ,optOTMemoryProfiling = IdeOTMemoryProfiling False     ,optReportProgress = IdeReportProgress False     ,optLanguageSyntax = "haskell"     ,optNewColonConvention = False@@ -135,6 +136,7 @@     ,optSkipProgress = defaultSkipProgress     ,optProgressStyle = Explicit     ,optRunSubset = True+    ,optVerifyCoreFile = False     ,optMaxDirtyAge = 100     }
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@@ -25,7 +23,9 @@ import           Data.Typeable                        (cast) import           Data.Vector                          (Vector) import           Development.IDE.Core.PositionMapping-import           Development.IDE.Graph                (Key (..), RuleResult)+import           Development.IDE.Core.RuleTypes       (FileVersion)+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@@ -33,16 +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)-import Development.IDE.Core.RuleTypes (FileVersion)+                                                       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@@ -75,7 +76,7 @@     | otherwise = False  toKey :: Shake.ShakeValue k => k -> NormalizedFilePath -> Key-toKey = (Key.) . curry Q+toKey = (newKey.) . curry Q  fromKey :: Typeable k => Key -> Maybe (k, NormalizedFilePath) fromKey (Key k)@@ -84,14 +85,15 @@  -- | 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 = Key $ Q (k, emptyFilePath)+toNoFileKey k = newKey $ Q (k, emptyFilePath)  newtype Q k = Q (k, NormalizedFilePath)     deriving newtype (Eq, Hashable, NFData)@@ -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@@ -31,7 +30,7 @@     SrcSpan ->     GenericQ (Maybe (Bool, ast)) genericIsSubspan _ dst = mkQ Nothing $ \case-  (L span ast :: Located ast) -> Just (dst `isSubspanOf` span, ast)+  (L srcSpan ast :: Located ast) -> Just (dst `isSubspanOf` srcSpan, ast)   -- | Lift a function that replaces a value with several values into a generic
+ 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,18 +1,18 @@ -- | Parallel versions of 'filter' and 'simpleFilter'  module Text.Fuzzy.Parallel-(   filter,-    simpleFilter,-    match,+(   filter, filter', matchPar,+    simpleFilter, simpleFilter',+    match, defChunkSize, defMaxResults,     Scored(..) ) where -import           Control.Parallel.Strategies (rseq, using, parList, evalList)+import           Control.Parallel.Strategies (evalList, parList, rseq, using) import           Data.Bits                   ((.|.)) import           Data.Maybe                  (fromMaybe, mapMaybe) import qualified Data.Text                   as T-import qualified Data.Text.Internal          as T import qualified Data.Text.Array             as TA+import qualified Data.Text.Internal          as T import           Prelude                     hiding (filter)  data Scored a = Scored {score :: !Int, original:: !a}@@ -29,7 +29,6 @@ -- Just 5 -- {-# INLINABLE match #-}- match :: T.Text    -- ^ Pattern in lowercase except for first character       -> T.Text    -- ^ The text to search in.       -> Maybe Int -- ^ The score@@ -70,38 +69,88 @@      toLowerAscii w = if (w - 65) < 26 then w .|. 0x20 else w --- | The function to filter a list of values by fuzzy search on the text extracted from them.-filter :: Int           -- ^ Chunk size. 1000 works well.+-- | Sensible default value for chunk size to use when calling simple filter.+defChunkSize :: Int+defChunkSize = 1000++-- | Sensible default value for the number of max results to use when calling simple filter.+defMaxResults :: Int+defMaxResults = 10++-- | Return all elements of the list that have a fuzzy+-- match against the pattern. Runs with default settings where+-- nothing is added around the matches, as case insensitive.+--+-- >>> simpleFilter 1000 10 "vm" ["vim", "emacs", "virtual machine"]+-- [Scored {score = 4, original = "vim"},Scored {score = 4, original = "virtual machine"}]+{-# INLINABLE simpleFilter #-}+simpleFilter :: Int      -- ^ Chunk size. 1000 works well.+             -> Int      -- ^ Max. number of results wanted+             -> T.Text   -- ^ Pattern to look for.+             -> [T.Text] -- ^ List of texts to check.+             -> [Scored T.Text] -- ^ The ones that match.+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,+-- using a custom matching function which determines how close words are.+filter' :: Int           -- ^ Chunk size. 1000 works well.        -> Int           -- ^ Max. number of results wanted        -> 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.-filter chunkSize maxRes pattern ts extract = 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' --- | Return all elements of the list that have a fuzzy--- match against the pattern. Runs with default settings where--- nothing is added around the matches, as case insensitive.------ >>> simpleFilter "vm" ["vim", "emacs", "virtual machine"]--- ["vim","virtual machine"]-{-# INLINABLE simpleFilter #-}-simpleFilter :: Int      -- ^ Chunk size. 1000 works well.+-- | 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.+filter :: Int           -- ^ Chunk size. 1000 works well.+       -> Int           -- ^ Max. number of results wanted+       -> 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.+       -> [Scored t]    -- ^ The list of results, sorted, highest score first.+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.+-- Runs with default settings where nothing is added around the matches, as case insensitive.+{-# INLINABLE simpleFilter' #-}+simpleFilter' :: Int      -- ^ Chunk size. 1000 works well.              -> Int      -- ^ Max. number of results wanted              -> T.Text   -- ^ Pattern to look for.              -> [T.Text] -- ^ List of texts to check.+             -> (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 =-  filter chunk maxRes pattern xs id-+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/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,9 +0,0 @@-{-# LANGUAGE TemplateHaskell, UnboxedTuples #-}-module THA where-import Language.Haskell.TH--f :: Int -> (# Int, Int #)-f x = (# x , x+1 #)--th_a :: DecsQ-th_a = case f 1 of (# a , b #) -> [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/hiding/AVec.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module AVec (Vec, type (@@@), (++), cons, fromList, snoc) where--import Prelude hiding ((++))--data Vec a--(++) :: Vec a -> Vec a -> Vec a-(++) = undefined--data (@@@) a b--fromList :: [a] -> Vec a-fromList = undefined--cons :: a -> Vec a -> Vec a-cons = undefined--snoc :: Vec a -> a -> Vec a-snoc = undefined
− test/data/hiding/BVec.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module BVec (Vec, type (@@@), (++), cons, fromList, snoc) where--import Prelude hiding ((++))--data Vec a--(++) :: Vec a -> Vec a -> Vec a-(++) = undefined--data (@@@) a b--fromList :: [a] -> Vec a-fromList = undefined--cons :: a -> Vec a -> Vec a-cons = undefined--snoc :: Vec a -> a -> Vec a-snoc = undefined
− test/data/hiding/CVec.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module CVec (Vec, type (@@@), (++), cons, fromList, snoc) where--import Prelude hiding ((++))--data Vec a--(++) :: Vec a -> Vec a -> Vec a-(++) = undefined--data (@@@) a b--fromList :: [a] -> Vec a-fromList = undefined--cons :: a -> Vec a -> Vec a-cons = undefined--snoc :: Vec a -> a -> Vec a-snoc = undefined
− test/data/hiding/DVec.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module DVec (Vec, (++), type (@@@), cons, fromList, snoc) where--import Prelude hiding ((++))--data Vec a--(++) :: Vec a -> Vec a -> Vec a-(++) = undefined--data (@@@) a b--fromList :: [a] -> Vec a-fromList = undefined--cons :: a -> Vec a -> Vec a-cons = undefined--snoc :: Vec a -> a -> Vec a-snoc = undefined
− test/data/hiding/EVec.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module EVec (Vec, (++), type (@@@), cons, fromList, snoc) where--import Prelude hiding ((++))--data Vec a--(++) :: Vec a -> Vec a -> Vec a-(++) = undefined--data (@@@) a b--fromList :: [a] -> Vec a-fromList = undefined--cons :: a -> Vec a -> Vec a-cons = undefined--snoc :: Vec a -> a -> Vec a-snoc = undefined
− test/data/hiding/FVec.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE DuplicateRecordFields #-}--module FVec (RecA(..), RecB(..)) where--data Vec a--newtype RecA a = RecA { fromList :: [a] -> Vec a }--newtype RecB a = RecB { fromList :: [a] -> Vec a }
− test/data/hiding/HideFunction.expected.append.E.hs 
@@ -1,12 +0,0 @@-module HideFunction where--import AVec (fromList)-import BVec (fromList)-import CVec hiding ((++), cons)-import DVec hiding ((++), cons, snoc)-import EVec as E-import Prelude hiding ((++))--theFun = fromList--theOp = (++)
− test/data/hiding/HideFunction.expected.append.Prelude.hs 
@@ -1,11 +0,0 @@-module HideFunction where--import AVec (fromList)-import BVec (fromList)-import CVec hiding ((++), cons)-import DVec hiding ((++), cons, snoc)-import EVec as E hiding ((++))--theFun = fromList--theOp = (++)
− test/data/hiding/HideFunction.expected.fromList.A.hs 
@@ -1,11 +0,0 @@-module HideFunction where--import AVec (fromList)-import BVec ( (++))-import CVec hiding (fromList, cons)-import DVec hiding (fromList, cons, snoc)-import EVec as E hiding (fromList)--theFun = fromList--theOp = (++)
− test/data/hiding/HideFunction.expected.fromList.B.hs 
@@ -1,11 +0,0 @@-module HideFunction where--import AVec ()-import BVec (fromList, (++))-import CVec hiding (fromList, cons)-import DVec hiding (fromList, cons, snoc)-import EVec as E hiding (fromList)--theFun = fromList--theOp = (++)
− test/data/hiding/HideFunction.expected.qualified.append.Prelude.hs 
@@ -1,11 +0,0 @@-module HideFunction where--import AVec (fromList)-import BVec (fromList, (++))-import CVec hiding (cons)-import DVec hiding (cons, snoc)-import EVec as E--theFun = fromList--theOp = (Prelude.++)
− test/data/hiding/HideFunction.expected.qualified.fromList.E.hs 
@@ -1,11 +0,0 @@-module HideFunction where--import AVec (fromList)-import BVec (fromList, (++))-import CVec hiding (cons)-import DVec hiding (cons, snoc)-import EVec as E--theFun = E.fromList--theOp = (++)
− test/data/hiding/HideFunction.hs 
@@ -1,11 +0,0 @@-module HideFunction where--import AVec (fromList)-import BVec (fromList, (++))-import CVec hiding (cons)-import DVec hiding (cons, snoc)-import EVec as E--theFun = fromList--theOp = (++)
− test/data/hiding/HideFunctionWithoutLocal.expected.hs 
@@ -1,14 +0,0 @@-module HideFunctionWithoutLocal where--import AVec (fromList)-import BVec (fromList)-import CVec hiding ((++), cons)-import DVec hiding ((++), cons, snoc)-import EVec as E hiding ((++))-import Prelude hiding ((++))--theOp = (++)--data Vec a--(++) = undefined
− test/data/hiding/HideFunctionWithoutLocal.hs 
@@ -1,13 +0,0 @@-module HideFunctionWithoutLocal where--import AVec (fromList)-import BVec (fromList, (++))-import CVec hiding (cons)-import DVec hiding (cons, snoc)-import EVec as E--theOp = (++)--data Vec a--(++) = undefined
− test/data/hiding/HidePreludeIndented.expected.hs 
@@ -1,5 +0,0 @@-module HidePreludeIndented where--   import AVec-   import Prelude hiding ((++))-   op = (++)
− test/data/hiding/HidePreludeIndented.hs 
@@ -1,4 +0,0 @@-module HidePreludeIndented where--   import AVec-   op = (++)
− test/data/hiding/HidePreludeLocalInfix.expected.hs 
@@ -1,9 +0,0 @@-module HidePreludeLocalInfix where-import Prelude hiding ((++))--infixed xs ys = xs ++ ys--data Vec a--(++) :: Vec a -> Vec a -> Vec a-(++) = undefined
− test/data/hiding/HidePreludeLocalInfix.hs 
@@ -1,8 +0,0 @@-module HidePreludeLocalInfix where--infixed xs ys = xs ++ ys--data Vec a--(++) :: Vec a -> Vec a -> Vec a-(++) = undefined
− test/data/hiding/HideQualifyDuplicateRecordFields.expected.hs 
@@ -1,10 +0,0 @@-module HideQualifyDuplicateRecordFields where--import AVec-import BVec-import CVec-import DVec-import EVec-import FVec--theFun = AVec.fromList
− test/data/hiding/HideQualifyDuplicateRecordFields.hs 
@@ -1,10 +0,0 @@-module HideQualifyDuplicateRecordFields where--import AVec-import BVec-import CVec-import DVec-import EVec-import FVec--theFun = fromList
− test/data/hiding/HideQualifyDuplicateRecordFieldsSelf.hs 
@@ -1,5 +0,0 @@-module HideQualifyDuplicateRecordFieldsSelf where--import FVec--x = fromList
− test/data/hiding/HideQualifyInfix.expected.hs 
@@ -1,5 +0,0 @@-module HideQualifyInfix where--import AVec--infixed xs ys = xs Prelude.++ ys
− test/data/hiding/HideQualifyInfix.hs 
@@ -1,5 +0,0 @@-module HideQualifyInfix where--import AVec--infixed xs ys = xs ++ ys
− test/data/hiding/HideQualifySectionLeft.expected.hs 
@@ -1,5 +0,0 @@-module HideQualifySectionLeft where--import AVec--sectLeft xs = (Prelude.++ xs)
− test/data/hiding/HideQualifySectionLeft.hs 
@@ -1,5 +0,0 @@-module HideQualifySectionLeft where--import AVec--sectLeft xs = (++ xs)
− test/data/hiding/HideQualifySectionRight.expected.hs 
@@ -1,5 +0,0 @@-module HideQualifySectionRight where--import AVec--sectLeft xs = (xs Prelude.++)
− test/data/hiding/HideQualifySectionRight.hs 
@@ -1,5 +0,0 @@-module HideQualifySectionRight where--import AVec--sectLeft xs = (xs ++)
− test/data/hiding/HideType.expected.A.hs 
@@ -1,9 +0,0 @@-module HideType where--import AVec (Vec, fromList)-import BVec (fromList, (++))-import CVec hiding (Vec, cons)-import DVec hiding (Vec, cons, snoc)-import EVec as E hiding (Vec)--type TheType = Vec
− test/data/hiding/HideType.expected.E.hs 
@@ -1,9 +0,0 @@-module HideType where--import AVec ( fromList)-import BVec (fromList, (++))-import CVec hiding (Vec, cons)-import DVec hiding (Vec, cons, snoc)-import EVec as E--type TheType = Vec
− test/data/hiding/HideType.hs 
@@ -1,9 +0,0 @@-module HideType where--import AVec (Vec, fromList)-import BVec (fromList, (++))-import CVec hiding (cons)-import DVec hiding (cons, snoc)-import EVec as E--type TheType = Vec
− test/data/hiding/hie.yaml 
@@ -1,10 +0,0 @@-cradle:-    direct:-        arguments:-        - -Wall-        - HideFunction.hs-        - AVec.hs-        - BVec.hs-        - CVec.hs-        - DVec.hs-        - EVec.hs
− 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,66 +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 = _
− test/data/hover/hie.yaml 
@@ -1,1 +0,0 @@-cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover"]}}
− 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/import-placement/CommentAtTop.expected.hs 
@@ -1,9 +0,0 @@-module Test-( SomeData(..)-) where-import Data.Monoid---- | Some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/CommentAtTop.hs 
@@ -1,8 +0,0 @@-module Test-( SomeData(..)-) where---- | Some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/CommentAtTopMultipleComments.expected.hs 
@@ -1,12 +0,0 @@-module Test-( SomeData(..)-) where-import Data.Monoid---- | Another comment-data SomethingElse = SomethingElse---- | Some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/CommentAtTopMultipleComments.hs 
@@ -1,11 +0,0 @@-module Test-( SomeData(..)-) where---- | Another comment-data SomethingElse = SomethingElse---- | Some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/CommentCurlyBraceAtTop.expected.hs 
@@ -1,9 +0,0 @@-module Test-( SomeData(..)-) where-import Data.Monoid--{- Some comment -}-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/CommentCurlyBraceAtTop.hs 
@@ -1,8 +0,0 @@-module Test-( SomeData(..)-) where--{- Some comment -}-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/DataAtTop.expected.hs 
@@ -1,11 +0,0 @@-module Test-( SomeData(..)-) where-import Data.Monoid--data Something = Something---- | some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/DataAtTop.hs 
@@ -1,10 +0,0 @@-module Test-( SomeData(..)-) where--data Something = Something---- | some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/ImportAtTop.expected.hs 
@@ -1,14 +0,0 @@-module Test-( SomeData(..)-) where--import Data.Char-import Data.Monoid--{- Some multi -   line comment --}-class Semigroup a => SomeData a---- | a comment-instance SomeData All
− test/data/import-placement/ImportAtTop.hs 
@@ -1,13 +0,0 @@-module Test-( SomeData(..)-) where--import Data.Char--{- Some multi -   line comment --}-class Semigroup a => SomeData a---- | a comment-instance SomeData All
− test/data/import-placement/LangPragmaModuleAtTop.expected.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Test where-import Data.Monoid--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LangPragmaModuleAtTop.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Test where--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Test-( SomeData(..)-) where-import Data.Monoid--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LangPragmaModuleExplicitExports.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Test-( SomeData(..)-) where--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LangPragmaModuleWithComment.expected.hs 
@@ -1,11 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Test-( SomeData(..)-) where-import Data.Monoid---- comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LangPragmaModuleWithComment.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Test-( SomeData(..)-) where---- comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LanguagePragmaAtTop.expected.hs 
@@ -1,6 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-import Data.Monoid--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LanguagePragmaAtTop.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-import Data.Monoid---- | comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LanguagePragmaAtTopWithComment.hs 
@@ -1,6 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LanguagePragmasThenShebangs.expected.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-import Data.Monoid---- some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LanguagePragmasThenShebangs.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"---- some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/ModuleDeclAndImports.expected.hs 
@@ -1,10 +0,0 @@-module Test-( SomeData(..)-) where-import Data.Char-import Data.Array-import Data.Monoid--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/ModuleDeclAndImports.hs 
@@ -1,9 +0,0 @@-module Test-( SomeData(..)-) where-import Data.Char-import Data.Array--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/MultiLineCommentAtTop.expected.hs 
@@ -1,11 +0,0 @@-module Test-( SomeData(..)-) where-import Data.Monoid--{- Some multi -   line comment --}-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/MultiLineCommentAtTop.hs 
@@ -1,10 +0,0 @@-module Test-( SomeData(..)-) where--{- Some multi -   line comment --}-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/MultiLinePragma.expected.hs 
@@ -1,13 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards, -   OverloadedStrings #-}-{-# OPTIONS_GHC -Wall,-  -Wno-unused-imports #-}-import Data.Monoid----- some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/MultiLinePragma.hs 
@@ -1,12 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards, -   OverloadedStrings #-}-{-# OPTIONS_GHC -Wall,-  -Wno-unused-imports #-}----- some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/MultipleImportsAtTop.expected.hs 
@@ -1,14 +0,0 @@-module Test-( SomeData(..)-) where--import Data.Char-import Data.Bool-import Data.Eq-import Data.Monoid---- | A comment-class Semigroup a => SomeData a---- | another comment-instance SomeData All
− test/data/import-placement/MultipleImportsAtTop.hs 
@@ -1,13 +0,0 @@-module Test-( SomeData(..)-) where--import Data.Char-import Data.Bool-import Data.Eq---- | A comment-class Semigroup a => SomeData a---- | another comment-instance SomeData All
− test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE RankNTypes #-}-import Data.Monoid---- some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE RankNTypes #-}---- some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NewTypeAtTop.expected.hs 
@@ -1,11 +0,0 @@-module Test-( SomeData(..)-) where-import Data.Monoid--newtype Something = S { foo :: Int }---- | a comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NewTypeAtTop.hs 
@@ -1,10 +0,0 @@-module Test-( SomeData(..)-) where--newtype Something = S { foo :: Int }---- | a comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs 
@@ -1,7 +0,0 @@-module Test where-import Data.Monoid---- | a comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NoExplicitExportCommentAtTop.hs 
@@ -1,6 +0,0 @@-module Test where---- | a comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NoExplicitExports.expected.hs 
@@ -1,8 +0,0 @@-module Test where-import Data.Monoid--newtype Something = S { foo :: Int }--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NoExplicitExports.hs 
@@ -1,7 +0,0 @@-module Test where--newtype Something = S { foo :: Int }--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NoModuleDeclaration.expected.hs 
@@ -1,7 +0,0 @@-import Data.Monoid-newtype Something = S { foo :: Int }---- | a comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NoModuleDeclaration.hs 
@@ -1,6 +0,0 @@-newtype Something = S { foo :: Int }---- | a comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs 
@@ -1,5 +0,0 @@-import Data.Monoid--- a comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NoModuleDeclarationCommentAtTop.hs 
@@ -1,4 +0,0 @@--- a comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---{-# LANGUAGE TupleSections #-}-import Data.Monoid-----class Semigroup a => SomeData a-instance SomeData All--{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/OptionsNotAtTopWithSpaces.hs 
@@ -1,15 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---{-# LANGUAGE TupleSections #-}-----class Semigroup a => SomeData a-instance SomeData All--{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/OptionsPragmaNotAtTop.expected.hs 
@@ -1,8 +0,0 @@-import Data.Monoid-class Semigroup a => SomeData a-instance SomeData All--{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/OptionsPragmaNotAtTop.hs 
@@ -1,7 +0,0 @@-class Semigroup a => SomeData a-instance SomeData All--{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs 
@@ -1,23 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--{-# OPTIONS_GHC -Wall,-   OPTIONS_GHC -Wno-unrecognised-pragmas #-}--- another comment--- oh-{- multi line -comment--}--{-# LANGUAGE TupleSections #-}-import Data.Monoid-{- some comment -}---- again-class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/PragmaNotAtTopMultipleComments.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--{-# OPTIONS_GHC -Wall,-   OPTIONS_GHC -Wno-unrecognised-pragmas #-}--- another comment--- oh-{- multi line -comment--}--{-# LANGUAGE TupleSections #-}-{- some comment -}---- again-class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs 
@@ -1,18 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--{-# OPTIONS_GHC -Wall #-}--- another comment--{-# LANGUAGE TupleSections #-}-import Data.Monoid-{- some comment -}---class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs 
@@ -1,17 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--{-# OPTIONS_GHC -Wall #-}--- another comment--{-# LANGUAGE TupleSections #-}-{- some comment -}---class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/PragmaNotAtTopWithImports.expected.hs 
@@ -1,19 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}--{-# LANGUAGE TupleSections #-}-module Test-( SomeData(..)-) where-import Data.Text-import Data.Monoid---class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/PragmaNotAtTopWithImports.hs 
@@ -1,18 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}--{-# LANGUAGE TupleSections #-}-module Test-( SomeData(..)-) where-import Data.Text---class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---{-# OPTIONS_GHC -Wall #-}--{-# LANGUAGE TupleSections #-}-module Test-( SomeData(..)-) where-import Data.Monoid-----class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs 
@@ -1,21 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---{-# OPTIONS_GHC -Wall #-}--{-# LANGUAGE TupleSections #-}-module Test-( SomeData(..)-) where-----class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/PragmasAndShebangsNoComment.expected.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-import Data.Monoid--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/PragmasAndShebangsNoComment.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs 
@@ -1,11 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--module Test where-import Data.Monoid--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/PragmasShebangsAndModuleDecl.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--module Test where--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs 
@@ -1,13 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--module Test-( SomeData(..)-) where-import Data.Monoid--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/PragmasShebangsModuleExplicitExports.hs 
@@ -1,12 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--module Test-( SomeData(..)-) where--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs 
@@ -1,12 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-import Data.Monoid--{- | some multiline-  comment-   ... -}-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/PragmasThenShebangsMultilineComment.hs 
@@ -1,11 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--{- | some multiline-  comment-   ... -}-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/ShebangNotAtTop.expected.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-import Data.Monoid--class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--f :: Int -> Int -f x = x * x
− test/data/import-placement/ShebangNotAtTop.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--f :: Int -> Int -f x = x * x
− test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs 
@@ -1,8 +0,0 @@-import Data.Monoid-class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--f :: Int -> Int -f x = x * x
− test/data/import-placement/ShebangNotAtTopNoSpace.hs 
@@ -1,7 +0,0 @@-class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--f :: Int -> Int -f x = x * x
− test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs 
@@ -1,21 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---{-# OPTIONS_GHC -Wall #-}----{-# LANGUAGE TupleSections #-}-import Data.Monoid-----class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/ShebangNotAtTopWithSpaces.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---{-# OPTIONS_GHC -Wall #-}----{-# LANGUAGE TupleSections #-}-----class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/TwoDashOnlyComment.expected.hs 
@@ -1,9 +0,0 @@-module Test-( SomeData(..)-) where-import Data.Monoid---- no vertical bar comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/TwoDashOnlyComment.hs 
@@ -1,8 +0,0 @@-module Test-( SomeData(..)-) where---- no vertical bar comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/WhereDeclLowerInFile.expected.hs 
@@ -1,18 +0,0 @@-module Asdf - (f- , where') - - where-import Data.Int----f :: Int64 -> Int64-f = id'-  where id' = id--g :: Int -> Int -g = id--where' :: Int -> Int -where' = id
− test/data/import-placement/WhereDeclLowerInFile.hs 
@@ -1,17 +0,0 @@-module Asdf - (f- , where') - - where----f :: Int64 -> Int64-f = id'-  where id' = id--g :: Int -> Int -g = id--where' :: Int -> Int -where' = id
− test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs 
@@ -1,16 +0,0 @@-module Asdf - - - where-import Data.Int---f :: Int64 -> Int64-f = id'-  where id' = id--g :: Int -> Int -g = id--where' :: Int -> Int -where' = id
− test/data/import-placement/WhereKeywordLowerInFileNoExports.hs 
@@ -1,15 +0,0 @@-module Asdf - - - where---f :: Int64 -> Int64-f = id'-  where id' = id--g :: Int -> Int -g = id--where' :: Int -> Int -where' = id
− 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-  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,1 +0,0 @@-packages: a b c
− 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/FuzzySearch.hs 
@@ -1,132 +0,0 @@-module FuzzySearch (tests) where--import Control.Monad (guard)-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 System.Directory (doesFileExist)-import System.IO.Unsafe (unsafePerformIO)-import System.Info.Extra (isWindows)-import Test.QuickCheck-import Test.Tasty-import Test.Tasty.ExpectedFailure-import Test.Tasty.HUnit-import Test.Tasty.QuickCheck (testProperty)-import Text.Fuzzy (Fuzzy (..))-import qualified Text.Fuzzy as Fuzzy-import Text.Fuzzy.Parallel-import Prelude hiding (filter)--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/HieDbRetry.hs 
@@ -1,138 +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           Development.IDE.Types.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/Main.hs 
@@ -1,6887 +0,0 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.--- SPDX-License-Identifier: Apache-2.0--{-# LANGUAGE AllowAmbiguousTypes   #-}-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE ImplicitParams        #-}-{-# LANGUAGE MultiWayIf            #-}-{-# LANGUAGE PatternSynonyms       #-}-{-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE TypeOperators         #-}-{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-}--module Main (main) where--import           Control.Applicative.Combinators-import           Control.Concurrent-import           Control.Exception                        (bracket_, catch,-                                                           finally)-import qualified Control.Lens                             as Lens-import           Control.Monad-import           Control.Monad.IO.Class                   (MonadIO, liftIO)-import           Data.Aeson                               (fromJSON, toJSON)-import qualified Data.Aeson                               as A-import           Data.Default-import           Data.Foldable-import           Data.List.Extra-import           Data.Maybe-import           Data.Rope.UTF16                          (Rope)-import qualified Data.Rope.UTF16                          as Rope-import qualified Data.Set                                 as Set-import qualified Data.Text                                as T-import           Development.IDE.Core.PositionMapping     (PositionResult (..),-                                                           fromCurrent,-                                                           positionResultToMaybe,-                                                           toCurrent)-import           Development.IDE.GHC.Compat               (GhcVersion (..),-                                                           ghcVersion)-import           Development.IDE.GHC.Util-import qualified Development.IDE.Main                     as IDE-import           Development.IDE.Plugin.Completions.Types (extendImportCommandId)-import           Development.IDE.Plugin.TypeLenses        (typeLensCommandId)-import           Development.IDE.Spans.Common-import           Development.IDE.Test                     (Cursor,-                                                           canonicalizeUri,-                                                           configureCheckProject,-                                                           diagnostic,-                                                           expectCurrentDiagnostics,-                                                           expectDiagnostics,-                                                           expectDiagnosticsWithTags,-                                                           expectMessages,-                                                           expectNoMoreDiagnostics,-                                                           flushMessages,-                                                           getInterfaceFilesDir,-                                                           getStoredKeys,-                                                           isReferenceReady,-                                                           referenceReady,-                                                           standardizeQuotes,-                                                           waitForAction,-                                                           waitForGC,-                                                           waitForTypecheck)-import           Development.IDE.Test.Runfiles-import qualified Development.IDE.Types.Diagnostics        as Diagnostics-import           Development.IDE.Types.Location-import           Development.Shake                        (getDirectoryFilesIO)-import qualified Experiments                              as Bench-import           Ide.Plugin.Config-import           Language.LSP.Test-import           Language.LSP.Types                       hiding-                                                          (SemanticTokenAbsolute (length, line),-                                                           SemanticTokenRelative (length),-                                                           SemanticTokensEdit (_start),-                                                           mkRange)-import           Language.LSP.Types.Capabilities-import qualified Language.LSP.Types.Lens                  as Lens (label)-import qualified Language.LSP.Types.Lens                  as Lsp (diagnostics,-                                                                  message,-                                                                  params)-import           Language.LSP.VFS                         (applyChange)-import           Network.URI-import           System.Directory-import           System.Environment.Blank                 (getEnv, setEnv,-                                                           unsetEnv)-import           System.Exit                              (ExitCode (ExitSuccess))-import           System.FilePath-import           System.IO.Extra                          hiding (withTempDir)-import qualified System.IO.Extra-import           System.Info.Extra                        (isMac, isWindows)-import           System.Mem                               (performGC)-import           System.Process.Extra                     (CreateProcess (cwd),-                                                           createPipe, proc,-                                                           readCreateProcessWithExitCode)-import           Test.QuickCheck--- import Test.QuickCheck.Instances ()-import           Control.Concurrent.Async-import           Control.Lens                             (to, (^.), (.~))-import           Control.Monad.Extra                      (whenJust)-import           Data.Function                            ((&))-import           Data.IORef-import           Data.IORef.Extra                         (atomicModifyIORef_)-import           Data.String                              (IsString (fromString))-import           Data.Tuple.Extra-import           Development.IDE.Core.FileStore           (getModTime)-import           Development.IDE.Plugin.CodeAction        (matchRegExMultipleImports)-import qualified Development.IDE.Plugin.HLS.GhcIde        as Ghcide-import           Development.IDE.Plugin.Test              (TestRequest (BlockSeconds),-                                                           WaitForIdeRuleResult (..),-                                                           blockCommandId)-import           Development.IDE.Types.Logger             (Logger (Logger),-                                                           LoggingColumn (DataColumn, PriorityColumn),-                                                           Pretty (pretty),-                                                           Priority (Debug),-                                                           Recorder (Recorder, logger_),-                                                           WithPriority (WithPriority, priority),-                                                           cfilter,-                                                           cmapWithPrio,-                                                           makeDefaultStderrRecorder)-import qualified FuzzySearch-import           GHC.Stack                                (emptyCallStack)-import qualified HieDbRetry-import           Ide.PluginUtils                          (pluginDescToIdePlugins)-import           Ide.Types-import qualified Language.LSP.Types                       as LSP-import qualified Language.LSP.Types.Lens                  as L-import           Language.LSP.Types.Lens                  (workspace, didChangeWatchedFiles)-import qualified Progress-import           System.Time.Extra-import           Test.Tasty-import           Test.Tasty.ExpectedFailure-import           Test.Tasty.HUnit-import           Test.Tasty.Ingredients.Rerun-import           Test.Tasty.QuickCheck-import           Text.Printf                              (printf)-import           Text.Regex.TDFA                          ((=~))--data Log-  = LogGhcIde Ghcide.Log-  | LogIDEMain IDE.Log--instance Pretty Log where-  pretty = \case-    LogGhcIde log  -> pretty log-    LogIDEMain log -> pretty log---- | Wait for the next progress begin step-waitForProgressBegin :: Session ()-waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case-  FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (Begin _))) -> 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 SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> 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 SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just ()-        _ -> Nothing-      done <- null <$> getIncompleteProgressSessions-      unless done loop--main :: IO ()-main = do-  docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Debug--  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"-    [ testSession "open close" $ do-        doc <- createDoc "Testing.hs" "haskell" ""-        void (skipManyTill anyMessage $ message SWindowWorkDoneProgressCreate)-        waitForProgressBegin-        closeDoc doc-        waitForProgressDone-    , codeActionTests-    , initializeResponseTests-    , completionTests-    , cppTests-    , diagnosticTests-    , codeLensesTests-    , outlineTests-    , highlightTests-    , findDefinitionAndHoverTests-    , pluginSimpleTests-    , pluginParsedResultTests-    , preprocessorTests-    , thTests-    , symlinkTests-    , safeTests-    , unitTests recorder logger-    , haddockTests-    , positionMappingTests-    , watchedFilesTests-    , cradleTests-    , dependentFileTest-    , nonLspCommandLine-    , benchmarkTests-    , ifaceTests-    , bootTests-    , rootUriTests-    , asyncTests-    , clientSettingsTest-    , codeActionHelperFunctionTests-    , referenceTests-    , garbageCollectionTests-    , HieDbRetry.tests-    ]--initializeResponseTests :: TestTree-initializeResponseTests = withResource acquire release tests where--  -- these tests document and monitor the evolution of the-  -- capabilities announced by the server in the initialize-  -- response. Currently the server advertises almost no capabilities-  -- at all, in some cases failing to announce capabilities that it-  -- actually does provide! Hopefully this will change ...-  tests :: IO (ResponseMessage Initialize) -> TestTree-  tests getInitializeResponse =-    testGroup "initialize response capabilities"-    [ chk "   text doc sync"             _textDocumentSync  tds-    , chk "   hover"                         _hoverProvider (Just $ InL True)-    , chk "   completion"               _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just False))-    , chk "NO signature help"        _signatureHelpProvider Nothing-    , chk "   goto definition"          _definitionProvider (Just $ InL True)-    , chk "   goto type definition" _typeDefinitionProvider (Just $ InL True)-    -- BUG in lsp-test, this test fails, just change the accepted response-    -- for now-    , chk "NO goto implementation"  _implementationProvider (Just $ InL False)-    , chk "   find references"          _referencesProvider (Just $ InL True)-    , chk "   doc highlight"     _documentHighlightProvider (Just $ InL True)-    , chk "   doc symbol"           _documentSymbolProvider (Just $ InL True)-    , chk "   workspace symbol"    _workspaceSymbolProvider (Just True)-    , chk "   code action"             _codeActionProvider  (Just $ InL True)-    , chk "   code lens"                 _codeLensProvider  (Just $ CodeLensOptions (Just False) (Just False))-    , chk "NO doc formatting"   _documentFormattingProvider (Just $ InL False)-    , chk "NO doc range formatting"-                           _documentRangeFormattingProvider (Just $ InL False)-    , chk "NO doc formatting on typing"-                          _documentOnTypeFormattingProvider Nothing-    , chk "NO renaming"                     _renameProvider (Just $ InL False)-    , chk "NO doc link"               _documentLinkProvider Nothing-    , chk "NO color"                         _colorProvider (Just $ InL False)-    , chk "NO folding range"          _foldingRangeProvider (Just $ InL False)-    , che "   execute command"      _executeCommandProvider [extendImportCommandId, typeLensCommandId, blockCommandId]-    , chk "   workspace"                         _workspace (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )}))-    , chk "NO experimental"                   _experimental Nothing-    ] where--      tds = Just (InL (TextDocumentSyncOptions-                              { _openClose = Just True-                              , _change    = Just TdSyncIncremental-                              , _willSave  = Nothing-                              , _willSaveWaitUntil = Nothing-                              , _save = Just (InR $ SaveOptions {_includeText = Nothing})}))--      chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree-      chk title getActual expected =-        testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir--      che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree-      che title getActual expected = testCase title doTest-        where-            doTest = do-                ir <- getInitializeResponse-                let Just ExecuteCommandOptions {_commands = List commands} = getActual $ innerCaps ir-                zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) expected commands--  innerCaps :: ResponseMessage Initialize -> ServerCapabilities-  innerCaps (ResponseMessage _ _ (Right (InitializeResult c _))) = c-  innerCaps (ResponseMessage _ _ (Left _)) = error "Initialization error"--  acquire :: IO (ResponseMessage Initialize)-  acquire = run initializeResponse--  release :: ResponseMessage Initialize -> IO ()-  release = const $ pure ()---diagnosticTests :: TestTree-diagnosticTests = testGroup "diagnostics"-  [ testSessionWait "fix syntax error" $ do-      let content = T.unlines [ "module Testing wher" ]-      doc <- createDoc "Testing.hs" "haskell" content-      expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]-      let change = TextDocumentContentChangeEvent-            { _range = Just (Range (Position 0 15) (Position 0 19))-            , _rangeLength = Nothing-            , _text = "where"-            }-      changeDoc doc [change]-      expectDiagnostics [("Testing.hs", [])]-  , testSessionWait "introduce syntax error" $ do-      let content = T.unlines [ "module Testing where" ]-      doc <- createDoc "Testing.hs" "haskell" content-      void $ skipManyTill anyMessage (message SWindowWorkDoneProgressCreate)-      waitForProgressBegin-      let change = TextDocumentContentChangeEvent-            { _range = Just (Range (Position 0 15) (Position 0 18))-            , _rangeLength = Nothing-            , _text = "wher"-            }-      changeDoc doc [change]-      expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]-  , testSessionWait "update syntax error" $ do-      let content = T.unlines [ "module Testing(missing) where" ]-      doc <- createDoc "Testing.hs" "haskell" content-      expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'missing'")])]-      let change = TextDocumentContentChangeEvent-            { _range = Just (Range (Position 0 15) (Position 0 16))-            , _rangeLength = Nothing-            , _text = "l"-            }-      changeDoc doc [change]-      expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'lissing'")])]-  , testSessionWait "variable not in scope" $ do-      let content = T.unlines-            [ "module Testing where"-            , "foo :: Int -> Int -> Int"-            , "foo a _b = a + ab"-            , "bar :: Int -> Int -> Int"-            , "bar _a b = cd + b"-            ]-      _ <- createDoc "Testing.hs" "haskell" content-      expectDiagnostics-        [ ( "Testing.hs"-          , [ (DsError, (2, 15), "Variable not in scope: ab")-            , (DsError, (4, 11), "Variable not in scope: cd")-            ]-          )-        ]-  , testSessionWait "type error" $ do-      let content = T.unlines-            [ "module Testing where"-            , "foo :: Int -> String -> Int"-            , "foo a b = a + b"-            ]-      _ <- createDoc "Testing.hs" "haskell" content-      expectDiagnostics-        [ ( "Testing.hs"-          , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]-          )-        ]-  , testSessionWait "typed hole" $ do-      let content = T.unlines-            [ "module Testing where"-            , "foo :: Int -> String"-            , "foo a = _ a"-            ]-      _ <- createDoc "Testing.hs" "haskell" content-      expectDiagnostics-        [ ( "Testing.hs"-          , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]-          )-        ]--  , testGroup "deferral" $-    let sourceA a = T.unlines-          [ "module A where"-          , "a :: Int"-          , "a = " <> a]-        sourceB = T.unlines-          [ "module B where"-          , "import A ()"-          , "b :: Float"-          , "b = True"]-        bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'"-        expectedDs aMessage =-          [ ("A.hs", [(DsError, (2,4), aMessage)])-          , ("B.hs", [(DsError, (3,4), bMessage)])]-        deferralTest title binding msg = testSessionWait title $ do-          _ <- createDoc "A.hs" "haskell" $ sourceA binding-          _ <- createDoc "B.hs" "haskell"   sourceB-          expectDiagnostics $ expectedDs msg-    in-    [ deferralTest "type error"          "True"    "Couldn't match expected type"-    , deferralTest "typed hole"          "_"       "Found hole"-    , deferralTest "out of scope var"    "unbound" "Variable not in scope"-    ]--  , testSessionWait "remove required module" $ do-      let contentA = T.unlines [ "module ModuleA where" ]-      docA <- createDoc "ModuleA.hs" "haskell" contentA-      let contentB = T.unlines-            [ "module ModuleB where"-            , "import ModuleA"-            ]-      _ <- createDoc "ModuleB.hs" "haskell" contentB-      let change = TextDocumentContentChangeEvent-            { _range = Just (Range (Position 0 0) (Position 0 20))-            , _rangeLength = Nothing-            , _text = ""-            }-      changeDoc docA [change]-      expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])]-  , testSessionWait "add missing module" $ do-      let contentB = T.unlines-            [ "module ModuleB where"-            , "import ModuleA ()"-            ]-      _ <- createDoc "ModuleB.hs" "haskell" contentB-      expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]-      let contentA = T.unlines [ "module ModuleA where" ]-      _ <- createDoc "ModuleA.hs" "haskell" contentA-      expectDiagnostics [("ModuleB.hs", [])]-  , 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", [(DsError, (1, 7), "Could not find module")])]-      let contentA = T.unlines [ "module ModuleA where" ]-      _ <- createDoc (tmpDir </> "ModuleA.hs") "haskell" contentA-      expectDiagnostics [(tmpDir </> "ModuleB.hs", [])]-  , testSessionWait "cyclic module dependency" $ do-      let contentA = T.unlines-            [ "module ModuleA where"-            , "import ModuleB"-            ]-      let contentB = T.unlines-            [ "module ModuleB where"-            , "import ModuleA"-            ]-      _ <- createDoc "ModuleA.hs" "haskell" contentA-      _ <- createDoc "ModuleB.hs" "haskell" contentB-      expectDiagnostics-        [ ( "ModuleA.hs"-          , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]-          )-        , ( "ModuleB.hs"-          , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]-          )-        ]-  , 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"-          , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]-          )-        ]-  , testSessionWait "cyclic module dependency with hs-boot" $ do-      let contentA = T.unlines-            [ "module ModuleA where"-            , "import {-# SOURCE #-} ModuleB"-            ]-      let contentB = T.unlines-            [ "{-# OPTIONS -Wmissing-signatures#-}"-            , "module ModuleB where"-            , "import ModuleA"-            -- introduce an artificial diagnostic-            , "foo = ()"-            ]-      let contentBboot = T.unlines-            [ "module ModuleB where"-            ]-      _ <- createDoc "ModuleA.hs" "haskell" contentA-      _ <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot-      expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])]-  , testSessionWait "correct reference used with hs-boot" $ do-      let contentB = T.unlines-            [ "module ModuleB where"-            , "import {-# SOURCE #-} ModuleA()"-            ]-      let contentA = T.unlines-            [ "module ModuleA where"-            , "import ModuleB()"-            , "x = 5"-            ]-      let contentAboot = T.unlines-            [ "module ModuleA where"-            ]-      let contentC = T.unlines-            [ "{-# OPTIONS -Wmissing-signatures #-}"-            , "module ModuleC where"-            , "import ModuleA"-            -- this reference will fail if it gets incorrectly-            -- resolved to the hs-boot file-            , "y = x"-            ]-      _ <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- createDoc "ModuleA.hs" "haskell" contentA-      _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot-      _ <- createDoc "ModuleC.hs" "haskell" contentC-      expectDiagnostics [("ModuleC.hs", [(DsWarning, (3,0), "Top-level binding")])]-  , testSessionWait "redundant import" $ do-      let contentA = T.unlines ["module ModuleA where"]-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA"-            ]-      _ <- createDoc "ModuleA.hs" "haskell" contentA-      _ <- createDoc "ModuleB.hs" "haskell" contentB-      expectDiagnosticsWithTags-        [ ( "ModuleB.hs"-          , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant", Just DtUnnecessary)]-          )-        ]-  , testSessionWait "redundant import even without warning" $ do-      let contentA = T.unlines ["module ModuleA where"]-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wno-unused-imports -Wmissing-signatures #-}"-            , "module ModuleB where"-            , "import ModuleA"-            -- introduce an artificial warning for testing purposes-            , "foo = ()"-            ]-      _ <- createDoc "ModuleA.hs" "haskell" contentA-      _ <- createDoc "ModuleB.hs" "haskell" contentB-      expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])]-  , testSessionWait "package imports" $ do-      let thisDataListContent = T.unlines-            [ "module Data.List where"-            , "x :: Integer"-            , "x = 123"-            ]-      let mainContent = T.unlines-            [ "{-# LANGUAGE PackageImports #-}"-            , "module Main where"-            , "import qualified \"this\" Data.List as ThisList"-            , "import qualified \"base\" Data.List as BaseList"-            , "useThis = ThisList.x"-            , "useBase = BaseList.map"-            , "wrong1 = ThisList.map"-            , "wrong2 = BaseList.x"-            ]-      _ <- createDoc "Data/List.hs" "haskell" thisDataListContent-      _ <- createDoc "Main.hs" "haskell" mainContent-      expectDiagnostics-        [ ( "Main.hs"-          , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")-            ,(DsError, (7, 9), "Not in scope: \8216BaseList.x\8217")-            ]-          )-        ]-  , testSessionWait "unqualified warnings" $ do-      let fooContent = T.unlines-            [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"-            , "module Foo where"-            , "foo :: Ord a => a -> Int"-            , "foo _a = 1"-            ]-      _ <- createDoc "Foo.hs" "haskell" fooContent-      expectDiagnostics-        [ ( "Foo.hs"-      -- The test is to make sure that warnings contain unqualified names-      -- where appropriate. The warning should use an unqualified name 'Ord', not-      -- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to-      -- test this is fairly arbitrary.-          , [(DsWarning, (2, 0), "Redundant constraint: Ord a")-            ]-          )-        ]-    , testSessionWait "lower-case drive" $ do-          let aContent = T.unlines-                [ "module A.A where"-                , "import A.B ()"-                ]-              bContent = T.unlines-                [ "{-# OPTIONS_GHC -Wall #-}"-                , "module A.B where"-                , "import Data.List"-                ]-          uriB <- getDocUri "A/B.hs"-          Just pathB <- pure $ uriToFilePath uriB-          uriB <- pure $-              let (drive, suffix) = splitDrive pathB-              in filePathToUri (joinDrive (lower drive) suffix)-          liftIO $ createDirectoryIfMissing True (takeDirectory pathB)-          liftIO $ writeFileUTF8 pathB $ T.unpack bContent-          uriA <- getDocUri "A/A.hs"-          Just pathA <- pure $ uriToFilePath uriA-          uriA <- pure $-              let (drive, suffix) = splitDrive pathA-              in filePathToUri (joinDrive (lower drive) suffix)-          let itemA = TextDocumentItem uriA "haskell" 0 aContent-          let a = TextDocumentIdentifier uriA-          sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams itemA)-          NotificationMessage{_params = PublishDiagnosticsParams fileUri _ diags} <- skipManyTill anyMessage diagnostic-          -- Check that if we put a lower-case drive in for A.A-          -- the diagnostics for A.B will also be lower-case.-          liftIO $ fileUri @?= uriB-          let msg = _message (head (toList diags) :: Diagnostic)-          liftIO $ unless ("redundant" `T.isInfixOf` msg) $-              assertFailure ("Expected redundant import but got " <> T.unpack msg)-          closeDoc a-  , testSessionWait "haddock parse error" $ do-      let fooContent = T.unlines-            [ "module Foo where"-            , "foo :: Int"-            , "foo = 1 {-|-}"-            ]-      _ <- createDoc "Foo.hs" "haskell" fooContent-      if ghcVersion >= GHC90 then-          -- Haddock parse errors are ignored on ghc-9.0-            pure ()-      else-        expectDiagnostics-            [ ( "Foo.hs"-              , [(DsWarning, (2, 8), "Haddock parse error on input")]-              )-            ]-  , testSessionWait "strip file path" $ do-      let-          name = "Testing"-          content = T.unlines-            [ "module " <> name <> " where"-            , "value :: Maybe ()"-            , "value = [()]"-            ]-      _ <- createDoc (T.unpack name <> ".hs") "haskell" content-      notification <- skipManyTill anyMessage diagnostic-      let-          offenders =-            Lsp.params .-            Lsp.diagnostics .-            Lens.folded .-            Lsp.message .-            Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:"))-          failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg-      Lens.mapMOf_ offenders failure notification-  , testSession' "-Werror in cradle is ignored" $ \sessionDir -> do-      liftIO $ writeFile (sessionDir </> "hie.yaml")-        "cradle: {direct: {arguments: [\"-Wall\", \"-Werror\"]}}"-      let fooContent = T.unlines-            [ "module Foo where"-            , "foo = ()"-            ]-      _ <- createDoc "Foo.hs" "haskell" fooContent-      expectDiagnostics-        [ ( "Foo.hs"-          , [(DsWarning, (1, 0), "Top-level binding with no type signature:")-            ]-          )-        ]-  , testSessionWait "-Werror in pragma is ignored" $ do-      let fooContent = T.unlines-            [ "{-# OPTIONS_GHC -Wall -Werror #-}"-            , "module Foo() where"-            , "foo :: Int"-            , "foo = 1"-            ]-      _ <- createDoc "Foo.hs" "haskell" fooContent-      expectDiagnostics-        [ ( "Foo.hs"-          , [(DsWarning, (3, 0), "Defined but not used:")-            ]-          )-        ]-  , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do-    let bPath = dir </> "B.hs"-        pPath = dir </> "P.hs"-        aPath = dir </> "A.hs"--    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int-    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int-    aSource <- liftIO $ readFileUtf8 aPath -- x = y :: Int--    bdoc <- createDoc bPath "haskell" bSource-    _pdoc <- createDoc pPath "haskell" pSource-    expectDiagnostics-      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded--    -- Change y from Int to B which introduces a type error in A (imported from P)-    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $-                    T.unlines ["module B where", "y :: Bool", "y = undefined"]]-    expectDiagnostics-      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])-      ]--    -- Open A and edit to fix the type error-    adoc <- createDoc aPath "haskell" aSource-    changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing $-                    T.unlines ["module A where", "import B", "x :: Bool", "x = y"]]--    expectDiagnostics-      [ ( "P.hs",-          [ (DsError, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"),-            (DsWarning, (4, 0), "Top-level binding")-          ]-        ),-        ("A.hs", [])-      ]-    expectNoMoreDiagnostics 1--  , testSessionWait "deduplicate missing module diagnostics" $  do-      let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ]-      doc <- createDoc "Foo.hs" "haskell" fooContent-      expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])]--      changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module Foo() where" ]-      expectDiagnostics []--      changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines-            [ "module Foo() where" , "import MissingModule" ] ]-      expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])]--  , testGroup "Cancellation"-    [ cancellationTestGroup "edit header" editHeader 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 {_range=Just (Range p p), _rangeLength=Nothing, _text="fd"}-        ,TextDocumentContentChangeEvent {_range=Just (Range p p'), _rangeLength=Nothing, _text=""})-      editHeader = editPair 0 0-      editImport = editPair 2 10-      editBody   = editPair 3 10--      noParse = False-      yesParse = True--      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 = [(DsWarning, (3, 0), "Top-level binding") ]-      typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags--      -- Now we edit the document and wait for the given key (if any)-      changeDoc doc [edit]-      whenJust mbKey $ \(key, expectedResult) -> do-        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--codeActionTests :: TestTree-codeActionTests = testGroup "code actions"-  [ insertImportTests-  , extendImportTests-  , renameActionTests-  , typeWildCardActionTests-  , removeImportTests-  , suggestImportClassMethodTests-  , suggestImportTests-  , suggestHideShadowTests-  , suggestImportDisambiguationTests-  , fixConstructorImportTests-  , fixModuleImportTypoTests-  , importRenameActionTests-  , fillTypedHoleTests-  , addSigActionTests-  , insertNewDefinitionTests-  , deleteUnusedDefinitionTests-  , addInstanceConstraintTests-  , addFunctionConstraintTests-  , removeRedundantConstraintsTests-  , addTypeAnnotationsToLiteralsTest-  , exportUnusedTests-  , addImplicitParamsConstraintTests-  , removeExportTests-  ]--codeActionHelperFunctionTests :: TestTree-codeActionHelperFunctionTests = testGroup "code action helpers"-    [-    extendImportTestsRegEx-    ]---codeLensesTests :: TestTree-codeLensesTests = testGroup "code lenses"-  [ addSigLensesTests-  ]--watchedFilesTests :: TestTree-watchedFilesTests = testGroup "watched files"-  [ 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 STextDocumentPublishDiagnostics--        -- 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 STextDocumentPublishDiagnostics--        -- 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", [(DsError, (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 SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $-                List [FileEvent (filePathToUri $ sessionDir </> "B.hs") FcChanged ]-        expectDiagnostics [("A.hs", [(DsError, (3, 4), "Couldn't match expected type '()' with actual type 'Int'")])]-    ]-  ]--insertImportTests :: TestTree-insertImportTests = testGroup "insert import"-  [ expectFailBecause-      ("'findPositionFromImportsOrModuleDecl' function adds import directly under line with module declaration, "-      ++ "not accounting for case when 'where' keyword is placed on lower line")-      (checkImport-         "module where keyword lower in file no exports"-         "WhereKeywordLowerInFileNoExports.hs"-         "WhereKeywordLowerInFileNoExports.expected.hs"-         "import Data.Int")-  , expectFailBecause-      ("'findPositionFromImportsOrModuleDecl' function adds import directly under line with module exports list, "-      ++ "not accounting for case when 'where' keyword is placed on lower line")-      (checkImport-         "module where keyword lower in file with exports"-         "WhereDeclLowerInFile.hs"-         "WhereDeclLowerInFile.expected.hs"-         "import Data.Int")-  , expectFailBecause-      "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file"-      (checkImport-         "Shebang not at top with spaces"-         "ShebangNotAtTopWithSpaces.hs"-         "ShebangNotAtTopWithSpaces.expected.hs"-         "import Data.Monoid")-  , expectFailBecause-      "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file"-      (checkImport-         "Shebang not at top no space"-         "ShebangNotAtTopNoSpace.hs"-         "ShebangNotAtTopNoSpace.expected.hs"-         "import Data.Monoid")-  , expectFailBecause-      ("'findNextPragmaPosition' function doesn't account for case "-      ++ "when OPTIONS_GHC pragma is not placed at top of file")-      (checkImport-         "OPTIONS_GHC pragma not at top with spaces"-         "OptionsNotAtTopWithSpaces.hs"-         "OptionsNotAtTopWithSpaces.expected.hs"-         "import Data.Monoid")-  , expectFailBecause-      ("'findNextPragmaPosition' function doesn't account for "-      ++ "case when shebang is not placed at top of file")-      (checkImport-         "Shebang not at top of file"-         "ShebangNotAtTop.hs"-         "ShebangNotAtTop.expected.hs"-         "import Data.Monoid")-  , expectFailBecause-      ("'findNextPragmaPosition' function doesn't account for case "-      ++ "when OPTIONS_GHC is not placed at top of file")-      (checkImport-         "OPTIONS_GHC pragma not at top of file"-         "OptionsPragmaNotAtTop.hs"-         "OptionsPragmaNotAtTop.expected.hs"-         "import Data.Monoid")-  , expectFailBecause-      ("'findNextPragmaPosition' function doesn't account for case when "-      ++ "OPTIONS_GHC pragma is not placed at top of file")-      (checkImport-         "pragma not at top with comment at top"-         "PragmaNotAtTopWithCommentsAtTop.hs"-         "PragmaNotAtTopWithCommentsAtTop.expected.hs"-         "import Data.Monoid")-  , expectFailBecause-      ("'findNextPragmaPosition' function doesn't account for case when "-      ++ "OPTIONS_GHC pragma is not placed at top of file")-      (checkImport-         "pragma not at top multiple comments"-         "PragmaNotAtTopMultipleComments.hs"-         "PragmaNotAtTopMultipleComments.expected.hs"-         "import Data.Monoid")-  , expectFailBecause-      "'findNextPragmaPosition' function doesn't account for case of multiline pragmas"-      (checkImport-         "after multiline language pragmas"-         "MultiLinePragma.hs"-         "MultiLinePragma.expected.hs"-         "import Data.Monoid")-  , checkImport-      "pragmas not at top with module declaration"-      "PragmaNotAtTopWithModuleDecl.hs"-      "PragmaNotAtTopWithModuleDecl.expected.hs"-      "import Data.Monoid"-  , checkImport-      "pragmas not at top with imports"-      "PragmaNotAtTopWithImports.hs"-      "PragmaNotAtTopWithImports.expected.hs"-      "import Data.Monoid"-  , checkImport-      "above comment at top of module"-      "CommentAtTop.hs"-      "CommentAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "above multiple comments below"-      "CommentAtTopMultipleComments.hs"-      "CommentAtTopMultipleComments.expected.hs"-      "import Data.Monoid"-  , checkImport-      "above curly brace comment"-      "CommentCurlyBraceAtTop.hs"-      "CommentCurlyBraceAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "above multi-line comment"-      "MultiLineCommentAtTop.hs"-      "MultiLineCommentAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "above comment with no module explicit exports"-      "NoExplicitExportCommentAtTop.hs"-      "NoExplicitExportCommentAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "above two-dash comment with no pipe"-      "TwoDashOnlyComment.hs"-      "TwoDashOnlyComment.expected.hs"-      "import Data.Monoid"-  , checkImport-      "above comment with no (module .. where) decl"-      "NoModuleDeclarationCommentAtTop.hs"-      "NoModuleDeclarationCommentAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "comment not at top with no (module .. where) decl"-      "NoModuleDeclaration.hs"-      "NoModuleDeclaration.expected.hs"-      "import Data.Monoid"-  , checkImport-      "comment not at top (data dec is)"-      "DataAtTop.hs"-      "DataAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "comment not at top (newtype is)"-      "NewTypeAtTop.hs"-      "NewTypeAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "with no explicit module exports"-      "NoExplicitExports.hs"-      "NoExplicitExports.expected.hs"-      "import Data.Monoid"-  , checkImport-      "add to correctly placed exisiting import"-      "ImportAtTop.hs"-      "ImportAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "add to multiple correctly placed exisiting imports"-      "MultipleImportsAtTop.hs"-      "MultipleImportsAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "with language pragma at top of module"-      "LangPragmaModuleAtTop.hs"-      "LangPragmaModuleAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "with language pragma and explicit module exports"-      "LangPragmaModuleWithComment.hs"-      "LangPragmaModuleWithComment.expected.hs"-      "import Data.Monoid"-  , checkImport-      "with language pragma at top and no module declaration"-      "LanguagePragmaAtTop.hs"-      "LanguagePragmaAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "with multiple lang pragmas and no module declaration"-      "MultipleLanguagePragmasNoModuleDeclaration.hs"-      "MultipleLanguagePragmasNoModuleDeclaration.expected.hs"-      "import Data.Monoid"-  , checkImport-      "with pragmas and shebangs"-      "LanguagePragmasThenShebangs.hs"-      "LanguagePragmasThenShebangs.expected.hs"-      "import Data.Monoid"-  , checkImport-      "with pragmas and shebangs but no comment at top"-      "PragmasAndShebangsNoComment.hs"-      "PragmasAndShebangsNoComment.expected.hs"-      "import Data.Monoid"-  , checkImport-      "module decl no exports under pragmas and shebangs"-      "PragmasShebangsAndModuleDecl.hs"-      "PragmasShebangsAndModuleDecl.expected.hs"-      "import Data.Monoid"-  , checkImport-      "module decl with explicit import under pragmas and shebangs"-      "PragmasShebangsModuleExplicitExports.hs"-      "PragmasShebangsModuleExplicitExports.expected.hs"-      "import Data.Monoid"-  , checkImport-      "module decl and multiple imports"-      "ModuleDeclAndImports.hs"-      "ModuleDeclAndImports.expected.hs"-      "import Data.Monoid"-  ]--checkImport :: String -> FilePath -> FilePath -> T.Text -> TestTree-checkImport testComment originalPath expectedPath action =-  testSessionWithExtraFiles "import-placement" testComment $ \dir ->-    check (dir </> originalPath) (dir </> expectedPath) action-  where-    check :: FilePath -> FilePath -> T.Text -> Session ()-    check originalPath expectedPath action = do-      oSrc <- liftIO $ readFileUtf8 originalPath-      eSrc <- liftIO $  readFileUtf8 expectedPath-      originalDoc <- createDoc originalPath "haskell" oSrc-      _ <- waitForDiagnostics-      shouldBeDoc <- createDoc expectedPath "haskell" eSrc-      actionsOrCommands <- getAllCodeActions originalDoc-      chosenAction <- liftIO $ pickActionWithTitle action actionsOrCommands-      executeCodeAction chosenAction-      originalDocAfterAction <- documentContents originalDoc-      shouldBeDocContents <- documentContents shouldBeDoc-      liftIO $ T.replace "\r\n" "\n" shouldBeDocContents @=? T.replace "\r\n" "\n" originalDocAfterAction--renameActionTests :: TestTree-renameActionTests = testGroup "rename actions"-  [ testSession "change to local variable name" $ do-      let content = T.unlines-            [ "module Testing where"-            , "foo :: Int -> Int"-            , "foo argName = argNme"-            ]-      doc <- createDoc "Testing.hs" "haskell" content-      _ <- waitForDiagnostics-      action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"-      executeCodeAction action-      contentAfterAction <- documentContents doc-      let expectedContentAfterAction = T.unlines-            [ "module Testing where"-            , "foo :: Int -> Int"-            , "foo argName = argName"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "change to name of imported function" $ do-      let content = T.unlines-            [ "module Testing where"-            , "import Data.Maybe (maybeToList)"-            , "foo :: Maybe a -> [a]"-            , "foo = maybToList"-            ]-      doc <- createDoc "Testing.hs" "haskell" content-      _ <- waitForDiagnostics-      action <- findCodeAction doc (Range (Position 3 6) (Position 3 16))  "Replace with ‘maybeToList’"-      executeCodeAction action-      contentAfterAction <- documentContents doc-      let expectedContentAfterAction = T.unlines-            [ "module Testing where"-            , "import Data.Maybe (maybeToList)"-            , "foo :: Maybe a -> [a]"-            , "foo = maybeToList"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "suggest multiple local variable names" $ do-      let content = T.unlines-            [ "module Testing where"-            , "foo :: Char -> Char -> Char -> Char"-            , "foo argument1 argument2 argument3 = argumentX"-            ]-      doc <- createDoc "Testing.hs" "haskell" content-      _ <- waitForDiagnostics-      _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))-                           ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]-      return()-  , testSession "change infix function" $ do-      let content = T.unlines-            [ "module Testing where"-            , "monus :: Int -> Int"-            , "monus x y = max 0 (x - y)"-            , "foo x y = x `monnus` y"-            ]-      doc <- createDoc "Testing.hs" "haskell" content-      _ <- waitForDiagnostics-      actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))-      [fixTypo] <- pure [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]-      executeCodeAction fixTypo-      contentAfterAction <- documentContents doc-      let expectedContentAfterAction = T.unlines-            [ "module Testing where"-            , "monus :: Int -> Int"-            , "monus x y = max 0 (x - y)"-            , "foo x y = x `monus` y"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  ]--typeWildCardActionTests :: TestTree-typeWildCardActionTests = testGroup "type wildcard actions"-  [ testUseTypeSignature "global signature"-        [ "func :: _"-        , "func x = x"-        ]-        [ "func :: (p -> p)"-        , "func x = x"-        ]-  , testUseTypeSignature "local signature"-        [ "func :: Int -> Int"-        , "func x ="-        , "  let y :: _"-        , "      y = x * 2"-        , "  in y"-        ]-        [ "func :: Int -> Int"-        , "func x ="-        , "  let y :: Int"-        , "      y = x * 2"-        , "  in y"-        ]-  , testUseTypeSignature "multi-line message"-        [ "func :: _"-        , "func x y = x + y"-        ]-        [ "func :: (Integer -> Integer -> Integer)"-        , "func x y = x + y"-        ]-  , testUseTypeSignature "type in parentheses"-        [ "func :: a -> _"-        , "func x = (x, const x)"-        ]-        [ "func :: a -> (a, b -> a)"-        , "func x = (x, const x)"-        ]-  , testUseTypeSignature "type in brackets"-        [ "func :: _ -> Maybe a"-        , "func xs = head xs"-        ]-        [ "func :: [Maybe a] -> Maybe a"-        , "func xs = head xs"-        ]-  , testUseTypeSignature "unit type"-        [ "func :: IO _"-        , "func = putChar 'H'"-        ]-        [ "func :: IO ()"-        , "func = putChar 'H'"-        ]-  ]-  where-    -- | Test session of given name, checking action "Use type signature..."-    --   on a test file with given content and comparing to expected result.-    testUseTypeSignature name textIn textOut = testSession name $ do-        let fileStart = "module Testing where"-            content = T.unlines $ fileStart : textIn-            expectedContentAfterAction = T.unlines $ fileStart : textOut-        doc <- createDoc "Testing.hs" "haskell" content-        _ <- waitForDiagnostics-        actionsOrCommands <- getAllCodeActions doc-        let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands-                                    , "Use type signature" `T.isInfixOf` actionTitle-                            ]-        executeCodeAction addSignature-        contentAfterAction <- documentContents doc-        liftIO $ expectedContentAfterAction @=? contentAfterAction--{-# HLINT ignore "Use nubOrd" #-}-removeImportTests :: TestTree-removeImportTests = testGroup "remove import actions"-  [ testSession "redundant" $ do-      let contentA = T.unlines-            [ "module ModuleA where"-            ]-      _docA <- createDoc "ModuleA.hs" "haskell" contentA-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA"-            , "stuffB :: Integer"-            , "stuffB = 123"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- waitForDiagnostics-      [InR action@CodeAction { _title = actionTitle }, _]-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))-      liftIO $ "Remove import" @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents docB-      let expectedContentAfterAction = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "stuffB :: Integer"-            , "stuffB = 123"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "qualified redundant" $ do-      let contentA = T.unlines-            [ "module ModuleA where"-            ]-      _docA <- createDoc "ModuleA.hs" "haskell" contentA-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import qualified ModuleA"-            , "stuffB :: Integer"-            , "stuffB = 123"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- waitForDiagnostics-      [InR action@CodeAction { _title = actionTitle }, _]-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))-      liftIO $ "Remove import" @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents docB-      let expectedContentAfterAction = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "stuffB :: Integer"-            , "stuffB = 123"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "redundant binding" $ do-      let contentA = T.unlines-            [ "module ModuleA where"-            , "stuffA = False"-            , "stuffB :: Integer"-            , "stuffB = 123"-            , "stuffC = ()"-            , "_stuffD = '_'"-            ]-      _docA <- createDoc "ModuleA.hs" "haskell" contentA-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA (stuffA, stuffB, _stuffD, stuffC, stuffA)"-            , "main = print stuffB"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- waitForDiagnostics-      [InR action@CodeAction { _title = actionTitle }, _]-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))-      liftIO $ "Remove _stuffD, stuffA, stuffC from import" @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents docB-      let expectedContentAfterAction = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA (stuffB)"-            , "main = print stuffB"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "redundant operator" $ do-      let contentA = T.unlines-            [ "module ModuleA where"-            , "a !! _b = a"-            , "a <?> _b = a"-            , "stuffB :: Integer"-            , "stuffB = 123"-            ]-      _docA <- createDoc "ModuleA.hs" "haskell" contentA-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import qualified ModuleA as A ((<?>), stuffB, (!!))"-            , "main = print A.stuffB"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- waitForDiagnostics-      [InR action@CodeAction { _title = actionTitle }, _]-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))-      liftIO $ "Remove !!, <?> from import" @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents docB-      let expectedContentAfterAction = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import qualified ModuleA as A (stuffB)"-            , "main = print A.stuffB"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "redundant all import" $ do-      let contentA = T.unlines-            [ "module ModuleA where"-            , "data A = A"-            , "stuffB :: Integer"-            , "stuffB = 123"-            ]-      _docA <- createDoc "ModuleA.hs" "haskell" contentA-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA (A(..), stuffB)"-            , "main = print stuffB"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- waitForDiagnostics-      [InR action@CodeAction { _title = actionTitle }, _]-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))-      liftIO $ "Remove A from import" @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents docB-      let expectedContentAfterAction = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA (stuffB)"-            , "main = print stuffB"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "redundant constructor import" $ do-      let contentA = T.unlines-            [ "module ModuleA where"-            , "data D = A | B"-            , "data E = F"-            ]-      _docA <- createDoc "ModuleA.hs" "haskell" contentA-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA (D(A,B), E(F))"-            , "main = B"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- waitForDiagnostics-      [InR action@CodeAction { _title = actionTitle }, _]-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))-      liftIO $ "Remove A, E, F from import" @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents docB-      let expectedContentAfterAction = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA (D(B))"-            , "main = B"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "import containing the identifier Strict" $ do-      let contentA = T.unlines-            [ "module Strict where"-            ]-      _docA <- createDoc "Strict.hs" "haskell" contentA-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import Strict"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- waitForDiagnostics-      [InR action@CodeAction { _title = actionTitle }, _]-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))-      liftIO $ "Remove import" @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents docB-      let expectedContentAfterAction = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "remove all" $ do-      let content = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleA where"-            , "import Data.Function (fix, (&))"-            , "import qualified Data.Functor.Const"-            , "import Data.Functor.Identity"-            , "import Data.Functor.Sum (Sum (InL, InR))"-            , "import qualified Data.Kind as K (Constraint, Type)"-            , "x = InL (Identity 123)"-            , "y = fix id"-            , "type T = K.Type"-            ]-      doc <- createDoc "ModuleC.hs" "haskell" content-      _ <- waitForDiagnostics-      [_, _, _, _, InR action@CodeAction { _title = actionTitle }]-          <- nub <$> getAllCodeActions doc-      liftIO $ "Remove all redundant imports" @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents doc-      let expectedContentAfterAction = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleA where"-            , "import Data.Function (fix)"-            , "import Data.Functor.Identity"-            , "import Data.Functor.Sum (Sum (InL))"-            , "import qualified Data.Kind as K (Type)"-            , "x = InL (Identity 123)"-            , "y = fix id"-            , "type T = K.Type"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "remove unused operators whose name ends with '.'" $ do-      let contentA = T.unlines-            [ "module ModuleA where"-            , "(@.) = 0 -- Must have an operator whose name ends with '.'"-            , "a = 1 -- .. but also something else"-            ]-      _docA <- createDoc "ModuleA.hs" "haskell" contentA-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA (a, (@.))"-            , "x = a -- Must use something from module A, but not (@.)"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- waitForDiagnostics-      [InR action@CodeAction { _title = actionTitle }, _]-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))-      liftIO $ "Remove @. from import" @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents docB-      let expectedContentAfterAction = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA (a)"-            , "x = a -- Must use something from module A, but not (@.)"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  ]--extendImportTests :: TestTree-extendImportTests = testGroup "extend import actions"-  [ testGroup "with checkAll" $ tests True-  , testGroup "without checkAll" $ tests False-  ]-  where-    tests overrideCheckProject =-        [ testSession "extend all constructors for record field" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "data A = B { a :: Int }"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (A(B))"-                    , "f = a"-                    ])-            (Range (Position 2 4) (Position 2 5))-            [ "Add A(..) to the import list of ModuleA"-            , "Add A(a) to the import list of ModuleA"-            , "Add a to the import list of ModuleA"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (A(..))"-                    , "f = a"-                    ])-        , testSession "extend all constructors with sibling" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "data Foo"-                    , "data Bar"-                    , "data A = B | C"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA ( Foo,  A (C) , Bar ) "-                    , "f = B"-                    ])-            (Range (Position 2 4) (Position 2 5))-            [ "Add A(..) to the import list of ModuleA"-            , "Add A(B) to the import list of ModuleA"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA ( Foo,  A (..) , Bar ) "-                    , "f = B"-                    ])-        , testSession "extend all constructors with comment" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "data Foo"-                    , "data Bar"-                    , "data A = B | C"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA ( Foo,  A (C{-comment--}) , Bar ) "-                    , "f = B"-                    ])-            (Range (Position 2 4) (Position 2 5))-            [ "Add A(..) to the import list of ModuleA"-            , "Add A(B) to the import list of ModuleA"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA ( Foo,  A (..{-comment--}) , Bar ) "-                    , "f = B"-                    ])-        , testSession "extend all constructors for type operator" $ template-            []-            ("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "import Data.Type.Equality ((:~:))"-                    , "x :: (:~:) [] []"-                    , "x = Refl"-                    ])-            (Range (Position 3 17) (Position 3 18))-            [ "Add (:~:)(..) to the import list of Data.Type.Equality"-            , "Add type (:~:)(Refl) to the import list of Data.Type.Equality"]-            (T.unlines-                    [ "module ModuleA where"-                    , "import Data.Type.Equality ((:~:) (..))"-                    , "x :: (:~:) [] []"-                    , "x = Refl"-                    ])-        , testSession "extend all constructors for class" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "class C a where"-                    , "  m1 :: a -> a"-                    , "  m2 :: a -> a"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (C(m1))"-                    , "b = m2"-                    ])-            (Range (Position 2 5) (Position 2 5))-            [ "Add C(..) to the import list of ModuleA"-            , "Add C(m2) to the import list of ModuleA"-            , "Add m2 to the import list of ModuleA"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (C(..))"-                    , "b = m2"-                    ])-        , testSession "extend single line import with value" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "stuffA :: Double"-                    , "stuffA = 0.00750"-                    , "stuffB :: Integer"-                    , "stuffB = 123"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA as A (stuffB)"-                    , "main = print (stuffA, stuffB)"-                    ])-            (Range (Position 2 17) (Position 2 18))-            ["Add stuffA to the import list of ModuleA"]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA as A (stuffB, stuffA)"-                    , "main = print (stuffA, stuffB)"-                    ])-        , testSession "extend single line import with operator" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "(.*) :: Integer -> Integer -> Integer"-                    , "x .* y = x * y"-                    , "stuffB :: Integer"-                    , "stuffB = 123"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA as A (stuffB)"-                    , "main = print (stuffB .* stuffB)"-                    ])-            (Range (Position 2 17) (Position 2 18))-            ["Add (.*) to the import list of ModuleA"]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA as A (stuffB, (.*))"-                    , "main = print (stuffB .* stuffB)"-                    ])-        , testSession "extend single line import with infix constructor" $ template-            []-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import Data.List.NonEmpty (fromList)"-                    , "main = case (fromList []) of _ :| _ -> pure ()"-                    ])-            (Range (Position 2 5) (Position 2 6))-            [ "Add NonEmpty((:|)) to the import list of Data.List.NonEmpty"-            , "Add NonEmpty(..) to the import list of Data.List.NonEmpty"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import Data.List.NonEmpty (fromList, NonEmpty ((:|)))"-                    , "main = case (fromList []) of _ :| _ -> pure ()"-                    ])-        , testSession "extend single line import with prefix constructor" $ template-            []-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import Prelude hiding (Maybe(..))"-                    , "import Data.Maybe (catMaybes)"-                    , "x = Just 10"-                    ])-            (Range (Position 3 5) (Position 2 6))-            [ "Add Maybe(Just) to the import list of Data.Maybe"-            , "Add Maybe(..) to the import list of Data.Maybe"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import Prelude hiding (Maybe(..))"-                    , "import Data.Maybe (catMaybes, Maybe (Just))"-                    , "x = Just 10"-                    ])-        , testSession "extend single line import with type" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "type A = Double"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA ()"-                    , "b :: A"-                    , "b = 0"-                    ])-            (Range (Position 2 5) (Position 2 5))-            ["Add A to the import list of ModuleA"]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (A)"-                    , "b :: A"-                    , "b = 0"-                    ])-        , testSession "extend single line import with constructor" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "data A = Constructor"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (A)"-                    , "b :: A"-                    , "b = Constructor"-                    ])-            (Range (Position 3 5) (Position 3 5))-            [ "Add A(Constructor) to the import list of ModuleA"-            , "Add A(..) to the import list of ModuleA"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (A (Constructor))"-                    , "b :: A"-                    , "b = Constructor"-                    ])-        , testSession "extend single line import with constructor (with comments)" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "data A = Constructor"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (A ({-Constructor-}))"-                    , "b :: A"-                    , "b = Constructor"-                    ])-            (Range (Position 3 5) (Position 3 5))-            [ "Add A(Constructor) to the import list of ModuleA"-            , "Add A(..) to the import list of ModuleA"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (A (Constructor{-Constructor-}))"-                    , "b :: A"-                    , "b = Constructor"-                    ])-        , testSession "extend single line import with mixed constructors" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "data A = ConstructorFoo | ConstructorBar"-                    , "a = 1"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (A (ConstructorBar), a)"-                    , "b :: A"-                    , "b = ConstructorFoo"-                    ])-            (Range (Position 3 5) (Position 3 5))-            [ "Add A(ConstructorFoo) to the import list of ModuleA"-            , "Add A(..) to the import list of ModuleA"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (A (ConstructorBar, ConstructorFoo), a)"-                    , "b :: A"-                    , "b = ConstructorFoo"-                    ])-        , testSession "extend single line qualified import with value" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "stuffA :: Double"-                    , "stuffA = 0.00750"-                    , "stuffB :: Integer"-                    , "stuffB = 123"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import qualified ModuleA as A (stuffB)"-                    , "main = print (A.stuffA, A.stuffB)"-                    ])-            (Range (Position 2 17) (Position 2 18))-            ["Add stuffA to the import list of ModuleA"]-            (T.unlines-                    [ "module ModuleB where"-                    , "import qualified ModuleA as A (stuffB, stuffA)"-                    , "main = print (A.stuffA, A.stuffB)"-                    ])-        , testSession "extend multi line import with value" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "stuffA :: Double"-                    , "stuffA = 0.00750"-                    , "stuffB :: Integer"-                    , "stuffB = 123"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (stuffB"-                    , "               )"-                    , "main = print (stuffA, stuffB)"-                    ])-            (Range (Position 3 17) (Position 3 18))-            ["Add stuffA to the import list of ModuleA"]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (stuffB, stuffA"-                    , "               )"-                    , "main = print (stuffA, stuffB)"-                    ])-        , testSession "extend single line import with method within class" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "class C a where"-                    , "  m1 :: a -> a"-                    , "  m2 :: a -> a"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (C(m1))"-                    , "b = m2"-                    ])-            (Range (Position 2 5) (Position 2 5))-            [ "Add C(m2) to the import list of ModuleA"-            , "Add m2 to the import list of ModuleA"-            , "Add C(..) to the import list of ModuleA"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (C(m1, m2))"-                    , "b = m2"-                    ])-        , testSession "extend single line import with method without class" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "class C a where"-                    , "  m1 :: a -> a"-                    , "  m2 :: a -> a"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (C(m1))"-                    , "b = m2"-                    ])-            (Range (Position 2 5) (Position 2 5))-            [ "Add m2 to the import list of ModuleA"-            , "Add C(m2) to the import list of ModuleA"-            , "Add C(..) to the import list of ModuleA"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (C(m1), m2)"-                    , "b = m2"-                    ])-        , testSession "extend import list with multiple choices" $ template-            [("ModuleA.hs", T.unlines-                    --  this is just a dummy module to help the arguments needed for this test-                    [  "module ModuleA (bar) where"-                    , "bar = 10"-                    ]),-            ("ModuleB.hs", T.unlines-                    --  this is just a dummy module to help the arguments needed for this test-                    [  "module ModuleB (bar) where"-                    , "bar = 10"-                    ])]-            ("ModuleC.hs", T.unlines-                    [ "module ModuleC where"-                    , "import ModuleB ()"-                    , "import ModuleA ()"-                    , "foo = bar"-                    ])-            (Range (Position 3 17) (Position 3 18))-            ["Add bar to the import list of ModuleA",-            "Add bar to the import list of ModuleB"]-            (T.unlines-                    [ "module ModuleC where"-                    , "import ModuleB ()"-                    , "import ModuleA (bar)"-                    , "foo = bar"-                    ])-        , testSession "extend import list with constructor of type operator" $ template-            []-            ("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "import Data.Type.Equality ((:~:))"-                    , "x :: (:~:) [] []"-                    , "x = Refl"-                    ])-            (Range (Position 3 17) (Position 3 18))-            [ "Add type (:~:)(Refl) to the import list of Data.Type.Equality"-            , "Add (:~:)(..) to the import list of Data.Type.Equality"]-            (T.unlines-                    [ "module ModuleA where"-                    , "import Data.Type.Equality ((:~:) (Refl))"-                    , "x :: (:~:) [] []"-                    , "x = Refl"-                    ])-        , expectFailBecause "importing pattern synonyms is unsupported"-          $ testSession "extend import list with pattern synonym" $ template-            [("ModuleA.hs", T.unlines-                    [ "{-# LANGUAGE PatternSynonyms #-}"-                      , "module ModuleA where"-                      , "pattern Some x = Just x"-                    ])-            ]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import A ()"-                    , "k (Some x) = x"-                    ])-            (Range (Position 2 3) (Position 2 7))-            ["Add pattern Some to the import list of A"]-            (T.unlines-                    [ "module ModuleB where"-                    , "import A (pattern Some)"-                    , "k (Some x) = x"-                    ])-        , ignoreForGHC92 "Diagnostic message has no suggestions" $-          testSession "type constructor name same as data constructor name" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "newtype Foo = Foo Int"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA(Foo)"-                    , "f :: Foo"-                    , "f = Foo 1"-                    ])-            (Range (Position 3 4) (Position 3 6))-            ["Add Foo(Foo) to the import list of ModuleA", "Add Foo(..) to the import list of ModuleA"]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA(Foo (Foo))"-                    , "f :: Foo"-                    , "f = Foo 1"-                    ])-        , testSession "type constructor name same as data constructor name, data constructor extraneous" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "data Foo = Foo"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA()"-                    , "f :: Foo"-                    , "f = undefined"-                    ])-            (Range (Position 2 4) (Position 2 6))-            ["Add Foo to the import list of ModuleA"]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA(Foo)"-                    , "f :: Foo"-                    , "f = undefined"-                    ])-        ]-      where-        codeActionTitle CodeAction{_title=x} = x--        template setUpModules moduleUnderTest range expectedTitles expectedContentB = do-            configureCheckProject overrideCheckProject--            mapM_ (\x -> createDoc (fst x) "haskell" (snd x)) setUpModules-            docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest)-            _  <- waitForDiagnostics-            waitForProgressDone-            actionsOrCommands <- getCodeActions docB range-            let codeActions =-                  filter-                    (T.isPrefixOf "Add" . codeActionTitle)-                    [ca | InR ca <- actionsOrCommands]-                actualTitles = codeActionTitle <$> codeActions-            -- Note that we are not testing the order of the actions, as the-            -- order of the expected actions indicates which one we'll execute-            -- in this test, i.e., the first one.-            liftIO $ sort expectedTitles @=? sort actualTitles--            -- Execute the action with the same title as the first expected one.-            -- Since we tested that both lists have the same elements (possibly-            -- in a different order), this search cannot fail.-            let firstTitle:_ = expectedTitles-                action = fromJust $-                  find ((firstTitle ==) . codeActionTitle) codeActions-            executeCodeAction action-            contentAfterAction <- documentContents docB-            liftIO $ expectedContentB @=? contentAfterAction--fixModuleImportTypoTests :: TestTree-fixModuleImportTypoTests = testGroup "fix module import typo"-    [ testSession "works when single module suggested" $ do-        doc <- createDoc "A.hs" "haskell" "import Data.Cha"-        _ <- waitForDiagnostics-        InR action@CodeAction { _title = actionTitle } : _  <- getCodeActions doc (R 0 0 0 10)-        liftIO $ actionTitle @?= "replace with Data.Char"-        executeCodeAction action-        contentAfterAction <- documentContents doc-        liftIO $ contentAfterAction @?= "import Data.Char"-    , testSession "works when multiple modules suggested" $ do-        doc <- createDoc "A.hs" "haskell" "import Data.I"-        _ <- waitForDiagnostics-        actions <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> getCodeActions doc (R 0 0 0 10)-        let actionTitles = [ title | InR CodeAction{_title=title} <- actions ]-        liftIO $ actionTitles @?= [ "replace with Data.Eq"-                                  , "replace with Data.Int"-                                  , "replace with Data.Ix"-                                  ]-        let InR replaceWithDataEq : _ = actions-        executeCodeAction replaceWithDataEq-        contentAfterAction <- documentContents doc-        liftIO $ contentAfterAction @?= "import Data.Eq"-    ]--extendImportTestsRegEx :: TestTree-extendImportTestsRegEx = testGroup "regex parsing"-    [-      testCase "parse invalid multiple imports" $ template "foo bar foo" Nothing-    , testCase "parse malformed import list" $ template-                  "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n    \8216Data.Map\8217)"-                  Nothing-    , testCase "parse multiple imports" $ template-                 "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n    \8216Data.Map\8217 (app/testlsp.hs:7:1-18)\n    \8216Data.HashMap.Strict\8217 (app/testlsp.hs:8:1-29)"-                 $ Just ("fromList",[("Data.Map","app/testlsp.hs:7:1-18"),("Data.HashMap.Strict","app/testlsp.hs:8:1-29")])-    ]-    where-        template message expected = do-            liftIO $ matchRegExMultipleImports message @=? expected--suggestImportClassMethodTests :: TestTree-suggestImportClassMethodTests =-  testGroup-    "suggest import class methods"-    [ testGroup-        "new"-        [ testSession "via parent" $-            template'-            "import Data.Semigroup (Semigroup(stimes))"-            (Range (Position 4 2) (Position 4 8)),-          testSession "top level" $-            template'-              "import Data.Semigroup (stimes)"-              (Range (Position 4 2) (Position 4 8)),-          testSession "all" $-            template'-              "import Data.Semigroup"-              (Range (Position 4 2) (Position 4 8))-        ],-      testGroup-        "extend"-        [ testSession "via parent" $-            template-              [ "module A where",-                "",-                "import Data.Semigroup ()"-              ]-              (Range (Position 6 2) (Position 6 8))-              "Add Semigroup(stimes) to the import list of Data.Semigroup"-              [ "module A where",-                "",-                "import Data.Semigroup (Semigroup (stimes))"-              ],-          testSession "top level" $-            template-              [ "module A where",-                "",-                "import Data.Semigroup ()"-              ]-              (Range (Position 6 2) (Position 6 8))-              "Add stimes to the import list of Data.Semigroup"-              [ "module A where",-                "",-                "import Data.Semigroup (stimes)"-              ]-        ]-    ]-  where-    decls =-      [ "data X = X",-        "instance Semigroup X where",-        "  (<>) _ _ = X",-        "  stimes _ _ = X"-      ]-    template beforeContent range executeTitle expectedContent = do-      doc <- createDoc "A.hs" "haskell" $ T.unlines (beforeContent <> decls)-      _ <- waitForDiagnostics-      waitForProgressDone-      actions <- getCodeActions doc range-      let actions' = [x | InR x <- actions]-          titles = [_title | CodeAction {_title} <- actions']-      liftIO $ executeTitle `elem` titles @? T.unpack executeTitle <> " does not in " <> show titles-      executeCodeAction $ fromJust $ find (\CodeAction {_title} -> _title == executeTitle) actions'-      content <- documentContents doc-      liftIO $ T.unlines (expectedContent <> decls) @=? content-    template' executeTitle range = let c = ["module A where"] in template c range executeTitle $ c <> [executeTitle]--suggestImportTests :: TestTree-suggestImportTests = testGroup "suggest import actions"-  [ testGroup "Dont want suggestion"-    [ -- extend import-      test False ["Data.List.NonEmpty ()"] "f = nonEmpty" []                "import Data.List.NonEmpty (nonEmpty)"-      -- data constructor-    , test False []                        "f = First"    []                "import Data.Monoid (First)"-      -- internal module-    , test False []         "f :: Typeable a => a"        ["f = undefined"] "import Data.Typeable.Internal (Typeable)"-      -- package not in scope-    , test False []         "f = quickCheck"              []                "import Test.QuickCheck (quickCheck)"-      -- don't omit the parent data type of a constructor-    , test False []         "f ExitSuccess = ()"          []                "import System.Exit (ExitSuccess)"-      -- don't suggest data constructor when we only need the type-    , test False []         "f :: Bar"                    []                "import Bar (Bar(Bar))"-      -- don't suggest all data constructors for the data type-    , test False []         "f :: Bar"                    []                "import Bar (Bar(..))"-    ]-  , testGroup "want suggestion"-    [ wantWait  []          "f = foo"                     []                "import Foo (foo)"-    , wantWait  []          "f = Bar"                     []                "import Bar (Bar(Bar))"-    , wantWait  []          "f :: Bar"                    []                "import Bar (Bar)"-    , wantWait  []          "f = Bar"                     []                "import Bar (Bar(..))"-    , test True []          "f = nonEmpty"                []                "import Data.List.NonEmpty (nonEmpty)"-    , test True []          "f = (:|)"                    []                "import Data.List.NonEmpty (NonEmpty((:|)))"-    , test True []          "f :: Natural"                ["f = undefined"] "import Numeric.Natural (Natural)"-    , test True []          "f :: Natural"                ["f = undefined"] "import Numeric.Natural"-    , test True []          "f :: NonEmpty ()"            ["f = () :| []"]  "import Data.List.NonEmpty (NonEmpty)"-    , test True []          "f :: NonEmpty ()"            ["f = () :| []"]  "import Data.List.NonEmpty"-    , test True []          "f = First"                   []                "import Data.Monoid (First(First))"-    , test True []          "f = Endo"                    []                "import Data.Monoid (Endo(Endo))"-    , test True []          "f = Version"                 []                "import Data.Version (Version(Version))"-    , test True []          "f ExitSuccess = ()"          []                "import System.Exit (ExitCode(ExitSuccess))"-    , test True []          "f = AssertionFailed"         []                "import Control.Exception (AssertionFailed(AssertionFailed))"-    , test True ["Prelude"] "f = nonEmpty"                []                "import Data.List.NonEmpty (nonEmpty)"-    , test True []          "f :: Alternative f => f ()"  ["f = undefined"] "import Control.Applicative (Alternative)"-    , test True []          "f :: Alternative f => f ()"  ["f = undefined"] "import Control.Applicative"-    , test True []          "f = empty"                   []                "import Control.Applicative (Alternative(empty))"-    , test True []          "f = empty"                   []                "import Control.Applicative (empty)"-    , test True []          "f = empty"                   []                "import Control.Applicative"-    , test True []          "f = (&)"                     []                "import Data.Function ((&))"-    , test True []          "f = NE.nonEmpty"             []                "import qualified Data.List.NonEmpty as NE"-    , test True []          "f = Data.List.NonEmpty.nonEmpty" []            "import qualified Data.List.NonEmpty"-    , test True []          "f :: Typeable a => a"        ["f = undefined"] "import Data.Typeable (Typeable)"-    , test True []          "f = pack"                    []                "import Data.Text (pack)"-    , test True []          "f :: Text"                   ["f = undefined"] "import Data.Text (Text)"-    , test True []          "f = [] & id"                 []                "import Data.Function ((&))"-    , test True []          "f = (&) [] id"               []                "import Data.Function ((&))"-    , test True []          "f = (.|.)"                   []                "import Data.Bits (Bits((.|.)))"-    , test True []          "f = (.|.)"                   []                "import Data.Bits ((.|.))"-    , test True []          "f :: a ~~ b"                 []                "import Data.Type.Equality (type (~~))"-    , test True-      ["qualified Data.Text as T"-      ]                     "f = T.putStrLn"              []                "import qualified Data.Text.IO as T"-    , test True-      [ "qualified Data.Text as T"-      , "qualified Data.Function as T"-      ]                     "f = T.putStrLn"              []                "import qualified Data.Text.IO as T"-    , test True-      [ "qualified Data.Text as T"-      , "qualified Data.Function as T"-      , "qualified Data.Functor as T"-      , "qualified Data.Data as T"-      ]                     "f = T.putStrLn"              []                "import qualified Data.Text.IO as T"-    , test True []          "f = (.|.)"                   []                "import Data.Bits (Bits(..))"-    , test True []          "f = empty"                   []                "import Control.Applicative (Alternative(..))"-    ]-  , expectFailBecause "importing pattern synonyms is unsupported" $ test True [] "k (Some x) = x" [] "import B (pattern Some)"-  ]-  where-    test = test' False-    wantWait = test' True True--    test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do-      configureCheckProject waitForCheckProject-      let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other-          after  = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other-          cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo, B]}}"-      liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle-      liftIO $ writeFileUTF8 (dir </> "B.hs") $ unlines ["{-# LANGUAGE PatternSynonyms #-}", "module B where", "pattern Some x = Just x"]-      doc <- createDoc "Test.hs" "haskell" before-      waitForProgressDone-      _ <- waitForDiagnostics-      -- there isn't a good way to wait until the whole project is checked atm-      when waitForCheckProject $ liftIO $ sleep 0.5-      let defLine = fromIntegral $ length imps + 1-          range = Range (Position defLine 0) (Position defLine maxBound)-      actions <- getCodeActions doc range-      if wanted-         then do-             action <- liftIO $ pickActionWithTitle newImp actions-             executeCodeAction action-             contentAfterAction <- documentContents doc-             liftIO $ after @=? contentAfterAction-          else-              liftIO $ [_title | InR CodeAction{_title} <- actions, _title == newImp ] @?= []--suggestImportDisambiguationTests :: TestTree-suggestImportDisambiguationTests = testGroup "suggest import disambiguation actions"-  [ testGroup "Hiding strategy works"-    [ testGroup "fromList"-        [ testCase "AVec" $-            compareHideFunctionTo [(8,9),(10,8)]-                "Use AVec for fromList, hiding other imports"-                "HideFunction.expected.fromList.A.hs"-        , testCase "BVec" $-            compareHideFunctionTo [(8,9),(10,8)]-                "Use BVec for fromList, hiding other imports"-                "HideFunction.expected.fromList.B.hs"-        ]-    , testGroup "(++)"-        [ testCase "EVec" $-            compareHideFunctionTo [(8,9),(10,8)]-                "Use EVec for ++, hiding other imports"-                "HideFunction.expected.append.E.hs"-        , testCase "Hide functions without local" $-            compareTwo-                "HideFunctionWithoutLocal.hs" [(8,8)]-                "Use local definition for ++, hiding other imports"-                "HideFunctionWithoutLocal.expected.hs"-        , testCase "Prelude" $-            compareHideFunctionTo [(8,9),(10,8)]-                "Use Prelude for ++, hiding other imports"-                "HideFunction.expected.append.Prelude.hs"-        , testCase "Prelude and local definition, infix" $-            compareTwo-                "HidePreludeLocalInfix.hs" [(2,19)]-                "Use local definition for ++, hiding other imports"-                "HidePreludeLocalInfix.expected.hs"-        , testCase "AVec, indented" $-            compareTwo "HidePreludeIndented.hs" [(3,8)]-            "Use AVec for ++, hiding other imports"-            "HidePreludeIndented.expected.hs"--        ]-    , testGroup "Vec (type)"-        [ testCase "AVec" $-            compareTwo-                "HideType.hs" [(8,15)]-                "Use AVec for Vec, hiding other imports"-                "HideType.expected.A.hs"-        , testCase "EVec" $-            compareTwo-                "HideType.hs" [(8,15)]-                "Use EVec for Vec, hiding other imports"-                "HideType.expected.E.hs"-        ]-    ]-  , testGroup "Qualify strategy"-    [ testCase "won't suggest full name for qualified module" $-      withHideFunction [(8,9),(10,8)] $ \_ actions -> do-        liftIO $-            assertBool "EVec.fromList must not be suggested" $-                "Replace with qualified: EVec.fromList" `notElem`-                [ actionTitle-                | InR CodeAction { _title = actionTitle } <- actions-                ]-        liftIO $-            assertBool "EVec.++ must not be suggested" $-                "Replace with qualified: EVec.++" `notElem`-                [ actionTitle-                | InR CodeAction { _title = actionTitle } <- actions-                ]-    , testGroup "fromList"-        [ testCase "EVec" $-            compareHideFunctionTo [(8,9),(10,8)]-                "Replace with qualified: E.fromList"-                "HideFunction.expected.qualified.fromList.E.hs"-        , testCase "Hide DuplicateRecordFields" $-            compareTwo-                "HideQualifyDuplicateRecordFields.hs" [(9, 9)]-                "Replace with qualified: AVec.fromList"-                "HideQualifyDuplicateRecordFields.expected.hs"-        , testCase "Duplicate record fields should not be imported" $ do-          withTarget ("HideQualifyDuplicateRecordFields" <.> ".hs") [(9, 9)] $-            \_ actions -> do-              liftIO $-                assertBool "Hidings should not be presented while DuplicateRecordFields exists" $-                  all not [ actionTitle =~ T.pack "Use ([A-Za-z][A-Za-z0-9]*) for fromList, hiding other imports"-                      | InR CodeAction { _title = actionTitle } <- actions]-          withTarget ("HideQualifyDuplicateRecordFieldsSelf" <.> ".hs") [(4, 4)] $-            \_ actions -> do-              liftIO $-                assertBool "ambiguity from DuplicateRecordFields should not be imported" $-                  null actions-        ]-    , testGroup "(++)"-        [ testCase "Prelude, parensed" $-            compareHideFunctionTo [(8,9),(10,8)]-                "Replace with qualified: Prelude.++"-                "HideFunction.expected.qualified.append.Prelude.hs"-        , testCase "Prelude, infix" $-            compareTwo-                "HideQualifyInfix.hs" [(4,19)]-                "Replace with qualified: Prelude.++"-                "HideQualifyInfix.expected.hs"-        , testCase "Prelude, left section" $-            compareTwo-                "HideQualifySectionLeft.hs" [(4,15)]-                "Replace with qualified: Prelude.++"-                "HideQualifySectionLeft.expected.hs"-        , testCase "Prelude, right section" $-            compareTwo-                "HideQualifySectionRight.hs" [(4,18)]-                "Replace with qualified: Prelude.++"-                "HideQualifySectionRight.expected.hs"-        ]-    ]-  ]-  where-    hidingDir = "test/data/hiding"-    compareTwo original locs cmd expected =-        withTarget original locs $ \doc actions -> do-            expected <- liftIO $-                readFileUtf8 (hidingDir </> expected)-            action <- liftIO $ pickActionWithTitle cmd actions-            executeCodeAction action-            contentAfterAction <- documentContents doc-            liftIO $ T.replace "\r\n" "\n" expected @=? contentAfterAction-    compareHideFunctionTo = compareTwo "HideFunction.hs"-    auxFiles = ["AVec.hs", "BVec.hs", "CVec.hs", "DVec.hs", "EVec.hs", "FVec.hs"]-    withTarget file locs k = withTempDir $ \dir -> runInDir dir $ do-        liftIO $ mapM_ (\fp -> copyFile (hidingDir </> fp) $ dir </> fp)-            $ file : auxFiles-        doc <- openDoc file "haskell"-        waitForProgressDone-        void $ expectDiagnostics [(file, [(DsError, loc, "Ambiguous occurrence") | loc <- locs])]-        actions <- getAllCodeActions doc-        k doc actions-    withHideFunction = withTarget ("HideFunction" <.> "hs")--suggestHideShadowTests :: TestTree-suggestHideShadowTests =-  testGroup-    "suggest hide shadow"-    [ testGroup-        "single"-        [ testOneCodeAction-            "hide unsued"-            "Hide on from Data.Function"-            (1, 2)-            (1, 4)-            [ "import Data.Function"-            , "f on = on"-            , "g on = on"-            ]-            [ "import Data.Function hiding (on)"-            , "f on = on"-            , "g on = on"-            ]-        , testOneCodeAction-            "extend hiding unsued"-            "Hide on from Data.Function"-            (1, 2)-            (1, 4)-            [ "import Data.Function hiding ((&))"-            , "f on = on"-            ]-            [ "import Data.Function hiding (on, (&))"-            , "f on = on"-            ]-        , testOneCodeAction-            "delete unsued"-            "Hide on from Data.Function"-            (1, 2)-            (1, 4)-            [ "import Data.Function ((&), on)"-            , "f on = on"-            ]-            [ "import Data.Function ((&))"-            , "f on = on"-            ]-        , testOneCodeAction-            "hide operator"-            "Hide & from Data.Function"-            (1, 2)-            (1, 5)-            [ "import Data.Function"-            , "f (&) = (&)"-            ]-            [ "import Data.Function hiding ((&))"-            , "f (&) = (&)"-            ]-        , testOneCodeAction-            "remove operator"-            "Hide & from Data.Function"-            (1, 2)-            (1, 5)-            [ "import Data.Function ((&), on)"-            , "f (&) = (&)"-            ]-            [ "import Data.Function ( on)"-            , "f (&) = (&)"-            ]-        , noCodeAction-            "don't remove already used"-            (2, 2)-            (2, 4)-            [ "import Data.Function"-            , "g = on"-            , "f on = on"-            ]-        ]-    , testGroup-        "multi"-        [ testOneCodeAction-            "hide from B"-            "Hide ++ from B"-            (2, 2)-            (2, 6)-            [ "import B"-            , "import C"-            , "f (++) = (++)"-            ]-            [ "import B hiding ((++))"-            , "import C"-            , "f (++) = (++)"-            ]-        , testOneCodeAction-            "hide from C"-            "Hide ++ from C"-            (2, 2)-            (2, 6)-            [ "import B"-            , "import C"-            , "f (++) = (++)"-            ]-            [ "import B"-            , "import C hiding ((++))"-            , "f (++) = (++)"-            ]-        , testOneCodeAction-            "hide from Prelude"-            "Hide ++ from Prelude"-            (2, 2)-            (2, 6)-            [ "import B"-            , "import C"-            , "f (++) = (++)"-            ]-            [ "import B"-            , "import C"-            , "import Prelude hiding ((++))"-            , "f (++) = (++)"-            ]-        , testMultiCodeActions-            "manual hide all"-            [ "Hide ++ from Prelude"-            , "Hide ++ from C"-            , "Hide ++ from B"-            ]-            (2, 2)-            (2, 6)-            [ "import B"-            , "import C"-            , "f (++) = (++)"-            ]-            [ "import B hiding ((++))"-            , "import C hiding ((++))"-            , "import Prelude hiding ((++))"-            , "f (++) = (++)"-            ]-        , testOneCodeAction-            "auto hide all"-            "Hide ++ from all occurence imports"-            (2, 2)-            (2, 6)-            [ "import B"-            , "import C"-            , "f (++) = (++)"-            ]-            [ "import B hiding ((++))"-            , "import C hiding ((++))"-            , "import Prelude hiding ((++))"-            , "f (++) = (++)"-            ]-        ]-    ]- where-  testOneCodeAction testName actionName start end origin expected =-    helper testName start end origin expected $ \cas -> do-      action <- liftIO $ pickActionWithTitle actionName cas-      executeCodeAction action-  noCodeAction testName start end origin =-    helper testName start end origin origin $ \cas -> do-      liftIO $ cas @?= []-  testMultiCodeActions testName actionNames start end origin expected =-    helper testName start end origin expected $ \cas -> do-      let r = [ca | (InR ca) <- cas, ca ^. L.title `elem` actionNames]-      liftIO $-        (length r == length actionNames)-          @? "Expected " <> show actionNames <> ", but got " <> show cas <> " which is not its superset"-      forM_ r executeCodeAction-  helper testName (line1, col1) (line2, col2) origin expected k = testSession testName $ do-    void $ createDoc "B.hs" "haskell" $ T.unlines docB-    void $ createDoc "C.hs" "haskell" $ T.unlines docC-    doc <- createDoc "A.hs" "haskell" $ T.unlines (header <> origin)-    void waitForDiagnostics-    waitForProgressDone-    cas <- getCodeActions doc (Range (Position (fromIntegral $ line1 + length header) col1) (Position (fromIntegral $ line2 + length header) col2))-    void $ k [x | x@(InR ca) <- cas, "Hide" `T.isPrefixOf` (ca ^. L.title)]-    contentAfter <- documentContents doc-    liftIO $ contentAfter @?= T.unlines (header <> expected)-  header =-    [ "{-# OPTIONS_GHC -Wname-shadowing #-}"-    , "module A where"-    , ""-    ]-  -- for multi group-  docB =-    [ "module B where"-    , "(++) = id"-    ]-  docC =-    [ "module C where"-    , "(++) = id"-    ]--insertNewDefinitionTests :: TestTree-insertNewDefinitionTests = testGroup "insert new definition actions"-  [ testSession "insert new function definition" $ do-      let txtB =-            ["foo True = select [True]"-            , ""-            ,"foo False = False"-            ]-          txtB' =-            [""-            ,"someOtherCode = ()"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')-      _ <- waitForDiagnostics-      InR action@CodeAction { _title = actionTitle } : _-                  <- sortOn (\(InR CodeAction{_title=x}) -> x) <$>-                     getCodeActions docB (R 0 0 0 50)-      liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"-      executeCodeAction action-      contentAfterAction <- documentContents docB-      liftIO $ contentAfterAction @?= T.unlines (txtB ++-        [ ""-        , "select :: [Bool] -> Bool"-        , "select = _"-        ]-        ++ txtB')-  , testSession "define a hole" $ do-      let txtB =-            ["foo True = _select [True]"-            , ""-            ,"foo False = False"-            ]-          txtB' =-            [""-            ,"someOtherCode = ()"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')-      _ <- waitForDiagnostics-      InR action@CodeAction { _title = actionTitle } : _-                  <- sortOn (\(InR CodeAction{_title=x}) -> x) <$>-                     getCodeActions docB (R 0 0 0 50)-      liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"-      executeCodeAction action-      contentAfterAction <- documentContents docB-      liftIO $ contentAfterAction @?= T.unlines (-        ["foo True = select [True]"-        , ""-        ,"foo False = False"-        , ""-        , "select :: [Bool] -> Bool"-        , "select = _"-        ]-        ++ txtB')-  , testSession "insert new function definition - Haddock comments" $ do-    let start =  ["foo :: Int -> Bool"-                 , "foo x = select (x + 1)"-                 , ""-                 , "-- | This is a haddock comment"-                 , "haddock :: Int -> Int"-                 , "haddock = undefined"-                 ]-    let expected =  ["foo :: Int -> Bool"-             , "foo x = select (x + 1)"-             , ""-             , "select :: Int -> Bool"-             , "select = _"-             , ""-             , "-- | This is a haddock comment"-             , "haddock :: Int -> Int"-             , "haddock = undefined"]-    docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start)-    _ <- waitForDiagnostics-    InR action@CodeAction { _title = actionTitle } : _-                <- sortOn (\(InR CodeAction{_title=x}) -> x) <$>-                    getCodeActions docB (R 1 0 0 50)-    liftIO $ actionTitle @?= "Define select :: Int -> Bool"-    executeCodeAction action-    contentAfterAction <- documentContents docB-    liftIO $ contentAfterAction @?= T.unlines expected-  , testSession "insert new function definition - normal comments" $ do-    let start =  ["foo :: Int -> Bool"-                 , "foo x = select (x + 1)"-                 , ""-                 , "-- This is a normal comment"-                 , "normal :: Int -> Int"-                 , "normal = undefined"-                 ]-    let expected =  ["foo :: Int -> Bool"-             , "foo x = select (x + 1)"-             , ""-             , "select :: Int -> Bool"-             , "select = _"-             , ""-             , "-- This is a normal comment"-             , "normal :: Int -> Int"-             , "normal = undefined"]-    docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start)-    _ <- waitForDiagnostics-    InR action@CodeAction { _title = actionTitle } : _-                <- sortOn (\(InR CodeAction{_title=x}) -> x) <$>-                    getCodeActions docB (R 1 0 0 50)-    liftIO $ actionTitle @?= "Define select :: Int -> Bool"-    executeCodeAction action-    contentAfterAction <- documentContents docB-    liftIO $ contentAfterAction @?= T.unlines expected-  ]---deleteUnusedDefinitionTests :: TestTree-deleteUnusedDefinitionTests = testGroup "delete unused definition action"-  [ testSession "delete unused top level binding" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-               , "module A (some) where"-               , ""-               , "f :: Int -> Int"-               , "f 1 = let a = 1"-               , "      in a"-               , "f 2 = 2"-               , ""-               , "some = ()"-               ])-    (4, 0)-    "Delete ‘f’"-    (T.unlines [-        "{-# OPTIONS_GHC -Wunused-top-binds #-}"-        , "module A (some) where"-        , ""-        , "some = ()"-        ])--  , testSession "delete unused top level binding defined in infix form" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-               , "module A (some) where"-               , ""-               , "myPlus :: Int -> Int -> Int"-               , "a `myPlus` b = a + b"-               , ""-               , "some = ()"-               ])-    (4, 2)-    "Delete ‘myPlus’"-    (T.unlines [-        "{-# OPTIONS_GHC -Wunused-top-binds #-}"-        , "module A (some) where"-        , ""-        , "some = ()"-      ])-  , testSession "delete unused binding in where clause" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"-               , "module A (h, g) where"-               , ""-               , "h :: Int"-               , "h = 3"-               , ""-               , "g :: Int"-               , "g = 6"-               , "  where"-               , "    h :: Int"-               , "    h = 4"-               , ""-               ])-    (10, 4)-    "Delete ‘h’"-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"-               , "module A (h, g) where"-               , ""-               , "h :: Int"-               , "h = 3"-               , ""-               , "g :: Int"-               , "g = 6"-               , "  where"-               , ""-               ])-  , testSession "delete unused binding with multi-oneline signatures front" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"-               , "module A (b, c) where"-               , ""-               , "a, b, c :: Int"-               , "a = 3"-               , "b = 4"-               , "c = 5"-               ])-    (4, 0)-    "Delete ‘a’"-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"-               , "module A (b, c) where"-               , ""-               , "b, c :: Int"-               , "b = 4"-               , "c = 5"-               ])-  , testSession "delete unused binding with multi-oneline signatures mid" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"-               , "module A (a, c) where"-               , ""-               , "a, b, c :: Int"-               , "a = 3"-               , "b = 4"-               , "c = 5"-               ])-    (5, 0)-    "Delete ‘b’"-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"-               , "module A (a, c) where"-               , ""-               , "a, c :: Int"-               , "a = 3"-               , "c = 5"-               ])-  , testSession "delete unused binding with multi-oneline signatures end" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"-               , "module A (a, b) where"-               , ""-               , "a, b, c :: Int"-               , "a = 3"-               , "b = 4"-               , "c = 5"-               ])-    (6, 0)-    "Delete ‘c’"-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"-               , "module A (a, b) where"-               , ""-               , "a, b :: Int"-               , "a = 3"-               , "b = 4"-               ])-  ]-  where-    testFor source pos expectedTitle expectedResult = do-      docId <- createDoc "A.hs" "haskell" source-      expectDiagnostics [ ("A.hs", [(DsWarning, pos, "not used")]) ]--      (action, title) <- extractCodeAction docId "Delete" pos--      liftIO $ title @?= expectedTitle-      executeCodeAction action-      contentAfterAction <- documentContents docId-      liftIO $ contentAfterAction @?= expectedResult--    extractCodeAction docId actionPrefix (l, c) = do-      [action@CodeAction { _title = actionTitle }]  <- findCodeActionsByPrefix docId (R l c l c) [actionPrefix]-      return (action, actionTitle)--addTypeAnnotationsToLiteralsTest :: TestTree-addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals to satisfy constraints"-  [-    testSession "add default type to satisfy one constraint" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "module A (f) where"-               , ""-               , "f = 1"-               ])-    [ (DsWarning, (3, 4), "Defaulting the following constraint") ]-    "Add type annotation ‘Integer’ to ‘1’"-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "module A (f) where"-               , ""-               , "f = (1 :: Integer)"-               ])--  , testSession "add default type to satisfy one constraint in nested expressions" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "module A where"-               , ""-               , "f ="-               , "    let x = 3"-               , "    in x"-               ])-    [ (DsWarning, (4, 12), "Defaulting the following constraint") ]-    "Add type annotation ‘Integer’ to ‘3’"-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "module A where"-               , ""-               , "f ="-               , "    let x = (3 :: Integer)"-               , "    in x"-               ])-  , testSession "add default type to satisfy one constraint in more nested expressions" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "module A where"-               , ""-               , "f ="-               , "    let x = let y = 5 in y"-               , "    in x"-               ])-    [ (DsWarning, (4, 20), "Defaulting the following constraint") ]-    "Add type annotation ‘Integer’ to ‘5’"-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "module A where"-               , ""-               , "f ="-               , "    let x = let y = (5 :: Integer) in y"-               , "    in x"-               ])-  , testSession "add default type to satisfy one constraint with duplicate literals" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "{-# LANGUAGE OverloadedStrings #-}"-               , "module A (f) where"-               , ""-               , "import Debug.Trace"-               , ""-               , "f = seq \"debug\" traceShow \"debug\""-               ])-    [ (DsWarning, (6, 8), "Defaulting the following constraint")-    , (DsWarning, (6, 16), "Defaulting the following constraint")-    ]-    ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’")-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "{-# LANGUAGE OverloadedStrings #-}"-               , "module A (f) where"-               , ""-               , "import Debug.Trace"-               , ""-               , "f = seq (\"debug\" :: " <> listOfChar <> ") traceShow \"debug\""-               ])-  , knownBrokenForGhcVersions [GHC92] "GHC 9.2 only has 'traceShow' in error span" $-    testSession "add default type to satisfy two constraints" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "{-# LANGUAGE OverloadedStrings #-}"-               , "module A (f) where"-               , ""-               , "import Debug.Trace"-               , ""-               , "f a = traceShow \"debug\" a"-               ])-    [ (DsWarning, (6, 6), "Defaulting the following constraint") ]-    ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’")-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "{-# LANGUAGE OverloadedStrings #-}"-               , "module A (f) where"-               , ""-               , "import Debug.Trace"-               , ""-               , "f a = traceShow (\"debug\" :: " <> listOfChar <> ") a"-               ])-  , knownBrokenForGhcVersions [GHC92] "GHC 9.2 only has 'traceShow' in error span" $-    testSession "add default type to satisfy two constraints with duplicate literals" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "{-# LANGUAGE OverloadedStrings #-}"-               , "module A (f) where"-               , ""-               , "import Debug.Trace"-               , ""-               , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))"-               ])-    [ (DsWarning, (6, 54), "Defaulting the following constraint") ]-    ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’")-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "{-# LANGUAGE OverloadedStrings #-}"-               , "module A (f) where"-               , ""-               , "import Debug.Trace"-               , ""-               , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: " <> listOfChar <> ")))"-               ])-  ]-  where-    testFor source diag expectedTitle expectedResult = do-      docId <- createDoc "A.hs" "haskell" source-      expectDiagnostics [ ("A.hs", diag) ]--      let cursors = map snd3 diag-      (action, title) <- extractCodeAction docId "Add type annotation" (minimum cursors) (maximum cursors)--      liftIO $ title @?= expectedTitle-      executeCodeAction action-      contentAfterAction <- documentContents docId-      liftIO $ contentAfterAction @?= expectedResult--    extractCodeAction docId actionPrefix (l,c) (l', c')= do-      [action@CodeAction { _title = actionTitle }]  <- findCodeActionsByPrefix docId (R l c l' c') [actionPrefix]-      return (action, actionTitle)---fixConstructorImportTests :: TestTree-fixConstructorImportTests = testGroup "fix import actions"-  [ testSession "fix constructor import" $ template-      (T.unlines-            [ "module ModuleA where"-            , "data A = Constructor"-            ])-      (T.unlines-            [ "module ModuleB where"-            , "import ModuleA(Constructor)"-            ])-      (Range (Position 1 10) (Position 1 11))-      "Fix import of A(Constructor)"-      (T.unlines-            [ "module ModuleB where"-            , "import ModuleA(A(Constructor))"-            ])-  ]-  where-    template contentA contentB range expectedAction expectedContentB = do-      _docA <- createDoc "ModuleA.hs" "haskell" contentA-      docB  <- createDoc "ModuleB.hs" "haskell" contentB-      _diags <- waitForDiagnostics-      InR action@CodeAction { _title = actionTitle } : _-                  <- sortOn (\(InR CodeAction{_title=x}) -> x) <$>-                     getCodeActions docB range-      liftIO $ expectedAction @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents docB-      liftIO $ expectedContentB @=? contentAfterAction--importRenameActionTests :: TestTree-importRenameActionTests = testGroup "import rename actions"-  [ testSession "Data.Mape -> Data.Map"   $ check "Map"-  , testSession "Data.Mape -> Data.Maybe" $ check "Maybe" ] where-  check modname = do-      let content = T.unlines-            [ "module Testing where"-            , "import Data.Mape"-            ]-      doc <- createDoc "Testing.hs" "haskell" content-      _ <- waitForDiagnostics-      actionsOrCommands <- getCodeActions doc (Range (Position 1 8) (Position 1 16))-      let [changeToMap] = [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]-      executeCodeAction changeToMap-      contentAfterAction <- documentContents doc-      let expectedContentAfterAction = T.unlines-            [ "module Testing where"-            , "import Data." <> modname-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction--fillTypedHoleTests :: TestTree-fillTypedHoleTests = let--  sourceCode :: T.Text -> T.Text -> T.Text -> T.Text-  sourceCode a b c = T.unlines-    [ "module Testing where"-      , ""-      , "globalConvert :: Int -> String"-      , "globalConvert = undefined"-      , ""-      , "globalInt :: Int"-      , "globalInt = 3"-      , ""-      , "bar :: Int -> Int -> String"-      , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ")  where"-      , "  localConvert = (flip replicate) 'x'"-      , ""-      , "foo :: () -> Int -> String"-      , "foo = undefined"--    ]--  check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree-  check actionTitle-        oldA oldB oldC-        newA newB newC = testSession (T.unpack actionTitle) $ do-    let originalCode = sourceCode oldA oldB oldC-    let expectedCode = sourceCode newA newB newC-    doc <- createDoc "Testing.hs" "haskell" originalCode-    _ <- waitForDiagnostics-    actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))-    chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands-    executeCodeAction chosenAction-    modifiedCode <- documentContents doc-    liftIO $ expectedCode @=? modifiedCode-  in-  testGroup "fill typed holes"-  [ check "replace _ with show"-          "_"    "n" "n"-          "show" "n" "n"--  , check "replace _ with globalConvert"-          "_"             "n" "n"-          "globalConvert" "n" "n"--  , check "replace _convertme with localConvert"-          "_convertme"   "n" "n"-          "localConvert" "n" "n"--  , check "replace _b with globalInt"-          "_a" "_b"        "_c"-          "_a" "globalInt" "_c"--  , check "replace _c with globalInt"-          "_a" "_b"        "_c"-          "_a" "_b" "globalInt"--  , check "replace _c with parameterInt"-          "_a" "_b" "_c"-          "_a" "_b"  "parameterInt"-  , check "replace _ with foo _"-          "_" "n" "n"-          "(foo _)" "n" "n"-  , testSession "replace _toException with E.toException" $ do-      let mkDoc x = T.unlines-            [ "module Testing where"-            , "import qualified Control.Exception as E"-            , "ioToSome :: E.IOException -> E.SomeException"-            , "ioToSome = " <> x ]-      doc <- createDoc "Test.hs" "haskell" $ mkDoc "_toException"-      _ <- waitForDiagnostics-      actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBound))-      chosen <- liftIO $ pickActionWithTitle "replace _toException with E.toException" actions-      executeCodeAction chosen-      modifiedCode <- documentContents doc-      liftIO $ mkDoc "E.toException" @=? modifiedCode-  , testSession "filling infix type hole uses prefix notation" $ do-      let mkDoc x = T.unlines-              [ "module Testing where"-              , "data A = A"-              , "foo :: A -> A -> A"-              , "foo A A = A"-              , "test :: A -> A -> A"-              , "test a1 a2 = a1 " <> x <> " a2"-              ]-      doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`"-      _ <- waitForDiagnostics-      actions <- getCodeActions doc (Range (Position 5 16) (Position 5 19))-      chosen <- liftIO $ pickActionWithTitle "replace _ with foo" actions-      executeCodeAction chosen-      modifiedCode <- documentContents doc-      liftIO $ mkDoc "`foo`" @=? modifiedCode-  , testSession "postfix hole uses postfix notation of infix operator" $ do-      let mkDoc x = T.unlines-              [ "module Testing where"-              , "test :: Int -> Int -> Int"-              , "test a1 a2 = " <> x <> " a1 a2"-              ]-      doc <- createDoc "Test.hs" "haskell" $ mkDoc "_"-      _ <- waitForDiagnostics-      actions <- getCodeActions doc (Range (Position 2 13) (Position 2 14))-      chosen <- liftIO $ pickActionWithTitle "replace _ with (+)" actions-      executeCodeAction chosen-      modifiedCode <- documentContents doc-      liftIO $ mkDoc "(+)" @=? modifiedCode-  , testSession "filling infix type hole uses infix operator" $ do-      let mkDoc x = T.unlines-              [ "module Testing where"-              , "test :: Int -> Int -> Int"-              , "test a1 a2 = a1 " <> x <> " a2"-              ]-      doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`"-      _ <- waitForDiagnostics-      actions <- getCodeActions doc (Range (Position 2 16) (Position 2 19))-      chosen <- liftIO $ pickActionWithTitle "replace _ with (+)" actions-      executeCodeAction chosen-      modifiedCode <- documentContents doc-      liftIO $ mkDoc "+" @=? modifiedCode-  ]--addInstanceConstraintTests :: TestTree-addInstanceConstraintTests = let-  missingConstraintSourceCode :: Maybe T.Text -> T.Text-  missingConstraintSourceCode mConstraint =-    let constraint = maybe "" (<> " => ") mConstraint-     in T.unlines-    [ "module Testing where"-    , ""-    , "data Wrap a = Wrap a"-    , ""-    , "instance " <> constraint <> "Eq (Wrap a) where"-    , "  (Wrap x) == (Wrap y) = x == y"-    ]--  incompleteConstraintSourceCode :: Maybe T.Text -> T.Text-  incompleteConstraintSourceCode mConstraint =-    let constraint = maybe "Eq a" (\c -> "(Eq a, " <> c <> ")")  mConstraint-     in T.unlines-    [ "module Testing where"-    , ""-    , "data Pair a b = Pair a b"-    , ""-    , "instance " <> constraint <> " => Eq (Pair a b) where"-    , "  (Pair x y) == (Pair x' y') = x == x' && y == y'"-    ]--  incompleteConstraintSourceCode2 :: Maybe T.Text -> T.Text-  incompleteConstraintSourceCode2 mConstraint =-    let constraint = maybe "(Eq a, Eq b)" (\c -> "(Eq a, Eq b, " <> c <> ")")  mConstraint-     in T.unlines-    [ "module Testing where"-    , ""-    , "data Three a b c = Three a b c"-    , ""-    , "instance " <> constraint <> " => Eq (Three a b c) where"-    , "  (Three x y z) == (Three x' y' z') = x == x' && y == y' && z == z'"-    ]--  check :: T.Text -> T.Text -> T.Text -> TestTree-  check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do-    doc <- createDoc "Testing.hs" "haskell" originalCode-    _ <- waitForDiagnostics-    actionsOrCommands <- getAllCodeActions doc-    chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands-    executeCodeAction chosenAction-    modifiedCode <- documentContents doc-    liftIO $ expectedCode @=? modifiedCode--  in testGroup "add instance constraint"-  [ check-    "Add `Eq a` to the context of the instance declaration"-    (missingConstraintSourceCode Nothing)-    (missingConstraintSourceCode $ Just "Eq a")-  , check-    "Add `Eq b` to the context of the instance declaration"-    (incompleteConstraintSourceCode Nothing)-    (incompleteConstraintSourceCode $ Just "Eq b")-  , check-    "Add `Eq c` to the context of the instance declaration"-    (incompleteConstraintSourceCode2 Nothing)-    (incompleteConstraintSourceCode2 $ Just "Eq c")-  ]--addFunctionConstraintTests :: TestTree-addFunctionConstraintTests = let-  missingConstraintSourceCode :: T.Text -> T.Text-  missingConstraintSourceCode constraint =-    T.unlines-    [ "module Testing where"-    , ""-    , "eq :: " <> constraint <> "a -> a -> Bool"-    , "eq x y = x == y"-    ]--  missingConstraintWithForAllSourceCode :: T.Text -> T.Text-  missingConstraintWithForAllSourceCode constraint =-    T.unlines-    [ "{-# LANGUAGE ExplicitForAll #-}"-    , "module Testing where"-    , ""-    , "eq :: forall a. " <> constraint <> "a -> a -> Bool"-    , "eq x y = x == y"-    ]--  incompleteConstraintWithForAllSourceCode :: T.Text -> T.Text-  incompleteConstraintWithForAllSourceCode constraint =-    T.unlines-    [ "{-# LANGUAGE ExplicitForAll #-}"-    , "module Testing where"-    , ""-    , "data Pair a b = Pair a b"-    , ""-    , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool"-    , "eq (Pair x y) (Pair x' y') = x == x' && y == y'"-    ]--  incompleteConstraintSourceCode :: T.Text -> T.Text-  incompleteConstraintSourceCode constraint =-    T.unlines-    [ "module Testing where"-    , ""-    , "data Pair a b = Pair a b"-    , ""-    , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool"-    , "eq (Pair x y) (Pair x' y') = x == x' && y == y'"-    ]--  incompleteConstraintSourceCode2 :: T.Text -> T.Text-  incompleteConstraintSourceCode2 constraint =-    T.unlines-    [ "module Testing where"-    , ""-    , "data Three a b c = Three a b c"-    , ""-    , "eq :: " <> constraint <> " => Three a b c -> Three a b c -> Bool"-    , "eq (Three x y z) (Three x' y' z') = x == x' && y == y' && z == z'"-    ]--  incompleteConstraintSourceCodeWithExtraCharsInContext :: T.Text -> T.Text-  incompleteConstraintSourceCodeWithExtraCharsInContext constraint =-    T.unlines-    [ "module Testing where"-    , ""-    , "data Pair a b = Pair a b"-    , ""-    , "eq :: ( " <> constraint <> " ) => Pair a b -> Pair a b -> Bool"-    , "eq (Pair x y) (Pair x' y') = x == x' && y == y'"-    ]--  incompleteConstraintSourceCodeWithNewlinesInTypeSignature :: T.Text -> T.Text-  incompleteConstraintSourceCodeWithNewlinesInTypeSignature constraint =-    T.unlines-    [ "module Testing where"-    , "data Pair a b = Pair a b"-    , "eq "-    , "    :: (" <> constraint <> ")"-    , "    => Pair a b -> Pair a b -> Bool"-    , "eq (Pair x y) (Pair x' y') = x == x' && y == y'"-    ]--  missingMonadConstraint constraint = T.unlines-    [ "module Testing where"-    , "f :: " <> constraint <> "m ()"-    , "f = do "-    , "  return ()"-    ]--  in testGroup "add function constraint"-  [ checkCodeAction-    "no preexisting constraint"-    "Add `Eq a` to the context of the type signature for `eq`"-    (missingConstraintSourceCode "")-    (missingConstraintSourceCode "Eq a => ")-  , checkCodeAction-    "no preexisting constraint, with forall"-    "Add `Eq a` to the context of the type signature for `eq`"-    (missingConstraintWithForAllSourceCode "")-    (missingConstraintWithForAllSourceCode "Eq a => ")-  , checkCodeAction-    "preexisting constraint, no parenthesis"-    "Add `Eq b` to the context of the type signature for `eq`"-    (incompleteConstraintSourceCode "Eq a")-    (incompleteConstraintSourceCode "(Eq a, Eq b)")-  , checkCodeAction-    "preexisting constraints in parenthesis"-    "Add `Eq c` to the context of the type signature for `eq`"-    (incompleteConstraintSourceCode2 "(Eq a, Eq b)")-    (incompleteConstraintSourceCode2 "(Eq a, Eq b, Eq c)")-  , checkCodeAction-    "preexisting constraints with forall"-    "Add `Eq b` to the context of the type signature for `eq`"-    (incompleteConstraintWithForAllSourceCode "Eq a")-    (incompleteConstraintWithForAllSourceCode "(Eq a, Eq b)")-  , checkCodeAction-    "preexisting constraint, with extra spaces in context"-    "Add `Eq b` to the context of the type signature for `eq`"-    (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a")-    (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a, Eq b")-  , checkCodeAction-    "preexisting constraint, with newlines in type signature"-    "Add `Eq b` to the context of the type signature for `eq`"-    (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a")-    (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a, Eq b")-  , checkCodeAction-    "missing Monad constraint"-    "Add `Monad m` to the context of the type signature for `f`"-    (missingMonadConstraint "")-    (missingMonadConstraint "Monad m => ")-  ]--checkCodeAction :: String -> T.Text -> T.Text -> T.Text -> TestTree-checkCodeAction testName actionTitle originalCode expectedCode = testSession testName $ do-  doc <- createDoc "Testing.hs" "haskell" originalCode-  _ <- waitForDiagnostics-  actionsOrCommands <- getAllCodeActions doc-  chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands-  executeCodeAction chosenAction-  modifiedCode <- documentContents doc-  liftIO $ expectedCode @=? modifiedCode--addImplicitParamsConstraintTests :: TestTree-addImplicitParamsConstraintTests =-  testGroup-    "add missing implicit params constraints"-    [ testGroup-        "introduced"-        [ let ex ctxtA = exampleCode "?a" ctxtA ""-           in checkCodeAction "at top level" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()"),-          let ex ctxA = exampleCode "x where x = ?a" ctxA ""-           in checkCodeAction "in nested def" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()")-        ],-      testGroup-        "inherited"-        [ let ex = exampleCode "()" "?a::()"-           in checkCodeAction-                "with preexisting context"-                "Add `?a::()` to the context of the type signature for `fCaller`"-                (ex "Eq ()")-                (ex "Eq (), ?a::()"),-          let ex = exampleCode "()" "?a::()"-           in checkCodeAction "without preexisting context" "Add ?a::() to the context of fCaller" (ex "") (ex "?a::()")-        ]-    ]-  where-    mkContext ""       = ""-    mkContext contents = "(" <> contents <> ") => "--    exampleCode bodyBase contextBase contextCaller =-      T.unlines-        [ "{-# LANGUAGE FlexibleContexts, ImplicitParams #-}",-          "module Testing where",-          "fBase :: " <> mkContext contextBase <> "()",-          "fBase = " <> bodyBase,-          "fCaller :: " <> mkContext contextCaller <> "()",-          "fCaller = fBase"-        ]--removeRedundantConstraintsTests :: TestTree-removeRedundantConstraintsTests = let-  header =-    [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"-    , "module Testing where"-    , ""-    ]--  headerExt :: [T.Text] -> [T.Text]-  headerExt exts =-    redunt : extTxt ++ ["module Testing where"]-    where-      redunt = "{-# OPTIONS_GHC -Wredundant-constraints #-}"-      extTxt = map (\ext -> "{-# LANGUAGE " <> ext <> " #-}") exts--  redundantConstraintsCode :: Maybe T.Text -> T.Text-  redundantConstraintsCode mConstraint =-    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint-      in T.unlines $ header <>-        [ "foo :: " <> constraint <> "a -> a"-        , "foo = id"-        ]--  redundantMixedConstraintsCode :: Maybe T.Text -> T.Text-  redundantMixedConstraintsCode mConstraint =-    let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint-      in T.unlines $ header <>-        [ "foo :: " <> constraint <> " => a -> Bool"-        , "foo x = x == 1"-        ]--  typeSignatureSpaces :: Maybe T.Text -> T.Text-  typeSignatureSpaces mConstraint =-    let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint-      in T.unlines $ header <>-        [ "foo ::  " <> constraint <> " => a -> Bool"-        , "foo x = x == 1"-        ]--  redundantConstraintsForall :: Maybe T.Text -> T.Text-  redundantConstraintsForall mConstraint =-    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint-      in T.unlines $ headerExt ["RankNTypes"] <>-        [ "foo :: forall a. " <> constraint <> "a -> a"-        , "foo = id"-        ]--  typeSignatureDo :: Maybe T.Text -> T.Text-  typeSignatureDo mConstraint =-    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint-      in T.unlines $ header <>-        [ "f :: Int -> IO ()"-        , "f n = do"-        , "  let foo :: " <> constraint <> "a -> IO ()"-        , "      foo _ = return ()"-        , "  r n"-        ]--  typeSignatureNested :: Maybe T.Text -> T.Text-  typeSignatureNested mConstraint =-    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint-      in T.unlines $ header <>-        [ "f :: Int -> ()"-        , "f = g"-        , "  where"-        , "    g :: " <> constraint <> "a -> ()"-        , "    g _ = ()"-        ]--  typeSignatureNested' :: Maybe T.Text -> T.Text-  typeSignatureNested' mConstraint =-    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint-      in T.unlines $ header <>-        [ "f :: Int -> ()"-        , "f ="-        , "  let"-        , "    g :: Int -> ()"-        , "    g = h"-        , "      where"-        , "        h :: " <> constraint <> "a -> ()"-        , "        h _ = ()"-        , "  in g"-        ]--  typeSignatureNested'' :: Maybe T.Text -> T.Text-  typeSignatureNested'' mConstraint =-    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint-      in T.unlines $ header <>-        [ "f :: Int -> ()"-        , "f = g"-        , "  where"-        , "    g :: Int -> ()"-        , "    g = "-        , "      let"-        , "        h :: " <> constraint <> "a -> ()"-        , "        h _ = ()"-        , "      in h"-        ]--  typeSignatureLined1 = T.unlines $ header <>-    [ "foo :: Eq a =>"-    , "  a -> Bool"-    , "foo _ = True"-    ]--  typeSignatureLined2 = T.unlines $ header <>-    [ "foo :: (Eq a, Show a)"-    , "  => a -> Bool"-    , "foo _ = True"-    ]--  typeSignatureOneLine = T.unlines $ header <>-    [ "foo :: a -> Bool"-    , "foo _ = True"-    ]--  typeSignatureLined3 = T.unlines $ header <>-    [ "foo :: ( Eq a"-    , "       , Show a"-    , "       )"-    , "    => a -> Bool"-    , "foo x = x == x"-    ]--  typeSignatureLined3' = T.unlines $ header <>-    [ "foo :: ( Eq a"-    , "       )"-    , "    => a -> Bool"-    , "foo x = x == x"-    ]---  check :: T.Text -> T.Text -> T.Text -> TestTree-  check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do-    doc <- createDoc "Testing.hs" "haskell" originalCode-    _ <- waitForDiagnostics-    actionsOrCommands <- getAllCodeActions doc-    chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands-    executeCodeAction chosenAction-    modifiedCode <- documentContents doc-    liftIO $ expectedCode @=? modifiedCode--  in testGroup "remove redundant function constraints"-  [ check-    "Remove redundant constraint `Eq a` from the context of the type signature for `foo`"-    (redundantConstraintsCode $ Just "Eq a")-    (redundantConstraintsCode Nothing)-  , check-    "Remove redundant constraints `(Eq a, Monoid a)` from the context of the type signature for `foo`"-    (redundantConstraintsCode $ Just "(Eq a, Monoid a)")-    (redundantConstraintsCode Nothing)-  , check-    "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`"-    (redundantMixedConstraintsCode $ Just "Monoid a, Show a")-    (redundantMixedConstraintsCode Nothing)-  , check-    "Remove redundant constraint `Eq a` from the context of the type signature for `g`"-    (typeSignatureNested $ Just "Eq a")-    (typeSignatureNested Nothing)-  , check-    "Remove redundant constraint `Eq a` from the context of the type signature for `h`"-    (typeSignatureNested' $ Just "Eq a")-    (typeSignatureNested' Nothing)-  , check-    "Remove redundant constraint `Eq a` from the context of the type signature for `h`"-    (typeSignatureNested'' $ Just "Eq a")-    (typeSignatureNested'' Nothing)-  , check-    "Remove redundant constraint `Eq a` from the context of the type signature for `foo`"-    (redundantConstraintsForall $ Just "Eq a")-    (redundantConstraintsForall Nothing)-  , check-    "Remove redundant constraint `Eq a` from the context of the type signature for `foo`"-    (typeSignatureDo $ Just "Eq a")-    (typeSignatureDo Nothing)-  , check-    "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`"-    (typeSignatureSpaces $ Just "Monoid a, Show a")-    (typeSignatureSpaces Nothing)-    , check-    "Remove redundant constraint `Eq a` from the context of the type signature for `foo`"-    typeSignatureLined1-    typeSignatureOneLine-    , check-    "Remove redundant constraints `(Eq a, Show a)` from the context of the type signature for `foo`"-    typeSignatureLined2-    typeSignatureOneLine-    , check-    "Remove redundant constraint `Show a` from the context of the type signature for `foo`"-    typeSignatureLined3-    typeSignatureLined3'-  ]--addSigActionTests :: TestTree-addSigActionTests = let-  header = [ "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"-           , "{-# LANGUAGE PatternSynonyms,BangPatterns,GADTs #-}"-           , "module Sigs where"-           , "data T1 a where"-           , "  MkT1 :: (Show b) => a -> b -> T1 a"-           ]-  before def     = T.unlines $ header ++ [def]-  after' def sig = T.unlines $ header ++ [sig, def]--  def >:: sig = testSession (T.unpack $ T.replace "\n" "\\n" def) $ do-    let originalCode = before def-    let expectedCode = after' def sig-    doc <- createDoc "Sigs.hs" "haskell" originalCode-    _ <- waitForDiagnostics-    actionsOrCommands <- getCodeActions doc (Range (Position 5 1) (Position 5 maxBound))-    chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands-    executeCodeAction chosenAction-    modifiedCode <- documentContents doc-    liftIO $ expectedCode @=? modifiedCode-  in-  testGroup "add signature"-    [ "abc = True"              >:: "abc :: Bool"-    , "foo a b = a + b"         >:: "foo :: Num a => a -> a -> a"-    , "bar a b = show $ a + b"  >:: "bar :: (Show a, Num a) => a -> a -> String"-    , "(!!!) a b = a > b"       >:: "(!!!) :: Ord a => a -> a -> Bool"-    , "a >>>> b = a + b"        >:: "(>>>>) :: Num a => a -> a -> a"-    , "a `haha` b = a b"        >:: "haha :: (t1 -> t2) -> t1 -> t2"-    , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a"-    , "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"-    ]--exportUnusedTests :: TestTree-exportUnusedTests = testGroup "export unused actions"-  [ testGroup "don't want suggestion"-    [ testSession "implicit exports" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# OPTIONS_GHC -Wmissing-signatures #-}"-              , "module A where"-              , "foo = id"])-        (R 3 0 3 3)-        "Export ‘foo’"-        Nothing -- codeaction should not be available-    , testSession "not top-level" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# OPTIONS_GHC -Wunused-binds #-}"-              , "module A (foo,bar) where"-              , "foo = ()"-              , "  where bar = ()"-              , "bar = ()"])-        (R 2 0 2 11)-        "Export ‘bar’"-        Nothing-    , ignoreForGHC92 "Diagnostic message has no suggestions" $-      testSession "type is exported but not the constructor of same name" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A (Foo) where"-              , "data Foo = Foo"])-        (R 2 0 2 8)-        "Export ‘Foo’"-        Nothing -- codeaction should not be available-    , testSession "unused data field" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A (Foo(Foo)) where"-              , "data Foo = Foo {foo :: ()}"])-        (R 2 0 2 20)-        "Export ‘foo’"-        Nothing -- codeaction should not be available-    ]-  , testGroup "want suggestion"-    [ testSession "empty exports" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A ("-              , ") where"-              , "foo = id"])-        (R 3 0 3 3)-        "Export ‘foo’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A ("-              , "foo) where"-              , "foo = id"])-    , testSession "single line explicit exports" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A (foo) where"-              , "foo = id"-              , "bar = foo"])-        (R 3 0 3 3)-        "Export ‘bar’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A (foo, bar) where"-              , "foo = id"-              , "bar = foo"])-    , testSession "multi line explicit exports" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A"-              , "  ("-              , "    foo) where"-              , "foo = id"-              , "bar = foo"])-        (R 5 0 5 3)-        "Export ‘bar’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A"-              , "  ("-              , "    foo, bar) where"-              , "foo = id"-              , "bar = foo"])-    , testSession "export list ends in comma" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A"-              , "  (foo,"-              , "  ) where"-              , "foo = id"-              , "bar = foo"])-        (R 5 0 5 3)-        "Export ‘bar’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A"-              , "  (foo,"-              , "  bar) where"-              , "foo = id"-              , "bar = foo"])-    , testSession "unused pattern synonym" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE PatternSynonyms #-}"-              , "module A () where"-              , "pattern Foo a <- (a, _)"])-        (R 3 0 3 10)-        "Export ‘Foo’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE PatternSynonyms #-}"-              , "module A (pattern Foo) where"-              , "pattern Foo a <- (a, _)"])-    , testSession "unused data type" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A () where"-              , "data Foo = Foo"])-        (R 2 0 2 7)-        "Export ‘Foo’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A (Foo(..)) where"-              , "data Foo = Foo"])-    , testSession "unused newtype" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A () where"-              , "newtype Foo = Foo ()"])-        (R 2 0 2 10)-        "Export ‘Foo’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A (Foo(..)) where"-              , "newtype Foo = Foo ()"])-    , testSession "unused type synonym" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A () where"-              , "type Foo = ()"])-        (R 2 0 2 7)-        "Export ‘Foo’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A (Foo) where"-              , "type Foo = ()"])-    , testSession "unused type family" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeFamilies #-}"-              , "module A () where"-              , "type family Foo p"])-        (R 3 0 3 15)-        "Export ‘Foo’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeFamilies #-}"-              , "module A (Foo) where"-              , "type family Foo p"])-    , testSession "unused typeclass" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A () where"-              , "class Foo a"])-        (R 2 0 2 8)-        "Export ‘Foo’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A (Foo(..)) where"-              , "class Foo a"])-    , testSession "infix" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A () where"-              , "a `f` b = ()"])-        (R 2 0 2 11)-        "Export ‘f’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A (f) where"-              , "a `f` b = ()"])-    , testSession "function operator" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A () where"-              , "(<|) = ($)"])-        (R 2 0 2 9)-        "Export ‘<|’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A ((<|)) where"-              , "(<|) = ($)"])-    , testSession "type synonym operator" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A () where"-              , "type (:<) = ()"])-        (R 3 0 3 13)-        "Export ‘:<’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A ((:<)) where"-              , "type (:<) = ()"])-    , testSession "type family operator" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeFamilies #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A () where"-              , "type family (:<)"])-        (R 4 0 4 15)-        "Export ‘:<’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeFamilies #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A (type (:<)) where"-              , "type family (:<)"])-    , testSession "typeclass operator" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A () where"-              , "class (:<) a"])-        (R 3 0 3 11)-        "Export ‘:<’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A (type (:<)(..)) where"-              , "class (:<) a"])-    , testSession "newtype operator" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A () where"-              , "newtype (:<) = Foo ()"])-        (R 3 0 3 20)-        "Export ‘:<’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A (type (:<)(..)) where"-              , "newtype (:<) = Foo ()"])-    , testSession "data type operator" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A () where"-              , "data (:<) = Foo ()"])-        (R 3 0 3 17)-        "Export ‘:<’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A (type (:<)(..)) where"-              , "data (:<) = Foo ()"])-    ]-  ]-  where-    template doc range = exportTemplate (Just range) doc--exportTemplate :: Maybe Range -> T.Text -> T.Text -> Maybe T.Text -> Session ()-exportTemplate mRange initialContent expectedAction expectedContents = do-  doc <- createDoc "A.hs" "haskell" initialContent-  _ <- waitForDiagnostics-  actions <- case mRange of-    Nothing    -> getAllCodeActions doc-    Just range -> getCodeActions doc range-  case expectedContents of-    Just content -> do-      action <- liftIO $ pickActionWithTitle expectedAction actions-      executeCodeAction action-      contentAfterAction <- documentContents doc-      liftIO $ content @=? contentAfterAction-    Nothing ->-      liftIO $ [_title | InR CodeAction{_title} <- actions, _title == expectedAction ] @?= []--removeExportTests :: TestTree-removeExportTests = testGroup "remove export actions"-    [ testSession "single export" $ template-        (T.unlines-              [ "module A (  a   ) where"-              , "b :: ()"-              , "b = ()"])-        "Remove ‘a’ from export"-        (Just $ T.unlines-              [ "module A (     ) where"-              , "b :: ()"-              , "b = ()"])-    , testSession "ending comma" $ template-        (T.unlines-              [ "module A (  a,   ) where"-              , "b :: ()"-              , "b = ()"])-        "Remove ‘a’ from export"-        (Just $ T.unlines-              [ "module A (  ) where"-              , "b :: ()"-              , "b = ()"])-    , testSession "multiple exports" $ template-        (T.unlines-              [ "module A (a  ,   c,    b ) where"-              , "a, c :: ()"-              , "a = ()"-              , "c = ()"])-        "Remove ‘b’ from export"-        (Just $ T.unlines-              [ "module A (a  ,   c ) where"-              , "a, c :: ()"-              , "a = ()"-              , "c = ()"])-    , testSession "not in scope constructor" $ template-        (T.unlines-              [ "module A (A (X,Y,Z,(:<)), ab) where"-              , "data A = X Int | Y | (:<) Int"-              , "ab :: ()"-              , "ab = ()"-              ])-        "Remove ‘Z’ from export"-        (Just $ T.unlines-              [ "module A (A (X,Y,(:<)), ab) where"-              , "data A = X Int | Y | (:<) Int"-              , "ab :: ()"-              , "ab = ()"])-    , testSession "multiline export" $ template-        (T.unlines-              [ "module A (a"-              , " ,  b"-              , " , (:*:)"-              , " , ) where"-              , "a,b :: ()"-              , "a = ()"-              , "b = ()"])-        "Remove ‘:*:’ from export"-        (Just $ T.unlines-              [ "module A (a"-              , " ,  b"-              , " "-              , " , ) where"-              , "a,b :: ()"-              , "a = ()"-              , "b = ()"])-    , testSession "qualified re-export" $ template-        (T.unlines-              [ "module A (M.x,a) where"-              , "import qualified Data.List as M"-              , "a :: ()"-              , "a = ()"])-        "Remove ‘M.x’ from export"-        (Just $ T.unlines-              [ "module A (a) where"-              , "import qualified Data.List as M"-              , "a :: ()"-              , "a = ()"])-    , testSession "qualified re-export ending in '.'" $ template-        (T.unlines-              [ "module A ((M.@.),a) where"-              , "import qualified Data.List as M"-              , "a :: ()"-              , "a = ()"])-        "Remove ‘M.@.’ from export"-        (Just $ T.unlines-              [ "module A (a) where"-              , "import qualified Data.List as M"-              , "a :: ()"-              , "a = ()"])-    , testSession "export module" $ template-        (T.unlines-              [ "module A (module B) where"-              , "a :: ()"-              , "a = ()"])-        "Remove ‘module B’ from export"-        (Just $ T.unlines-              [ "module A () where"-              , "a :: ()"-              , "a = ()"])-    , testSession "dodgy export" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wall #-}"-              , "module A (A (..)) where"-              , "data X = X"-              , "type A = X"])-        "Remove ‘A(..)’ from export"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wall #-}"-              , "module A () where"-              , "data X = X"-              , "type A = X"])-    , testSession "dodgy export" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wall #-}"-              , "module A (A (..)) where"-              , "data X = X"-              , "type A = X"])-        "Remove ‘A(..)’ from export"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wall #-}"-              , "module A () where"-              , "data X = X"-              , "type A = X"])-    , testSession "duplicate module export" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wall #-}"-              , "module A (module L,module L) where"-              , "import Data.List as L"-              , "a :: ()"-              , "a = ()"])-        "Remove ‘Module L’ from export"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wall #-}"-              , "module A (module L) where"-              , "import Data.List as L"-              , "a :: ()"-              , "a = ()"])-    , testSession "remove all exports single" $ template-        (T.unlines-              [ "module A (x) where"-              , "a :: ()"-              , "a = ()"])-        "Remove all redundant exports"-        (Just $ T.unlines-              [ "module A () where"-              , "a :: ()"-              , "a = ()"])-    , testSession "remove all exports two" $ template-        (T.unlines-              [ "module A (x,y) where"-              , "a :: ()"-              , "a = ()"])-        "Remove all redundant exports"-        (Just $ T.unlines-              [ "module A () where"-              , "a :: ()"-              , "a = ()"])-    , testSession "remove all exports three" $ template-        (T.unlines-              [ "module A (a,x,y) where"-              , "a :: ()"-              , "a = ()"])-        "Remove all redundant exports"-        (Just $ T.unlines-              [ "module A (a) where"-              , "a :: ()"-              , "a = ()"])-    , testSession "remove all exports composite" $ template-        (T.unlines-              [ "module A (x,y,b, module Ls, a, A(X,getW, Y, Z,(:-),getV), (-+), B(B)) where"-              , "data A = X {getV :: Int} | Y {getV :: Int}"-              , "data B = B"-              , "a,b :: ()"-              , "a = ()"-              , "b = ()"])-        "Remove all redundant exports"-        (Just $ T.unlines-              [ "module A (b, a, A(X, Y,getV), B(B)) where"-              , "data A = X {getV :: Int} | Y {getV :: Int}"-              , "data B = B"-              , "a,b :: ()"-              , "a = ()"-              , "b = ()"])-    ]-  where-    template = exportTemplate Nothing--addSigLensesTests :: TestTree-addSigLensesTests =-  let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"-      moduleH exported =-        T.unlines-          [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators,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 ["haskell" A..= A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]]-      sigSession testName enableGHCWarnings mode exported def others = testSession testName $ do-        let originalCode = before enableGHCWarnings exported def others-        let expectedCode = after' enableGHCWarnings exported def others-        sendNotification SWorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode-        doc <- createDoc "Sigs.hs" "haskell" originalCode-        waitForProgressDone-        codeLenses <- getCodeLenses doc-        if not $ null $ snd def-          then do-            liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses-            executeCommand $ fromJust $ head codeLenses ^. L.command-            modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc)-            liftIO $ expectedCode @=? modifiedCode-          else liftIO $ null codeLenses @? "Expected no code lens, but got: " <> show codeLenses-      cases =-        [ ("abc = True", "abc :: Bool")-        , ("foo a b = a + b", "foo :: Num a => a -> a -> a")-        , ("bar a b = show $ a + b", "bar :: (Show a, Num a) => a -> a -> String")-        , ("(!!!) a b = a > b", "(!!!) :: Ord a => a -> a -> Bool")-        , ("a >>>> b = a + b", "(>>>>) :: Num a => a -> a -> a")-        , ("a `haha` b = a b", "haha :: (t1 -> t2) -> t1 -> t2")-        , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a")-        , ("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", "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")-        ]-   in testGroup-        "add signature"-        [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False "always" "" (def, Just sig) [] | (def, sig) <- cases]-        , sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases)-        , testGroup-            "diagnostics mode works"-            [ sigSession "with GHC warnings" True "diagnostics" "" (second Just $ head cases) []-            , sigSession "without GHC warnings" False "diagnostics" "" (second (const Nothing) $ head cases) []-            ]-        ]--linkToLocation :: [LocationLink] -> [Location]-linkToLocation = map (\LocationLink{_targetUri,_targetRange} -> Location _targetUri _targetRange)--checkDefs :: [Location] |? [LocationLink] -> Session [Expect] -> Session ()-checkDefs (either id linkToLocation . toEither -> defs) mkExpectations = traverse_ check =<< mkExpectations where-  check (ExpectRange expectedRange) = do-    assertNDefinitionsFound 1 defs-    assertRangeCorrect (head defs) expectedRange-  check (ExpectLocation expectedLocation) = do-    assertNDefinitionsFound 1 defs-    liftIO $ do-      canonActualLoc <- canonicalizeLocation (head defs)-      canonExpectedLoc <- canonicalizeLocation expectedLocation-      canonActualLoc @?= canonExpectedLoc-  check ExpectNoDefinitions = do-    assertNDefinitionsFound 0 defs-  check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"-  check _ = pure () -- all other expectations not relevant to getDefinition--  assertNDefinitionsFound :: Int -> [a] -> Session ()-  assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)--  assertRangeCorrect Location{_range = foundRange} expectedRange =-    liftIO $ expectedRange @=? foundRange--canonicalizeLocation :: Location -> IO Location-canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range--findDefinitionAndHoverTests :: TestTree-findDefinitionAndHoverTests = let--  tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> Session [Expect] -> String -> TestTree-  tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do--    -- Dirty the cache to check that definitions work even in the presence of iface files-    liftIO $ runInDir dir $ do-      let fooPath = dir </> "Foo.hs"-      fooSource <- liftIO $ readFileUtf8 fooPath-      fooDoc <- createDoc fooPath "haskell" fooSource-      _ <- getHover fooDoc $ Position 4 3-      closeDoc fooDoc--    doc <- openTestDataDoc (dir </> sourceFilePath)-    waitForProgressDone-    found <- get doc pos-    check found targetRange----  checkHover :: Maybe Hover -> Session [Expect] -> Session ()-  checkHover hover expectations = traverse_ check =<< expectations where--    check expected =-      case hover of-        Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"-        Just Hover{_contents = (HoverContents MarkupContent{_value = standardizeQuotes -> msg})-                  ,_range    = rangeInHover } ->-          case expected of-            ExpectRange  expectedRange -> checkHoverRange expectedRange rangeInHover msg-            ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg-            ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets-            ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover-            _ -> pure () -- all other expectations not relevant to hover-        _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover--  extractLineColFromHoverMsg :: T.Text -> [T.Text]-  extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":")--  checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()-  checkHoverRange expectedRange rangeInHover msg =-    let-      lineCol = extractLineColFromHoverMsg msg-      -- looks like hovers use 1-based numbering while definitions use 0-based-      -- turns out that they are stored 1-based in RealSrcLoc by GHC itself.-      adjust Position{_line = l, _character = c} =-        Position{_line = l + 1, _character = c + 1}-    in-    case map (read . T.unpack) lineCol of-      [l,c] -> liftIO $ adjust (_start expectedRange) @=? Position l c-      _     -> liftIO $ assertFailure $-        "expected: " <> show ("[...]" <> sourceFileName <> ":<LINE>:<COL>**[...]", Just expectedRange) <>-        "\n but got: " <> show (msg, rangeInHover)--  assertFoundIn :: T.Text -> T.Text -> Assertion-  assertFoundIn part whole = assertBool-    (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)-    (part `T.isInfixOf` whole)--  sourceFilePath = T.unpack sourceFileName-  sourceFileName = "GotoHover.hs"--  mkFindTests tests = testGroup "get"-    [ testGroup "definition" $ mapMaybe fst tests-    , testGroup "hover"      $ mapMaybe snd tests-    , checkFileCompiles sourceFilePath $-        expectDiagnostics-          [ ( "GotoHover.hs", [(DsError, (62, 7), "Found hole: _")])-          , ( "GotoHover.hs", [(DsError, (65, 8), "Found hole: _")])-          ]-    , testGroup "type-definition" typeDefinitionTests ]--  typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 (pure tcData) "Saturated data con"-                        , tst (getTypeDefinitions, checkDefs) aL20 (pure [ExpectNoDefinitions]) "Polymorphic variable"]--  test runDef runHover look expect = testM runDef runHover look (return expect)--  testM runDef runHover look expect title =-    ( runDef   $ tst def   look expect title-    , runHover $ tst hover look expect title ) where-      def   = (getDefinitions, checkDefs)-      hover = (getHover      , checkHover)--  -- search locations            expectations on results-  fffL4  = _start fffR     ;  fffR = mkRange 8  4    8  7 ; fff  = [ExpectRange fffR]-  fffL8  = Position 12  4  ;-  fffL14 = Position 18  7  ;-  aL20   = Position 19 15-  aaaL14 = Position 18 20  ;  aaa    = [mkR  11  0   11  3]-  dcL7   = Position 11 11  ;  tcDC   = [mkR   7 23    9 16]-  dcL12  = Position 16 11  ;-  xtcL5  = Position  9 11  ;  xtc    = [ExpectExternFail,   ExpectHoverText ["Int", "Defined in ", "GHC.Types", "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 = [ExpectHoverText ["[Documentation](file:///"]]-  imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3]-  reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 0 3 14]-  thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]]-  in-  mkFindTests-  --      def    hover  look       expect-  [-    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"-  , if ghcVersion >= GHC810 then-        test  yes    yes    spaceL37   space         "top-level fn on space           #1002"-    else-        test  yes    broken 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"-  , 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     skip   cccL17     docLink       "Haddock html links"-  , testM yes    yes    imported   importedSig   "Imported symbol"-  , testM yes    yes    reexported reexportedSig "Imported symbol (reexported)"-  , if | ghcVersion == GHC90 && isWindows ->-        test  no     broken    thLocL57   thLoc         "TH Splice Hover"-       | ghcVersion == GHC92 && (isWindows || isMac) ->-           -- Some GHC 9.2 distributions ship without .hi docs-           -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903-        test  no     broken   thLocL57   thLoc         "TH Splice Hover"-       | otherwise ->-        test  no     yes       thLocL57   thLoc         "TH Splice Hover"-  ]-  where yes, broken :: (TestTree -> Maybe TestTree)-        yes    = Just -- test should run and pass-        broken = Just . (`xfail` "known broken")-        no = const Nothing -- don't run this test at all-        skip = const Nothing -- unreliable, don't run--checkFileCompiles :: FilePath -> Session () -> TestTree-checkFileCompiles fp diag =-  testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do-    void (openTestDataDoc (dir </> fp))-    diag--pluginSimpleTests :: TestTree-pluginSimpleTests =-  ignoreInWindowsForGHC88And810 $-  ignoreForGHC92 "blocked on ghc-typelits-natnormalise" $-  testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do-    _ <- openDoc (dir </> "KnownNat.hs") "haskell"-    liftIO $ writeFile (dir</>"hie.yaml")-      "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}"--    expectDiagnostics-      [ ( "KnownNat.hs",-          [(DsError, (9, 15), "Variable not in scope: c")]-          )-      ]--pluginParsedResultTests :: TestTree-pluginParsedResultTests =-  ignoreInWindowsForGHC88And810 $-  ignoreForGHC92 "No need for this plugin anymore!" $-  testSessionWithExtraFiles "plugin-recorddot" "parsedResultAction plugin" $ \dir -> do-    _ <- openDoc (dir</> "RecordDot.hs") "haskell"-    expectNoMoreDiagnostics 2--cppTests :: TestTree-cppTests =-  testGroup "cpp"-    [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do-        let content =-              T.unlines-                [ "{-# LANGUAGE CPP #-}",-                  "module Testing where",-                  "#ifdef FOO",-                  "foo = 42"-                ]-        -- The error locations differ depending on which C-preprocessor is used.-        -- Some give the column number and others don't (hence 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", [(DsError, (3, 2), "Variable not in scope: worked")])]-    ]-  where-    expectError :: T.Text -> Cursor -> Session ()-    expectError content cursor = do-      _ <- createDoc "Testing.hs" "haskell" content-      expectDiagnostics-        [ ( "Testing.hs",-            [(DsError, cursor, "error: unterminated")]-          )-        ]-      expectNoMoreDiagnostics 0.5--preprocessorTests :: TestTree-preprocessorTests = testSessionWait "preprocessor" $ do-  let content =-        T.unlines-          [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}"-          , "module Testing where"-          , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic-          ]-  _ <- createDoc "Testing.hs" "haskell" content-  expectDiagnostics-    [ ( "Testing.hs",-        [(DsError, (2, 8), "Variable not in scope: z")]-      )-    ]---safeTests :: TestTree-safeTests =-  testGroup-    "SafeHaskell"-    [ -- Test for https://github.com/haskell/ghcide/issues/424-      testSessionWait "load" $ do-        let sourceA =-              T.unlines-                ["{-# LANGUAGE Trustworthy #-}"-                ,"module A where"-                ,"import System.IO.Unsafe"-                ,"import System.IO ()"-                ,"trustWorthyId :: a -> a"-                ,"trustWorthyId i = unsafePerformIO $ do"-                ,"  putStrLn \"I'm safe\""-                ,"  return i"]-            sourceB =-              T.unlines-                ["{-# LANGUAGE Safe #-}"-                ,"module B where"-                ,"import A"-                ,"safeId :: a -> a"-                ,"safeId = trustWorthyId"-                ]--        _ <- createDoc "A.hs" "haskell" sourceA-        _ <- createDoc "B.hs" "haskell" sourceB-        expectNoMoreDiagnostics 1 ]--thTests :: TestTree-thTests =-  testGroup-    "TemplateHaskell"-    [ -- Test for https://github.com/haskell/ghcide/pull/212-      testSessionWait "load" $ do-        let sourceA =-              T.unlines-                [ "{-# LANGUAGE PackageImports #-}",-                  "{-# LANGUAGE TemplateHaskell #-}",-                  "module A where",-                  "import \"template-haskell\" Language.Haskell.TH",-                  "a :: Integer",-                  "a = $(litE $ IntegerL 3)"-                ]-            sourceB =-              T.unlines-                [ "{-# LANGUAGE PackageImports #-}",-                  "{-# LANGUAGE TemplateHaskell #-}",-                  "module B where",-                  "import A",-                  "import \"template-haskell\" Language.Haskell.TH",-                  "b :: Integer",-                  "b = $(litE $ IntegerL $ a) + n"-                ]-        _ <- createDoc "A.hs" "haskell" sourceA-        _ <- createDoc "B.hs" "haskell" sourceB-        expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]-    , testSessionWait "newtype-closure" $ do-        let sourceA =-              T.unlines-                [ "{-# LANGUAGE DeriveDataTypeable #-}"-                  ,"{-# LANGUAGE TemplateHaskell #-}"-                  ,"module A (a) where"-                  ,"import Data.Data"-                  ,"import Language.Haskell.TH"-                  ,"newtype A = A () deriving (Data)"-                  ,"a :: ExpQ"-                  ,"a = [| 0 |]"]-        let sourceB =-              T.unlines-                [ "{-# LANGUAGE TemplateHaskell #-}"-                ,"module B where"-                ,"import A"-                ,"b :: Int"-                ,"b = $( a )" ]-        _ <- createDoc "A.hs" "haskell" sourceA-        _ <- createDoc "B.hs" "haskell" sourceB-        return ()-    , thReloadingTest False-    , thLoadingTest-    , 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", [(DsWarning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ]-    , ignoreInWindowsForGHC88 $ testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do--    -- This test defines a TH value with the meaning "data A = A" in A.hs-    -- Loads and export the template in B.hs-    -- And checks wether the constructor A can be loaded in C.hs-    -- This test does not fail when either A and B get manually loaded before C.hs-    -- or when we remove the seemingly unnecessary TH pragma from C.hs--    let cPath = dir </> "C.hs"-    _ <- openDoc cPath "haskell"-    expectDiagnostics [ ( cPath, [(DsWarning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ]-    ]---- | Tests for projects that use symbolic links one way or another-symlinkTests :: TestTree-symlinkTests =-  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", [(DsWarning, (2, 0), "The import of 'Sym' is redundant", Just DtUnnecessary)])]-        pure ()-    ]---- | 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---- | test that TH is reevaluated on typecheck-thReloadingTest :: Bool -> TestTree-thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do--    let aPath = dir </> "THA.hs"-        bPath = dir </> "THB.hs"-        cPath = dir </> "THC.hs"--    aSource <- liftIO $ readFileUtf8 aPath --  th = [d|a = ()|]-    bSource <- liftIO $ readFileUtf8 bPath --  $th-    cSource <- liftIO $ readFileUtf8 cPath --  c = a :: ()--    adoc <- createDoc aPath "haskell" aSource-    bdoc <- createDoc bPath "haskell" bSource-    cdoc <- createDoc cPath "haskell" cSource--    expectDiagnostics [("THB.hs", [(DsWarning, (4,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 Nothing Nothing aSource']-    -- generate an artificial warning to avoid timing out if the TH change does not propagate-    changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing $ cSource <> "\nfoo=()"]--    -- Check that the change propagates to C-    expectDiagnostics-        [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")])-        ,("THC.hs", [(DsWarning, (6,0), "Top-level binding")])-        ,("THB.hs", [(DsWarning, (4,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", [(DsWarning, (4,thDollarIdx), "Top-level binding")])]--    let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"]-    changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource']--    -- modify b too-    let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"]-    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing bSource']-    waitForProgressBegin-    waitForAllProgressDone--    expectCurrentDiagnostics bdoc [(DsWarning, (4,thDollarIdx), "Top-level binding")]--    closeDoc adoc-    closeDoc bdoc-  where-    name = "th-linking-test" <> if unboxed then "-unboxed" else ""-    dir | unboxed = "THUnboxed"-        | otherwise = "TH"--completionTests :: TestTree-completionTests-  = testGroup "completion"-    [-    testGroup "non local" nonLocalCompletionTests-    , testGroup "topLevel" topLevelCompletionTests-    , testGroup "local" localCompletionTests-    , testGroup "package" packageCompletionTests-    , testGroup "project" projectCompletionTests-    , testGroup "other" otherCompletionTests-    , testGroup "doc" completionDocTests-    ]--completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe (List TextEdit))] -> TestTree-completionTest name src pos expected = testSessionWait name $ do-    docId <- createDoc "A.hs" "haskell" (T.unlines src)-    _ <- waitForDiagnostics-    compls <- getCompletions docId pos-    let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls]-    liftIO $ do-        let emptyToMaybe x = if T.null x then Nothing else Just x-        sortOn (Lens.view Lens._1) (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 $-                assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail)-            when expectedDocs $-                assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation)--completionCommandTest ::-  String ->-  [T.Text] ->-  Position ->-  T.Text ->-  [T.Text] ->-  TestTree-completionCommandTest name src pos wanted expected = testSession name $ do-  docId <- createDoc "A.hs" "haskell" (T.unlines src)-  _ <- waitForDiagnostics-  compls <- skipManyTill anyMessage (getCompletions docId pos)-  let wantedC = find ( \case-            CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x-            _                                     -> False-            ) compls-  case wantedC of-    Nothing ->-      liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls]-    Just CompletionItem {..} -> do-      c <- assertJust "Expected a command" _command-      executeCommand c-      if src /= expected-          then do-            void $ skipManyTill anyMessage loggingNotification-            modifiedCode <- skipManyTill anyMessage (getDocumentEdit docId)-            liftIO $ modifiedCode @?= T.unlines expected-          else do-            expectMessages SWorkspaceApplyEdit 1 $ \edit ->-              liftIO $ assertFailure $ "Expected no edit but got: " <> show edit--completionNoCommandTest ::-  String ->-  [T.Text] ->-  Position ->-  T.Text ->-  TestTree-completionNoCommandTest name src pos wanted = testSession name $ do-  docId <- createDoc "A.hs" "haskell" (T.unlines src)-  _ <- waitForDiagnostics-  compls <- getCompletions docId pos-  let wantedC = find ( \case-            CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x-            _                                     -> False-            ) compls-  case wantedC of-    Nothing ->-      liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls]-    Just CompletionItem{..} -> liftIO . assertBool ("Expected no command but got: " <> show _command) $ null _command---topLevelCompletionTests :: [TestTree]-topLevelCompletionTests = [-    completionTest-        "variable"-        ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]-        (Position 0 8)-        [("xxx", CiFunction, "xxx", True, True, Nothing)-        ],-    completionTest-        "constructor"-        ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]-        (Position 0 8)-        [("xxx", CiFunction, "xxx", True, True, Nothing)-        ],-    completionTest-        "class method"-        ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"]-        (Position 0 8)-        [("xxx", CiFunction, "xxx", True, True, Nothing)],-    completionTest-        "type"-        ["bar :: Xx", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]-        (Position 0 9)-        [("Xxx", CiStruct, "Xxx", False, True, Nothing)],-    completionTest-        "class"-        ["bar :: Xx", "xxx = ()", "-- | haddock", "class Xxx a"]-        (Position 0 9)-        [("Xxx", CiInterface, "Xxx", False, True, Nothing)],-    completionTest-        "records"-        ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ]-        (Position 1 19)-        [("_personName", CiFunction, "_personName", False, True, Nothing),-         ("_personAge", CiFunction, "_personAge", False, True, Nothing)],-    completionTest-        "recordsConstructor"-        ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ]-        (Position 1 19)-        [("XyRecord", CiConstructor, "XyRecord", False, True, Nothing),-         ("XyRecord", CiSnippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)]-    ]--localCompletionTests :: [TestTree]-localCompletionTests = [-    completionTest-        "argument"-        ["bar (Just abcdef) abcdefg = abcd"]-        (Position 0 32)-        [("abcdef", CiFunction, "abcdef", True, False, Nothing),-         ("abcdefg", CiFunction , "abcdefg", True, False, Nothing)-        ],-    completionTest-        "let"-        ["bar = let (Just abcdef) = undefined"-        ,"          abcdefg = let abcd = undefined in undefined"-        ,"        in abcd"-        ]-        (Position 2 15)-        [("abcdef", CiFunction, "abcdef", True, False, Nothing),-         ("abcdefg", CiFunction , "abcdefg", True, False, Nothing)-        ],-    completionTest-        "where"-        ["bar = abcd"-        ,"  where (Just abcdef) = undefined"-        ,"        abcdefg = let abcd = undefined in undefined"-        ]-        (Position 0 10)-        [("abcdef", CiFunction, "abcdef", True, False, Nothing),-         ("abcdefg", CiFunction , "abcdefg", True, False, Nothing)-        ],-    completionTest-        "do/1"-        ["bar = do"-        ,"  Just abcdef <- undefined"-        ,"  abcd"-        ,"  abcdefg <- undefined"-        ,"  pure ()"-        ]-        (Position 2 6)-        [("abcdef", CiFunction, "abcdef", True, False, Nothing)-        ],-    completionTest-        "do/2"-        ["bar abcde = do"-        ,"    Just [(abcdef,_)] <- undefined"-        ,"    abcdefg <- undefined"-        ,"    let abcdefgh = undefined"-        ,"        (Just [abcdefghi]) = undefined"-        ,"    abcd"-        ,"  where"-        ,"    abcdefghij = undefined"-        ]-        (Position 5 8)-        [("abcde", CiFunction, "abcde", True, False, Nothing)-        ,("abcdefghij", CiFunction, "abcdefghij", True, False, Nothing)-        ,("abcdef", CiFunction, "abcdef", True, False, Nothing)-        ,("abcdefg", CiFunction, "abcdefg", True, False, Nothing)-        ,("abcdefgh", CiFunction, "abcdefgh", True, False, Nothing)-        ,("abcdefghi", CiFunction, "abcdefghi", True, False, Nothing)-        ],-    completionTest-        "type family"-        ["{-# LANGUAGE DataKinds, TypeFamilies #-}"-        ,"type family Bar a"-        ,"a :: Ba"-        ]-        (Position 2 7)-        [("Bar", CiStruct, "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", CiFunction, "abcd", True, False, Nothing)-        ,("abcde", CiFunction, "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-                    { _range=Nothing-                    , _rangeLength=Nothing-                    , _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 =-  [ completionTest-      "variable"-      ["module A where", "f = hea"]-      (Position 1 7)-      [("head", CiFunction, "head ${1:([a])}", True, True, Nothing)],-    completionTest-      "constructor"-      ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"]-      (Position 2 8)-      [ ("True", CiConstructor, "True", True, True, Nothing)-      ],-    completionTest-      "type"-      ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"]-      (Position 2 8)-      [ ("Bool", CiStruct, "Bool", True, True, Nothing)-      ],-    completionTest-      "qualified"-      ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]-      (Position 2 15)-      [ ("head", CiFunction, "head ${1:([a])}", True, True, Nothing)-      ],-    completionTest-      "duplicate import"-      ["module A where", "import Data.List", "import Data.List", "f = permu"]-      (Position 3 9)-      [ ("permutations", CiFunction, "permutations ${1:([a])}", False, False, Nothing)-      ],-    completionTest-       "dont show hidden items"-       [ "{-# LANGUAGE NoImplicitPrelude #-}",-         "module A where",-         "import Control.Monad hiding (join)",-         "f = joi"-       ]-       (Position 3 6)-       [],-    testGroup "ordering"-      [completionTest "qualified has priority"-        ["module A where"-        ,"import qualified Data.ByteString as BS"-        ,"f = BS.read"-        ]-        (Position 2 10)-        [("readFile", CiFunction, "readFile ${1:FilePath}", True, True, Nothing)]-        ],-    testGroup "auto import snippets"-      [ completionCommandTest-        "show imports not in list - simple"-        ["{-# LANGUAGE NoImplicitPrelude #-}",-        "module A where", "import Control.Monad (msum)", "f = joi"]-        (Position 3 6)-        "join"-        ["{-# LANGUAGE NoImplicitPrelude #-}",-        "module A where", "import Control.Monad (msum, join)", "f = joi"]-      , completionCommandTest-        "show imports not in list - multi-line"-        ["{-# LANGUAGE NoImplicitPrelude #-}",-        "module A where", "import Control.Monad (\n    msum)", "f = joi"]-        (Position 4 6)-        "join"-        ["{-# LANGUAGE NoImplicitPrelude #-}",-        "module A where", "import Control.Monad (\n    msum, join)", "f = joi"]-      , completionCommandTest-        "show imports not in list - names with _"-        ["{-# LANGUAGE NoImplicitPrelude #-}",-        "module A where", "import Control.Monad as M (msum)", "f = M.mapM_"]-        (Position 3 11)-        "mapM_"-        ["{-# LANGUAGE NoImplicitPrelude #-}",-        "module A where", "import Control.Monad as M (msum, mapM_)", "f = M.mapM_"]-      , completionCommandTest-        "show imports not in list - initial empty list"-        ["{-# LANGUAGE NoImplicitPrelude #-}",-        "module A where", "import Control.Monad as M ()", "f = M.joi"]-        (Position 3 10)-        "join"-        ["{-# LANGUAGE NoImplicitPrelude #-}",-        "module A where", "import Control.Monad as M (join)", "f = M.joi"]-      , testGroup "qualified imports"-        [ completionCommandTest-            "single"-            ["{-# LANGUAGE NoImplicitPrelude #-}",-            "module A where", "import Control.Monad ()", "f = Control.Monad.joi"]-            (Position 3 22)-            "join"-            ["{-# LANGUAGE NoImplicitPrelude #-}",-            "module A where", "import Control.Monad (join)", "f = Control.Monad.joi"]-        , completionCommandTest-            "as"-            ["{-# LANGUAGE NoImplicitPrelude #-}",-            "module A where", "import Control.Monad as M ()", "f = M.joi"]-            (Position 3 10)-            "join"-            ["{-# LANGUAGE NoImplicitPrelude #-}",-            "module A where", "import Control.Monad as M (join)", "f = M.joi"]-        , completionCommandTest-            "multiple"-            ["{-# LANGUAGE NoImplicitPrelude #-}",-            "module A where", "import Control.Monad as M ()", "import Control.Monad as N ()", "f = N.joi"]-            (Position 4 10)-            "join"-            ["{-# LANGUAGE NoImplicitPrelude #-}",-            "module A where", "import Control.Monad as M ()", "import Control.Monad as N (join)", "f = N.joi"]-        ]-      , testGroup "Data constructor"-        [ completionCommandTest-            "not imported"-            ["module A where", "import Text.Printf ()", "ZeroPad"]-            (Position 2 4)-            "ZeroPad"-            ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"]-        , completionCommandTest-            "parent imported abs"-            ["module A where", "import Text.Printf (FormatAdjustment)", "ZeroPad"]-            (Position 2 4)-            "ZeroPad"-            ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"]-        , completionNoCommandTest-            "parent imported all"-            ["module A where", "import Text.Printf (FormatAdjustment (..))", "ZeroPad"]-            (Position 2 4)-            "ZeroPad"-        , completionNoCommandTest-            "already imported"-            ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"]-            (Position 2 4)-            "ZeroPad"-        , completionNoCommandTest-            "function from Prelude"-            ["module A where", "import Data.Maybe ()", "Nothing"]-            (Position 2 4)-            "Nothing"-        , completionCommandTest-            "type operator parent"-            ["module A where", "import Data.Type.Equality ()", "f = Ref"]-            (Position 2 8)-            "Refl"-            ["module A where", "import Data.Type.Equality (type (:~:) (Refl))", "f = Ref"]-        ]-      , testGroup "Record completion"-        [ completionCommandTest-            "not imported"-            ["module A where", "import Text.Printf ()", "FormatParse"]-            (Position 2 10)-            "FormatParse {"-            ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"]-        , completionCommandTest-            "parent imported"-            ["module A where", "import Text.Printf (FormatParse)", "FormatParse"]-            (Position 2 10)-            "FormatParse {"-            ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"]-        , completionNoCommandTest-            "already imported"-            ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"]-            (Position 2 10)-            "FormatParse {"-        ]-      ],-      -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls-     completionTest-      "do not show pragma completions"-      [ "{-# LANGUAGE  ",-        "{module A where}",-        "main = return ()"-      ]-      (Position 0 13)-      []-  ]--otherCompletionTests :: [TestTree]-otherCompletionTests = [-    completionTest-      "keyword"-      ["module A where", "f = newty"]-      (Position 1 9)-      [("newtype", CiKeyword, "", False, False, Nothing)],-    completionTest-      "type context"-      [ "{-# OPTIONS_GHC -Wunused-binds #-}",-        "module A () where",-        "f = f",-        "g :: Intege"-      ]-      -- At this point the module parses but does not typecheck.-      -- This should be sufficient to detect that we are in a-      -- type context and only show the completion to the type.-      (Position 3 11)-      [("Integer", CiStruct, "Integer", True, True, Nothing)],--    testSession "duplicate record fields" $ do-      void $-        createDoc "B.hs" "haskell" $-          T.unlines-            [ "{-# LANGUAGE DuplicateRecordFields #-}",-              "module B where",-              "newtype Foo = Foo { member :: () }",-              "newtype Bar = Bar { member :: () }"-            ]-      docA <--        createDoc "A.hs" "haskell" $-          T.unlines-            [ "module A where",-              "import B",-              "memb"-            ]-      _ <- waitForDiagnostics-      compls <- getCompletions docA $ Position 2 4-      let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"]-      liftIO $ take 2 compls' @?= ["member ${1:Bar}", "member ${1:Foo}"],--    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 (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label}-                <- compls-              , _label == "fromList"-              ]-        liftIO $ take 3 (sort compls') @?=-          map ("Defined in "<>)-              [ "'Data.List.NonEmpty"-              , "'GHC.Exts"-              ]--  , 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 (CompletionDocMarkup (MarkupContent MkMarkdown 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 =-              find-                (\case-                  CompletionItem-                    { _insertText = Just "fromList"-                    , _documentation =-                      Just (CompletionDocMarkup (MarkupContent MkMarkdown d))-                    } ->-                    "GHC.Exts" `T.isInfixOf` d-                  _ -> False-                ) compls-        liftIO $ duplicate @?= Nothing--  , 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 ${1:([Item l])}"]-  , testGroup "auto import snippets"-    [ completionCommandTest-            "import Data.Sequence"-            ["module A where", "foo :: Seq"]-            (Position 1 9)-            "Seq"-            ["module A where", "import Data.Sequence (Seq)", "foo :: Seq"]--    , completionCommandTest-            "qualified import"-            ["module A where", "foo :: Seq.Seq"]-            (Position 1 13)-            "Seq"-            ["module A where", "import qualified Data.Sequence as Seq", "foo :: Seq.Seq"]-    ]-  ]--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 (CompletionDocMarkup (MarkupContent MkMarkdown 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") . (^. Lens.label)) compls-        liftIO $ do-          item ^. Lens.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"]-  , brokenForGhc9 $ testSession "local single line doc without '\\n'" $ 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* * *\ndocdoc\n"]-  , brokenForGhc9 $ testSession "local multi line doc with '\\n'" $ 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 abcabc\n"]-  , brokenForGhc9 $ testSession "local multi line doc without '\\n'" $ 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     abcabc\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 $ brokenForWinGhc9 $ 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 $ brokenForWinGhc9 $ 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]) "Completion doc doesn't support ghc9"-    brokenForWinGhc9 = knownBrokenFor (BrokenSpecific Windows [GHC90, GHC92]) "Extern doc doesn't support Windows for ghc9.2"-    -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903-    brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC90, GHC92]) "Extern doc doesn't support MacOS for ghc9"-    test doc pos label mn expected = do-      _ <- waitForDiagnostics-      compls <- getCompletions doc pos-      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 (CompletionDocMarkup (MarkupContent MkMarkdown txt)), ..} <- compls-            , _label == label-            ]-      liftIO $ compls' @?= expected--highlightTests :: TestTree-highlightTests = testGroup "highlight"-  [ testSessionWait "value" $ do-    doc <- createDoc "A.hs" "haskell" source-    _ <- waitForDiagnostics-    highlights <- getHighlights doc (Position 3 2)-    liftIO $ highlights @?= List-            [ DocumentHighlight (R 2 0 2 3) (Just HkRead)-            , DocumentHighlight (R 3 0 3 3) (Just HkWrite)-            , DocumentHighlight (R 4 6 4 9) (Just HkRead)-            , DocumentHighlight (R 5 22 5 25) (Just HkRead)-            ]-  , testSessionWait "type" $ do-    doc <- createDoc "A.hs" "haskell" source-    _ <- waitForDiagnostics-    highlights <- getHighlights doc (Position 2 8)-    liftIO $ highlights @?= List-            [ DocumentHighlight (R 2 7 2 10) (Just HkRead)-            , DocumentHighlight (R 3 11 3 14) (Just HkRead)-            ]-  , testSessionWait "local" $ do-    doc <- createDoc "A.hs" "haskell" source-    _ <- waitForDiagnostics-    highlights <- getHighlights doc (Position 6 5)-    liftIO $ highlights @?= List-            [ DocumentHighlight (R 6 4 6 7) (Just HkWrite)-            , DocumentHighlight (R 6 10 6 13) (Just HkRead)-            , DocumentHighlight (R 7 12 7 15) (Just HkRead)-            ]-  , knownBrokenForGhcVersions [GHC90, GHC92] "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 @?= List-          -- Span is just the .. on 8.10, but Rec{..} before-          [ if ghcVersion >= GHC810-              then DocumentHighlight (R 4 8 4 10) (Just HkWrite)-              else DocumentHighlight (R 4 4 4 11) (Just HkWrite)-          , DocumentHighlight (R 4 14 4 20) (Just HkRead)-          ]-        highlights <- getHighlights doc (Position 3 17)-        liftIO $ highlights @?= List-          [ DocumentHighlight (R 3 17 3 23) (Just HkWrite)-          -- Span is just the .. on 8.10, but Rec{..} before-          , if ghcVersion >= GHC810-              then DocumentHighlight (R 4 8 4 10) (Just HkRead)-              else DocumentHighlight (R 4 4 4 11) (Just HkRead)-          ]-  ]-  where-    source = T.unlines-      ["{-# OPTIONS_GHC -Wunused-binds #-}"-      ,"module Highlight () where"-      ,"foo :: Int"-      ,"foo = 3 :: Int"-      ,"bar = foo"-      ,"  where baz = let x = foo in x"-      ,"baz arg = arg + x"-      ,"  where x = arg"-      ]-    recsource = T.unlines-      ["{-# LANGUAGE RecordWildCards #-}"-      ,"{-# OPTIONS_GHC -Wunused-binds #-}"-      ,"module Highlight () where"-      ,"data Rec = Rec { field1 :: Int, field2 :: Char }"-      ,"foo Rec{..} = field2 + field1"-      ]--outlineTests :: TestTree-outlineTests = testGroup-  "outline"-  [ testSessionWait "type class" $ do-    let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [ moduleSymbol-          "A"-          (R 0 7 0 8)-          [ classSymbol "A a"-                        (R 1 0 1 30)-                        [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)]-          ]-      ]-  , testSessionWait "type class instance " $ do-    let source = T.unlines ["class A a where", "instance A () where"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [ classSymbol "A a" (R 0 0 0 15) []-      , docSymbol "A ()" SkInterface (R 1 0 1 19)-      ]-  , testSessionWait "type family" $ do-    let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkFunction (R 1 0 1 13)]-  , testSessionWait "type family instance " $ do-    let source = T.unlines-          [ "{-# language TypeFamilies #-}"-          , "type family A a"-          , "type instance A () = ()"-          ]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [ docSymbolD "A a"   "type family" SkFunction     (R 1 0 1 15)-      , docSymbol "A ()" SkInterface (R 2 0 2 23)-      ]-  , testSessionWait "data family" $ do-    let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkFunction (R 1 0 1 11)]-  , testSessionWait "data family instance " $ do-    let source = T.unlines-          [ "{-# language TypeFamilies #-}"-          , "data family A a"-          , "data instance A () = A ()"-          ]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [ docSymbolD "A a"   "data family" SkFunction     (R 1 0 1 11)-      , docSymbol "A ()" SkInterface (R 2 0 2 25)-      ]-  , testSessionWait "constant" $ do-    let source = T.unlines ["a = ()"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [docSymbol "a" SkFunction (R 0 0 0 6)]-  , testSessionWait "pattern" $ do-    let source = T.unlines ["Just foo = Just 21"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [docSymbol "Just foo" SkFunction (R 0 0 0 18)]-  , testSessionWait "pattern with type signature" $ do-    let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]-  , testSessionWait "function" $ do-    let source = T.unlines ["a _x = ()"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 9)]-  , testSessionWait "type synonym" $ do-    let source = T.unlines ["type A = Bool"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]-  , testSessionWait "datatype" $ do-    let source = T.unlines ["data A = C"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [ docSymbolWithChildren "A"-                              SkStruct-                              (R 0 0 0 10)-                              [docSymbol "C" SkConstructor (R 0 9 0 10)]-      ]-  , testSessionWait "record fields" $ do-    let source = T.unlines ["data A = B {", "  x :: Int", "  , y :: Int}"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13)-          [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10)-            [ docSymbol "x" SkField (R 1 2 1 3)-            , docSymbol "y" SkField (R 2 4 2 5)-            ]-          ]-      ]-  , testSessionWait "import" $ do-    let source = T.unlines ["import Data.Maybe ()"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [docSymbolWithChildren "imports"-                             SkModule-                             (R 0 0 0 20)-                             [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 20)-                             ]-      ]-  , testSessionWait "multiple import" $ do-    let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [docSymbolWithChildren "imports"-                             SkModule-                             (R 1 0 3 27)-                             [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 20)-                             , docSymbol "import Control.Exception" SkModule (R 3 0 3 27)-                             ]-      ]-  , testSessionWait "foreign import" $ do-    let source = T.unlines-          [ "{-# language ForeignFunctionInterface #-}"-          , "foreign import ccall \"a\" a :: Int"-          ]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]-  , testSessionWait "foreign export" $ do-    let source = T.unlines-          [ "{-# language ForeignFunctionInterface #-}"-          , "foreign export ccall odd :: Int -> Bool"-          ]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]-  ]- where-  docSymbol name kind loc =-    DocumentSymbol name Nothing kind Nothing 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 $ List cc)-  docSymbolWithChildren' name kind loc selectionLoc cc =-    DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just $ List cc)-  moduleSymbol name loc cc = DocumentSymbol name-                                            Nothing-                                            SkFile-                                            Nothing-                                            Nothing-                                            (R 0 0 maxBound 0)-                                            loc-                                            (Just $ List cc)-  classSymbol name loc cc = DocumentSymbol name-                                           (Just "class")-                                           SkInterface-                                           Nothing-                                           Nothing-                                           loc-                                           loc-                                           (Just $ List cc)--pattern R :: UInt -> UInt -> UInt -> UInt -> Range-pattern R x y x' y' = Range (Position x y) (Position x' y')--xfail :: TestTree -> String -> TestTree-xfail = flip expectFailBecause--ignoreInWindowsBecause :: String -> TestTree -> TestTree-ignoreInWindowsBecause = ignoreFor (BrokenForOS Windows)--ignoreInWindowsForGHC88And810 :: TestTree -> TestTree-ignoreInWindowsForGHC88And810 =-    ignoreFor (BrokenSpecific Windows [GHC88, GHC810]) "tests are unreliable in windows for ghc 8.8 and 8.10"--ignoreForGHC92 :: String -> TestTree -> TestTree-ignoreForGHC92 = ignoreFor (BrokenForGHC [GHC92])--ignoreInWindowsForGHC88 :: TestTree -> TestTree-ignoreInWindowsForGHC88 =-    ignoreFor (BrokenSpecific Windows [GHC88]) "tests are unreliable in windows for ghc 8.8"--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 = \_ -> 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-  | 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--haddockTests :: TestTree-haddockTests-  = testGroup "haddock"-      [ testCase "Num" $ checkHaddock-          (unlines-             [ "However, '(+)' and '(*)' are"-             , "customarily expected to define a ring and have the following properties:"-             , ""-             , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@"-             , "[__Commutativity of (+)__]: @x + y@ = @y + x@"-             , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@"-             ]-          )-          (unlines-             [ ""-             , ""-             , "However,  `(+)`  and  `(*)`  are"-             , "customarily expected to define a ring and have the following properties: "-             , "+ ****Associativity of (+)****: `(x + y) + z`  =  `x + (y + z)`"-             , "+ ****Commutativity of (+)****: `x + y`  =  `y + x`"-             , "+ ****`fromInteger 0`  is the additive identity****: `x + fromInteger 0`  =  `x`"-             ]-          )-      , testCase "unsafePerformIO" $ checkHaddock-          (unlines-             [ "may require"-             , "different precautions:"-             , ""-             , "  * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@"-             , "        that calls 'unsafePerformIO'.  If the call is inlined,"-             , "        the I\\/O may be performed more than once."-             , ""-             , "  * Use the compiler flag @-fno-cse@ to prevent common sub-expression"-             , "        elimination being performed on the module."-             , ""-             ]-          )-          (unlines-             [ ""-             , ""-             , "may require"-             , "different precautions: "-             , "+ Use  `{-# NOINLINE foo #-}`  as a pragma on any function  `foo` "-             , "  that calls  `unsafePerformIO` .  If the call is inlined,"-             , "  the I/O may be performed more than once."-             , ""-             , "+ Use the compiler flag  `-fno-cse`  to prevent common sub-expression"-             , "  elimination being performed on the module."-             , ""-             ]-          )-      ]-  where-    checkHaddock s txt = spanDocToMarkdownForTest s @?= txt--cradleTests :: TestTree-cradleTests = testGroup "cradle"-    [testGroup "dependencies" [sessionDepsArePickedUp]-    ,testGroup "ignore-fatal" [ignoreFatalWarning]-    ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle]-    ,testGroup "multi"   [simpleMultiTest, simpleMultiTest2, 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 STextDocumentPublishDiagnostics))-            liftIO $ length msgs @?= 1-            changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]-            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics))-            liftIO $ length msgs @?= 0-            _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"-            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics))-            liftIO $ length msgs @?= 0--retryFailedCradle :: TestTree-retryFailedCradle = testSession' "retry failed" $ \dir -> do-  -- The false cradle always fails-  let hieContents = "cradle: {bios: {shell: \"false\"}}"-      hiePath = dir </> "hie.yaml"-  liftIO $ writeFile hiePath hieContents-  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 SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $-          List [FileEvent (filePathToUri $ dir </> "hie.yaml") FcChanged ]--  WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc-  liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess---dependentFileTest :: TestTree-dependentFileTest = testGroup "addDependentFile"-    [testGroup "file-changed" [ignoreInWindowsForGHC88 $ testSession' "test" test]-    ]-    where-      test dir = do-        -- If the file contains B then no type error-        -- otherwise type error-        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", [(DsError, if ghcVersion >= GHC92 then (4,11) else (4, 6), "Couldn't match type")])]-                else [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]-        -- Now modify the dependent file-        liftIO $ writeFile depFilePath "B"-        sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $-          List [FileEvent (filePathToUri "dep-file.txt") FcChanged ]--        -- Modifying Baz will now trigger Foo to be rebuilt as well-        let change = TextDocumentContentChangeEvent-              { _range = Just (Range (Position 2 0) (Position 2 6))-              , _rangeLength = Nothing-              , _text = "f = ()"-              }-        changeDoc doc [change]-        expectDiagnostics [("Foo.hs", [])]---cradleLoadedMessage :: Session FromServerMessage-cradleLoadedMessage = satisfy $ \case-        FromServerMess (SCustomMethod m) (NotMess _) -> m == cradleLoadedMethod-        _                                            -> False--cradleLoadedMethod :: T.Text-cradleLoadedMethod = "ghcide/cradle/loaded"--ignoreFatalWarning :: TestTree-ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do-    let srcPath = dir </> "IgnoreFatal.hs"-    src <- liftIO $ readFileUtf8 srcPath-    _ <- createDoc srcPath "haskell" src-    expectNoMoreDiagnostics 5--simpleSubDirectoryTest :: TestTree-simpleSubDirectoryTest =-  testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do-    let mainPath = dir </> "a/src/Main.hs"-    mainSource <- liftIO $ readFileUtf8 mainPath-    _mdoc <- createDoc mainPath "haskell" mainSource-    expectDiagnosticsWithTags-      [("a/src/Main.hs", [(DsWarning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded-      ]-    expectNoMoreDiagnostics 0.5--simpleMultiTest :: TestTree-simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraFiles "multi" $ \dir -> do-    let aPath = dir </> "a/A.hs"-        bPath = dir </> "b/B.hs"-    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 seperate session-simpleMultiDefTest :: TestTree-simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do-    let aPath = dir </> "a/A.hs"-        bPath = dir </> "b/B.hs"-    adoc <- liftIO $ runInDir dir $ do-      aSource <- liftIO $ readFileUtf8 aPath-      adoc <- createDoc aPath "haskell" aSource-      skipManyTill anyMessage $ 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--ifaceTests :: TestTree-ifaceTests = testGroup "Interface loading tests"-    [ -- https://github.com/haskell/ghcide/pull/645/-      ifaceErrorTest-    , ifaceErrorTest2-    , ifaceErrorTest3-    , ifaceTHTest-    ]--bootTests :: TestTree-bootTests = 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 STextDocumentHover hoverParams-            let parseReadyMessage = isReferenceReady cPath-            let parseHoverResponse = responseForId STextDocumentHover 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 that TH reevaluates across interfaces-ifaceTHTest :: TestTree-ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do-    let aPath = dir </> "THA.hs"-        bPath = dir </> "THB.hs"-        cPath = dir </> "THC.hs"--    aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: ()-    _bSource <- liftIO $ readFileUtf8 bPath -- a :: ()-    cSource <- liftIO $ readFileUtf8 cPath -- c = a :: ()--    cdoc <- createDoc cPath "haskell" cSource--    -- Change [TH]a from () to Bool-    liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"])--    -- Check that the change propogates to C-    changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing cSource]-    expectDiagnostics-      [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")])-      ,("THB.hs", [(DsWarning, (4,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", [(DsWarning,(4,0), "Top-level binding")])] -- So what we know P has been loaded--    -- Change y from Int to B-    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]-    -- save so that we can that the error propogates to A-    sendNotification STextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing)--    -- Check that the error propogates to A-    expectDiagnostics-      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])]---    -- Check that we wrote the interfaces for B when we saved-    hidir <- getInterfaceFilesDir bdoc-    hi_exists <- liftIO $ doesFileExist $ hidir </> "B.hi"-    liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists--    pdoc <- createDoc pPath "haskell" pSource-    changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ]-    -- Now in P we have-    -- bar = x :: Int-    -- foo = y :: Bool-    -- HOWEVER, in A...-    -- x = y  :: Int-    -- This is clearly inconsistent, and the expected outcome a bit surprising:-    --   - The diagnostic for A has already been received. Ghcide does not repeat diagnostics-    --   - P is being typechecked with the last successful artifacts for A.-    expectDiagnostics-      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])-      ,("P.hs", [(DsWarning,(6,0), "Top-level binding")])-      ]-    expectNoMoreDiagnostics 2--ifaceErrorTest2 :: TestTree-ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \dir -> do-    let bPath = dir </> "B.hs"-        pPath = dir </> "P.hs"--    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int-    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int--    bdoc <- createDoc bPath "haskell" bSource-    pdoc <- createDoc pPath "haskell" pSource-    expectDiagnostics-      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded--    -- Change y from Int to B-    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]--    -- Add a new definition to P-    changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ]-    -- Now in P we have-    -- bar = x :: Int-    -- foo = y :: Bool-    -- HOWEVER, in A...-    -- x = y  :: Int-    expectDiagnostics-    -- As in the other test, P is being typechecked with the last successful artifacts for A-    -- (ot thanks to -fdeferred-type-errors)-      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])-      ,("P.hs", [(DsWarning, (4, 0), "Top-level binding")])-      ,("P.hs", [(DsWarning, (6, 0), "Top-level binding")])-      ]--    expectNoMoreDiagnostics 2--ifaceErrorTest3 :: TestTree-ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \dir -> do-    let bPath = dir </> "B.hs"-        pPath = dir </> "P.hs"--    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int-    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int--    bdoc <- createDoc bPath "haskell" bSource--    -- Change y from Int to B-    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]--    -- P should not typecheck, as there are no last valid artifacts for A-    _pdoc <- createDoc pPath "haskell" pSource--    -- In this example the interface file for A should not exist (modulo the cache folder)-    -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors-    expectDiagnostics-      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])-      ,("P.hs", [(DsWarning,(4,0), "Top-level binding")])-      ]-    expectNoMoreDiagnostics 2--sessionDepsArePickedUp :: TestTree-sessionDepsArePickedUp = testSession'-  "session-deps-are-picked-up"-  $ \dir -> do-    liftIO $-      writeFileUTF8-        (dir </> "hie.yaml")-        "cradle: {direct: {arguments: []}}"-    -- Open without OverloadedStrings and expect an error.-    doc <- createDoc "Foo.hs" "haskell" fooContent-    expectDiagnostics $-        if ghcVersion >= GHC90-            -- String vs [Char] causes this change in error message-            then [("Foo.hs", [(DsError, (3, 6), "Couldn't match type")])]-            else [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]-    -- Update hie.yaml to enable OverloadedStrings.-    liftIO $-      writeFileUTF8-        (dir </> "hie.yaml")-        "cradle: {direct: {arguments: [-XOverloadedStrings]}}"-    sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $-          List [FileEvent (filePathToUri $ dir </> "hie.yaml") FcChanged ]-    -- Send change event.-    let change =-          TextDocumentContentChangeEvent-            { _range = Just (Range (Position 4 0) (Position 4 0)),-              _rangeLength = Nothing,-              _text = "\n"-            }-    changeDoc doc [change]-    -- Now no errors.-    expectDiagnostics [("Foo.hs", [])]-  where-    fooContent =-      T.unlines-        [ "module Foo where",-          "import Data.Text",-          "foo :: Text",-          "foo = \"hello\""-        ]---- A test to ensure that the command line ghcide workflow stays working-nonLspCommandLine :: TestTree-nonLspCommandLine = testGroup "ghcide command line"-  [ testCase "works" $ withTempDir $ \dir -> do-        ghcide <- locateGhcideExecutable-        copyTestDataFiles dir "multi"-        let cmd = (proc ghcide ["a/A.hs"]){cwd = Just dir}--        setEnv "HOME" "/homeless-shelter" False--        (ec, _, _) <- readCreateProcessWithExitCode cmd ""--        ec @?= ExitSuccess-  ]--benchmarkTests :: TestTree-benchmarkTests =-    let ?config = Bench.defConfig-            { Bench.verbosity = Bench.Quiet-            , Bench.repetitions = Just 3-            , Bench.buildTool = Bench.Cabal-            } in-    withResource Bench.setup Bench.cleanUp $ \getResource -> testGroup "benchmark experiments"-    [ testCase (Bench.name e) $ do-        Bench.SetupResult{Bench.benchDir} <- getResource-        res <- Bench.runBench (runInDir benchDir) e-        assertBool "did not successfully complete 5 repetitions" $ Bench.success res-        | e <- Bench.experiments-        , Bench.name e /= "edit" -- the edit experiment does not ever fail-        , Bench.name e /= "hole fit suggestions" -- is too slow!-        -- the cradle experiments are way too slow-        , not ("cradle" `isInfixOf` Bench.name e)-    ]---- | checks if we use InitializeParams.rootUri for loading session-rootUriTests :: TestTree-rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do-  let bPath = dir </> "dirB/Foo.hs"-  liftIO $ copyTestDataFiles dir "rootUri"-  bSource <- liftIO $ readFileUtf8 bPath-  _ <- createDoc "Foo.hs" "haskell" bSource-  expectNoMoreDiagnostics 0.5-  where-    -- similar to run' except we can configure where to start ghcide and session-    runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO ()-    runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir)---- | Test if ghcide asynchronously handles Commands and user Requests-asyncTests :: TestTree-asyncTests = testGroup "async"-    [-      testSession "command" $ do-            -- Execute a command that will block forever-            let req = ExecuteCommandParams Nothing blockCommandId Nothing-            void $ sendRequest SWorkspaceExecuteCommand req-            -- Load a file and check for code actions. Will only work if the command is run asynchronously-            doc <- createDoc "A.hs" "haskell" $ T.unlines-              [ "{-# OPTIONS -Wmissing-signatures #-}"-              , "foo = id"-              ]-            void waitForDiagnostics-            actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0))-            liftIO $ [ _title | InR CodeAction{_title} <- actions] @=?-              [ "add signature: foo :: a -> a" ]-    , testSession "request" $ do-            -- Execute a custom request that will block for 1000 seconds-            void $ sendRequest (SCustomMethod "test") $ toJSON $ BlockSeconds 1000-            -- Load a file and check for code actions. Will only work if the request is run asynchronously-            doc <- createDoc "A.hs" "haskell" $ T.unlines-              [ "{-# OPTIONS -Wmissing-signatures #-}"-              , "foo = id"-              ]-            void waitForDiagnostics-            actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0))-            liftIO $ [ _title | InR CodeAction{_title} <- actions] @=?-              [ "add signature: foo :: a -> a" ]-    ]---clientSettingsTest :: TestTree-clientSettingsTest = testGroup "client settings handling"-    [ testSession "ghcide restarts shake session on config changes" $ do-            void $ skipManyTill anyMessage $ message SClientRegisterCapability-            void $ createDoc "A.hs" "haskell" "module A where"-            waitForProgressDone-            sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String)))-            skipManyTill anyMessage restartingBuildSession--    ]-  where-    restartingBuildSession :: Session ()-    restartingBuildSession = do-        FromServerMess SWindowLogMessage NotificationMessage{_params = LogMessageParams{..}} <- loggingNotification-        guard $ "Restarting build session" `T.isInfixOf` _message--referenceTests :: TestTree-referenceTests = testGroup "references"-    [ testGroup "can get references to FOIs"-          [ referenceTest "can get references to symbols"-                          ("References.hs", 4, 7)-                          YesIncludeDeclaration-                          [ ("References.hs", 4, 6)-                          , ("References.hs", 6, 0)-                          , ("References.hs", 6, 14)-                          , ("References.hs", 9, 7)-                          , ("References.hs", 10, 11)-                          ]--          , referenceTest "can get references to data constructor"-                          ("References.hs", 13, 2)-                          YesIncludeDeclaration-                          [ ("References.hs", 13, 2)-                          , ("References.hs", 16, 14)-                          , ("References.hs", 19, 21)-                          ]--          , referenceTest "getting references works in the other module"-                          ("OtherModule.hs", 6, 0)-                          YesIncludeDeclaration-                          [ ("OtherModule.hs", 6, 0)-                          , ("OtherModule.hs", 8, 16)-                          ]--          , referenceTest "getting references works in the Main module"-                          ("Main.hs", 9, 0)-                          YesIncludeDeclaration-                          [ ("Main.hs", 9, 0)-                          , ("Main.hs", 10, 4)-                          ]--          , referenceTest "getting references to main works"-                          ("Main.hs", 5, 0)-                          YesIncludeDeclaration-                          [ ("Main.hs", 4, 0)-                          , ("Main.hs", 5, 0)-                          ]--          , referenceTest "can get type references"-                          ("Main.hs", 9, 9)-                          YesIncludeDeclaration-                          [ ("Main.hs", 9, 0)-                          , ("Main.hs", 9, 9)-                          , ("Main.hs", 10, 0)-                          ]--          , expectFailBecause "references provider does not respect includeDeclaration parameter" $- referenceTest "works when we ask to exclude declarations"-                          ("References.hs", 4, 7)-                          NoExcludeDeclaration-                          [ ("References.hs", 6, 0)-                          , ("References.hs", 6, 14)-                          , ("References.hs", 9, 7)-                          , ("References.hs", 10, 11)-                          ]--          , referenceTest "INCORRECTLY returns declarations when we ask to exclude them"-                          ("References.hs", 4, 7)-                          NoExcludeDeclaration-                          [ ("References.hs", 4, 6)-                          , ("References.hs", 6, 0)-                          , ("References.hs", 6, 14)-                          , ("References.hs", 9, 7)-                          , ("References.hs", 10, 11)-                          ]-          ]--    , testGroup "can get references to non FOIs"-          [ referenceTest "can get references to symbol defined in a module we import"-                          ("References.hs", 22, 4)-                          YesIncludeDeclaration-                          [ ("References.hs", 22, 4)-                          , ("OtherModule.hs", 0, 20)-                          , ("OtherModule.hs", 4, 0)-                          ]--          , referenceTest "can get references in modules that import us to symbols we define"-                          ("OtherModule.hs", 4, 0)-                          YesIncludeDeclaration-                          [ ("References.hs", 22, 4)-                          , ("OtherModule.hs", 0, 20)-                          , ("OtherModule.hs", 4, 0)-                          ]--          , referenceTest "can get references to symbol defined in a module we import transitively"-                          ("References.hs", 24, 4)-                          YesIncludeDeclaration-                          [ ("References.hs", 24, 4)-                          , ("OtherModule.hs", 0, 48)-                          , ("OtherOtherModule.hs", 2, 0)-                          ]--          , referenceTest "can get references in modules that import us transitively to symbols we define"-                          ("OtherOtherModule.hs", 2, 0)-                          YesIncludeDeclaration-                          [ ("References.hs", 24, 4)-                          , ("OtherModule.hs", 0, 48)-                          , ("OtherOtherModule.hs", 2, 0)-                          ]--          , referenceTest "can get type references to other modules"-                          ("Main.hs", 12, 10)-                          YesIncludeDeclaration-                          [ ("Main.hs", 12, 7)-                          , ("Main.hs", 13, 0)-                          , ("References.hs", 12, 5)-                          , ("References.hs", 16, 0)-                          ]-          ]-    ]---- | When we ask for all references to symbol "foo", should the declaration "foo--- = 2" be among the references returned?-data IncludeDeclaration =-    YesIncludeDeclaration-    | NoExcludeDeclaration--getReferences' :: SymbolLocation -> IncludeDeclaration -> Session (List Location)-getReferences' (file, l, c) includeDeclaration = do-    doc <- openDoc file "haskell"-    getReferences doc (Position l c) $ toBool includeDeclaration-    where toBool YesIncludeDeclaration = True-          toBool NoExcludeDeclaration  = False--referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree-referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do-  -- 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-        List 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 . to fromIntegral-                                   , location ^. L.range . L.start . L.character . to fromIntegral))-            $ Set.fromList actual-    expected' <- Set.fromList <$>-        (forM expected $ \(file, l, c) -> do-                              fp <- canonicalizePath file-                              return (filePathToUri fp, l, c))-    actual' @?= expected'--------------------------------------------------------------------------- Utils-------------------------------------------------------------------------testSession :: String -> Session () -> TestTree-testSession name = testCase name . run--testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree-testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix--testSession' :: String -> (FilePath -> Session ()) -> TestTree-testSession' name = testCase name . run'--testSessionWait :: 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)--pickActionWithTitle :: T.Text -> [Command |? CodeAction] -> IO CodeAction-pickActionWithTitle title actions = do-  assertBool ("Found no matching actions for " <> show title <> " in " <> show titles) (not $ null matches)-  return $ head matches-  where-    titles =-        [ actionTitle-        | InR CodeAction { _title = actionTitle } <- actions-        ]-    matches =-        [ action-        | InR action@CodeAction { _title = actionTitle } <- actions-        , title == actionTitle-        ]--mkRange :: UInt -> UInt -> UInt -> UInt -> Range-mkRange a b c d = Range (Position a b) (Position c d)--run :: Session a -> IO a-run s = run' (const s)--runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a-runWithExtraFiles prefix s = withTempDir $ \dir -> do-  copyTestDataFiles dir prefix-  runInDir dir (s dir)--copyTestDataFiles :: FilePath -> FilePath -> IO ()-copyTestDataFiles dir prefix = do-  -- Copy all the test data files to the temporary workspace-  testDataFiles <- getDirectoryFilesIO ("test/data" </> prefix) ["//*"]-  for_ testDataFiles $ \f -> do-    createDirectoryIfMissing True $ dir </> takeDirectory f-    copyFile ("test/data" </> prefix </> f) (dir </> f)--run' :: (FilePath -> Session a) -> IO a-run' s = withTempDir $ \dir -> runInDir dir (s dir)--runInDir :: FilePath -> Session a -> IO a-runInDir dir = runInDir' dir "." "." []--withLongTimeout :: IO a -> IO a-withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT")---- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root.-runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a-runInDir' = 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", "--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---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--lspTestCaps :: ClientCapabilities-lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing }--lspTestCapsNoFileWatches :: ClientCapabilities-lspTestCapsNoFileWatches = lspTestCaps & workspace . Lens._Just . didChangeWatchedFiles .~ Nothing--openTestDataDoc :: FilePath -> Session TextDocumentIdentifier-openTestDataDoc path = do-  source <- liftIO $ readFileUtf8 $ "test/data" </> path-  createDoc path "haskell" source--findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]-findCodeActions = findCodeActions' (==) "is not a superset of"--findCodeActionsByPrefix :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]-findCodeActionsByPrefix = findCodeActions' T.isPrefixOf "is not prefix of"--findCodeActions' :: (T.Text -> T.Text -> Bool) -> String -> TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]-findCodeActions' op errMsg doc range expectedTitles = do-  actions <- getCodeActions doc range-  let matches = sequence-        [ listToMaybe-          [ action-          | InR action@CodeAction { _title = actionTitle } <- actions-          , expectedTitle `op` actionTitle]-        | expectedTitle <- expectedTitles]-  let msg = show-            [ actionTitle-            | InR CodeAction { _title = actionTitle } <- actions-            ]-            ++ " " <> errMsg <> " "-            ++ show expectedTitles-  liftIO $ case matches of-    Nothing -> assertFailure msg-    Just _  -> pure ()-  return (fromJust matches)--findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction-findCodeAction doc range t = head <$> findCodeActions doc range [t]--unitTests :: Recorder (WithPriority Log) -> Logger -> TestTree-unitTests 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-               { _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 sequentially" $ do-        orderRef <- newIORef []-        let plugins = pluginDescToIdePlugins $-                [ (defaultPluginDescriptor $ fromString $ show i)-                    { pluginNotificationHandlers = mconcat-                        [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ \_ _ _ _ ->-                            liftIO $ atomicModifyIORef_ orderRef (i:)-                        ]-                    }-                    | i <- [(1::Int)..20]-                ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder)--        testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger){IDE.argsHlsPlugins = plugins} $ do-            _ <- createDoc "haskell" "A.hs" "module A where"-            waitForProgressDone-            actualOrder <- liftIO $ readIORef orderRef--            liftIO $ actualOrder @?= reverse [(1::Int)..20]-     , 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-     ]--garbageCollectionTests :: TestTree-garbageCollectionTests = 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 Nothing Nothing edit]-            builds <- waitForTypecheck doc-            liftIO $ assertBool "it still builds" builds-            expectCurrentDiagnostics doc [(DsError, (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--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)---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----positionMappingTests :: TestTree-positionMappingTests =-    testGroup "position mapping"-        [ testGroup "toCurrent"-              [ testCase "before" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "ab"-                    (Position 0 0) @?= PositionExact (Position 0 0)-              , testCase "after, same line, same length" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "ab"-                    (Position 0 3) @?= PositionExact (Position 0 3)-              , testCase "after, same line, increased length" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc"-                    (Position 0 3) @?= PositionExact (Position 0 4)-              , testCase "after, same line, decreased length" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "a"-                    (Position 0 3) @?= PositionExact (Position 0 2)-              , testCase "after, next line, no newline" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc"-                    (Position 1 3) @?= PositionExact (Position 1 3)-              , testCase "after, next line, newline" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc\ndef"-                    (Position 1 0) @?= PositionExact (Position 2 0)-              , testCase "after, same line, newline" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc\nd"-                    (Position 0 4) @?= PositionExact (Position 1 2)-              , testCase "after, same line, newline + newline at end" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc\nd\n"-                    (Position 0 4) @?= PositionExact (Position 2 1)-              , testCase "after, same line, newline + newline at end" $-                toCurrent-                    (Range (Position 0 1) (Position 0 1))-                    "abc"-                    (Position 0 1) @?= PositionExact (Position 0 4)-              ]-        , testGroup "fromCurrent"-              [ testCase "before" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "ab"-                    (Position 0 0) @?= PositionExact (Position 0 0)-              , testCase "after, same line, same length" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "ab"-                    (Position 0 3) @?= PositionExact (Position 0 3)-              , testCase "after, same line, increased length" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc"-                    (Position 0 4) @?= PositionExact (Position 0 3)-              , testCase "after, same line, decreased length" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "a"-                    (Position 0 2) @?= PositionExact (Position 0 3)-              , testCase "after, next line, no newline" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc"-                    (Position 1 3) @?= PositionExact (Position 1 3)-              , testCase "after, next line, newline" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc\ndef"-                    (Position 2 0) @?= PositionExact (Position 1 0)-              , testCase "after, same line, newline" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc\nd"-                    (Position 1 2) @?= PositionExact (Position 0 4)-              , testCase "after, same line, newline + newline at end" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc\nd\n"-                    (Position 2 1) @?= PositionExact (Position 0 4)-              , testCase "after, same line, newline + newline at end" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 1))-                    "abc"-                    (Position 0 4) @?= PositionExact (Position 0 1)-              ]-        , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties"-              [ testProperty "fromCurrent r t <=< toCurrent r t" $ do-                -- Note that it is important to use suchThatMap on all values at once-                -- instead of only using it on the position. Otherwise you can get-                -- into situations where there is no position that can be mapped back-                -- for the edit which will result in QuickCheck looping forever.-                let gen = do-                        rope <- genRope-                        range <- genRange rope-                        PrintableText replacement <- arbitrary-                        oldPos <- genPosition rope-                        pure (range, replacement, oldPos)-                forAll-                    (suchThatMap gen-                        (\(range, replacement, oldPos) -> positionResultToMaybe $ (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $-                    \(range, replacement, oldPos, newPos) ->-                    fromCurrent range replacement newPos === PositionExact oldPos-              , testProperty "toCurrent r t <=< fromCurrent r t" $ do-                let gen = do-                        rope <- genRope-                        range <- genRange rope-                        PrintableText replacement <- arbitrary-                        let newRope = applyChange rope (TextDocumentContentChangeEvent (Just range) Nothing replacement)-                        newPos <- genPosition newRope-                        pure (range, replacement, newPos)-                forAll-                    (suchThatMap gen-                        (\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $-                    \(range, replacement, newPos, oldPos) ->-                    toCurrent range replacement oldPos === PositionExact newPos-              ]-        ]--newtype PrintableText = PrintableText { getPrintableText :: T.Text }-    deriving Show--instance Arbitrary PrintableText where-    arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary---genRope :: Gen Rope-genRope = Rope.fromText . getPrintableText <$> arbitrary--genPosition :: Rope -> Gen Position-genPosition r = do-    let rows = Rope.rows r-    row <- choose (0, max 0 $ rows - 1) `suchThat` inBounds @UInt-    let columns = Rope.columns (nthLine 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 = Rope.rows 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 = Rope.columns (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 -> Rope-nthLine i r-    | i < 0 = error $ "Negative line number: " <> show i-    | i == 0 && Rope.rows r == 0 = r-    | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)-    | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r--getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions]-getWatchedFilesSubscriptionsUntil m = do-      msgs <- manyTill (Just <$> message SClientRegisterCapability <|> Nothing <$ anyMessage) (message m)-      return-            [ args-            | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs-            , SomeRegistration (Registration _id SWorkspaceDidChangeWatchedFiles args) <- regs-            ]---- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path--- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or--- @/var@-withTempDir :: (FilePath -> IO a) -> IO a-withTempDir f = System.IO.Extra.withTempDir $ \dir -> do-  dir' <- canonicalizePath dir-  f dir'---- | Assert that a value is not 'Nothing', and extract the value.-assertJust :: MonadIO m => String -> Maybe a -> m a-assertJust s = \case-  Nothing -> liftIO $ assertFailure s-  Just x  -> pure x---- | 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]"---- | Ghc 9 doesn't include the $-sign in TH warnings like earlier versions did-thDollarIdx :: UInt-thDollarIdx | ghcVersion >= GHC90 = 1-            | otherwise = 0
− 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/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,280 +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-  , getBuildKeysBuilt-  , getBuildKeysVisited-  , getBuildKeysChanged-  , getBuildEdgesCount-  , getRebuildsCount-  , 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.Text                       (Text)-import qualified Data.Text                       as T-import           Development.IDE.Plugin.Test     (TestRequest (..),-                                                  WaitForIdeRuleResult,-                                                  ideResultSuccess)-import           Development.IDE.Test.Diagnostic-import           Ide.Plugin.Config               (CheckParents, checkProject)-import           Language.LSP.Test               hiding (message)-import qualified Language.LSP.Test               as LspTest-import           Language.LSP.Types              hiding-                                                 (SemanticTokenAbsolute (length, line),-                                                  SemanticTokenRelative (length),-                                                  SemanticTokensEdit (_start))-import           Language.LSP.Types.Lens         as Lsp-import           System.Directory                (canonicalizePath)-import           System.Time.Extra-import           Test.Tasty.HUnit-import System.FilePath (equalFilePath)--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 STextDocumentPublishDiagnostics timeout $ \diagsNot -> do-    let fileUri = diagsNot ^. params . uri-        actual = diagsNot ^. params . diagnostics-    liftIO $-      assertFailure $-        "Got unexpected diagnostics for " <> show fileUri-          <> " got "-          <> show actual--expectMessages :: SMethod m -> Seconds -> (ServerMessage m -> Session ()) -> Session ()-expectMessages m timeout handle = do-    -- Give any further diagnostic messages time to arrive.-    liftIO $ sleep timeout-    -- Send a dummy message to provoke a response from the server.-    -- This guarantees that we have at least one message to-    -- process, so message won't block or timeout.-    let cm = SCustomMethod "test"-    i <- sendRequest cm $ A.toJSON GetShakeSessionQueueCount-    go cm i-  where-    go cm i = handleMessages-      where-        handleMessages = (LspTest.message m >>= handle) <|> (void $ responseForId cm i) <|> ignoreOthers-        ignoreOthers = void anyMessage >> handleMessages--flushMessages :: Session ()-flushMessages = do-    let cm = SCustomMethod "non-existent-method"-    i <- sendRequest cm A.Null-    void (responseForId cm i) <|> ignoreOthers cm i-    where-        ignoreOthers cm i = skipManyTill anyMessage (responseForId cm i) >> flushMessages---- | It is not possible to use 'expectDiagnostics []' to assert the absence of diagnostics,---   only that existing diagnostics have been cleared.------   Rather than trying to assert the absence of diagnostics, introduce an---   expected diagnostic (e.g. a redundant import) and assert the singleton diagnostic.-expectDiagnostics :: HasCallStack => [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()-expectDiagnostics-  = expectDiagnosticsWithTags-  . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing))))--unwrapDiagnostic :: NotificationMessage TextDocumentPublishDiagnostics  -> (Uri, List Diagnostic)-unwrapDiagnostic diagsNot = (diagsNot^.params.uri, diagsNot^.params.diagnostics)--expectDiagnosticsWithTags :: 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, List Diagnostic) ->-  Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] ->-  m ()-expectDiagnosticsWithTags' next m | null m = do-    (_,actual) <- next-    case actual of-        List [] ->-            return ()-        _ ->-            liftIO $ assertFailure $ "Got unexpected diagnostics:" <> show actual--expectDiagnosticsWithTags' next expected = go expected-  where-    go m-      | Map.null m = pure ()-      | otherwise = do-        (fileUri, actual) <- next-        canonUri <- liftIO $ toNormalizedUri <$> canonicalizeUri fileUri-        case Map.lookup canonUri m of-          Nothing -> do-            liftIO $-              assertFailure $-                "Got diagnostics for " <> show fileUri-                  <> " but only expected diagnostics for "-                  <> show (Map.keys m)-                  <> " got "-                  <> show actual-          Just expected -> do-            liftIO $ mapM_ (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, List obtained)) expected'--canonicalizeUri :: Uri -> IO Uri-canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePath uri))--diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics)-diagnostic = LspTest.message STextDocumentPublishDiagnostics--tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)-tryCallTestPlugin cmd = do-    let cm = SCustomMethod "test"-    waitId <- sendRequest cm (A.toJSON cmd)-    ResponseMessage{_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)--getBuildKeysBuilt :: Session (Either ResponseError [T.Text])-getBuildKeysBuilt = tryCallTestPlugin GetBuildKeysBuilt--getBuildKeysVisited :: Session (Either ResponseError [T.Text])-getBuildKeysVisited = tryCallTestPlugin GetBuildKeysVisited--getBuildKeysChanged :: Session (Either ResponseError [T.Text])-getBuildKeysChanged = tryCallTestPlugin GetBuildKeysChanged--getBuildEdgesCount :: Session (Either ResponseError Int)-getBuildEdgesCount = tryCallTestPlugin GetBuildEdgesCount--getRebuildsCount :: Session (Either ResponseError Int)-getRebuildsCount = tryCallTestPlugin GetRebuildsCount--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 (SCustomMethod lbl) (NotMess NotificationMessage{_params = value})-            | lbl == 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 =-    sendNotification SWorkspaceDidChangeConfiguration-        (DidChangeConfigurationParams $ 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 (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params})-    | A.Success fp <- A.fromJSON _params-    , pred fp-    -> 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.Types-import           Language.LSP.Types.Lens as Lsp---- | (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 (List DiagnosticTag) -> Bool-    hasTag Nothing  _                          = True-    hasTag (Just _) Nothing                    = False-    hasTag (Just actualTag) (Just (List tags)) = actualTag `elem` tags--standardizeQuotes :: T.Text -> T.Text-standardizeQuotes msg = let-        repl '‘' = '\''-        repl '’' = '\''-        repl '`' = '\''-        repl  c  = c-    in  T.map repl msg