packages feed

haskell-language-server 2.14.0.0 → 2.15.0.0

raw patch · 338 files changed

+9448/−3171 lines, 338 filesdep +exceptionsdep +table-layoutdep −retriedep ~basedep ~extradep ~fourmolu

Dependencies added: exceptions, table-layout

Dependencies removed: retrie

Dependency ranges changed: base, extra, fourmolu, ghc-exactprint, ghcide, hls-graph, hls-plugin-api, hls-test-utils, lsp, lsp-types, mtl

Files

ChangeLog.md view
@@ -1,5 +1,185 @@ # Changelog for haskell-language-server +## 2.15.0.0++- Remove `hls-retrie-plugin`+- Add `hls-case-split-plugin`+- Add `hls-export-plugin`+- Enable `hls-semantic-tokens-plugin` by default+- Prefer multi-component loading by default+- Replace the `sessionLoading` config with `componentsLoading`+- Support for Ormolu and Fourmolu on GHC 9.14+- Improvements to ghcide+  - Point documentation and source links at Hackage+  - Stop unloading all bytecode whenever new bytecode is generated+  - Unload linkables when any transitive dependency changes+- Improvements to `hls-rename-plugin`+  - Improved limited cross-module renaming+- Improvements to `hls-refactor-plugin`+  - Code action to delete all unused bindings, including `let` bindings+- Improvements to `hls-eval-plugin`+  - Capture `stdout` and `stderr` from evaluated expressions+- Improvements to `hls-splice-plugin`+  - Support declaration splices+- Optimizations+  - Speed up dependency graph building+  - Load core files on demand and improve freshness checking+- Bug fixes+  - Correct code action edits across several plugins+  - Match GHC when resolving imports and boot files+  - Avoid serving stale completions, documentation and diagnostics++### Pull Requests++- Split module interface rule into interface and code outputs+  ([#5057](https://github.com/haskell/haskell-language-server/pull/5057)) by @crtschin+- Show built keys by rule in `ghcide-bench` summary+  ([#5055](https://github.com/haskell/haskell-language-server/pull/5055)) by @crtschin+- docs: updated moved nvim-lspconfig page+  ([#5051](https://github.com/haskell/haskell-language-server/pull/5051)) by @LanHikari22+- Delete unused `CodeAction.RuleTypes` module+  ([#5050](https://github.com/haskell/haskell-language-server/pull/5050)) by @crtschin+- Keep only the core file hash in `HiFileResult`+  ([#5048](https://github.com/haskell/haskell-language-server/pull/5048)) by @crtschin+- Change `rangesOverlap` to honor the fact that `Range`s are inclusive to the left but exclusive to the right+  ([#5047](https://github.com/haskell/haskell-language-server/pull/5047)) by @Aster89+- Use a unique id for each file watcher registration+  ([#5043](https://github.com/haskell/haskell-language-server/pull/5043)) by @crtschin+- Simplify `activeDiagnosticsInRange` by returning `[FileDiagnostic]` instead of `Maybe [FileDiagnostic]`+  ([#5041](https://github.com/haskell/haskell-language-server/pull/5041)) by @Aster89+- Unload linkables if any transitive dependency changes+  ([#5035](https://github.com/haskell/haskell-language-server/pull/5035)) by @wz1000+- Stop unloading all bytecode whenever we generate new bytecode+  ([#5033](https://github.com/haskell/haskell-language-server/pull/5033)) by @wz1000+- cross-module renames+  ([#5031](https://github.com/haskell/haskell-language-server/pull/5031)) by @Esgariot+- Set FileCache hook before typechecking+  ([#5030](https://github.com/haskell/haskell-language-server/pull/5030)) by @fendor+- Improve error messages in HLS+  ([#5029](https://github.com/haskell/haskell-language-server/pull/5029)) by @fendor+- Fix invalid non-singleton constraint suggestion edits+  ([#5028](https://github.com/haskell/haskell-language-server/pull/5028)) by @crtschin+- Some improvements of comments, of code, and return->pure+  ([#5026](https://github.com/haskell/haskell-language-server/pull/5026)) by @Aster89+- Build CI with `--jobs` and `--semaphore`+  ([#5022](https://github.com/haskell/haskell-language-server/pull/5022)) by @crtschin+- Bump fkirc/skip-duplicate-actions from 5.3.1 to 5.3.2+  ([#5019](https://github.com/haskell/haskell-language-server/pull/5019)) by @dependabot[bot]+- Isolate per-test caches via explicit args instead of `XDG_CACHE_HOME`+  ([#5018](https://github.com/haskell/haskell-language-server/pull/5018)) by @crtschin+- Restrict batch session loads to files owned by the same cradle+  ([#5017](https://github.com/haskell/haskell-language-server/pull/5017)) by @simonhorlick+- Workaround for semantic tokens on Windows with CPP+  ([#5016](https://github.com/haskell/haskell-language-server/pull/5016)) by @Abbath+- Case split plugin+  ([#5014](https://github.com/haskell/haskell-language-server/pull/5014)) by @Aster89+- Fix stale completions after changing an import alias+  ([#5011](https://github.com/haskell/haskell-language-server/pull/5011)) by @BurningLutz+- Ormolu & Fourmolu on GHC 9.14+  ([#5009](https://github.com/haskell/haskell-language-server/pull/5009)) by @kafji+- bugfix(ghc optimization option): set optimization level to 0 to eval properly+  ([#5008](https://github.com/haskell/haskell-language-server/pull/5008)) by @abdivasiyev+- fix(hls-eval-plugin): hardcode QckChck to eval property tests+  ([#5007](https://github.com/haskell/haskell-language-server/pull/5007)) by @abdivasiyev+- adding whole-project loading+  ([#5002](https://github.com/haskell/haskell-language-server/pull/5002)) by @Saizan+- Enable semantic tokens plugin by default+  ([#5000](https://github.com/haskell/haskell-language-server/pull/5000)) by @soulomoon+- Nix shell for ghc9.14+  ([#4998](https://github.com/haskell/haskell-language-server/pull/4998)) by @dyniec+- Docs: update Kakoune configuration instructions+  ([#4997](https://github.com/haskell/haskell-language-server/pull/4997)) by @ficd0+- Bump actions/checkout to v7+  ([#4995](https://github.com/haskell/haskell-language-server/pull/4995)) by @fendor+- Bump actions/cache from 5 to 6 in /.github/actions/setup-build+  ([#4994](https://github.com/haskell/haskell-language-server/pull/4994)) by @dependabot[bot]+- Bump actions/cache from 5 to 6+  ([#4993](https://github.com/haskell/haskell-language-server/pull/4993)) by @dependabot[bot]+- Add `Unexport ...` to `hls-export-plugin`+  ([#4991](https://github.com/haskell/haskell-language-server/pull/4991)) by @crtschin+- Remove @santiweight from CODEOWNERS for hls-refactor-plugin+  ([#4984](https://github.com/haskell/haskell-language-server/pull/4984)) by @santiweight+- Remove CI workaround for ghcup GH runner issue+  ([#4982](https://github.com/haskell/haskell-language-server/pull/4982)) by @crtschin+- Splice export modifications precisely when using CPP+  ([#4981](https://github.com/haskell/haskell-language-server/pull/4981)) by @crtschin+- Bump GHA versions+  ([#4980](https://github.com/haskell/haskell-language-server/pull/4980)) by @fendor+- Support fourmolu 0.20.0.0+  ([#4979](https://github.com/haskell/haskell-language-server/pull/4979)) by @brandonchinn178+- Support symbolic record fields when converting to record syntax+  ([#4978](https://github.com/haskell/haskell-language-server/pull/4978)) by @olaberglund+- Fix running `cabal test all` as a local workflow+  ([#4974](https://github.com/haskell/haskell-language-server/pull/4974)) by @crtschin+- Extend delete-unused-bindings to let-expression bindings+  ([#4972](https://github.com/haskell/haskell-language-server/pull/4972)) by @olaberglund+- Try getting rid of `withWarnings` in `~Compile.hs`+  ([#4971](https://github.com/haskell/haskell-language-server/pull/4971)) by @Aster89+- Remove `LD_LIBRARY_PATH` override in nix `devShell`+  ([#4966](https://github.com/haskell/haskell-language-server/pull/4966)) by @crtschin+- Fix: make subsumesEither commutative+  ([#4964](https://github.com/haskell/haskell-language-server/pull/4964)) by @olaberglund+- Remove unused test-logs directory+  ([#4960](https://github.com/haskell/haskell-language-server/pull/4960)) by @crtschin+- Change HLS default to prefer multi-component loading+  ([#4959](https://github.com/haskell/haskell-language-server/pull/4959)) by @xsebek+- Code action to delete all unused bindings+  ([#4958](https://github.com/haskell/haskell-language-server/pull/4958)) by @olaberglund+- nix-flake: Update inputs+  ([#4956](https://github.com/haskell/haskell-language-server/pull/4956)) by @akshaymankar+- Add support for extra LSP options+  ([#4955](https://github.com/haskell/haskell-language-server/pull/4955)) by @VeryMilkyJoe+- Use defaultTestRunner in ghcide-test+  ([#4953](https://github.com/haskell/haskell-language-server/pull/4953)) by @xsebek+- Create `hls-export-plugin` with `Export '...'` code action+  ([#4952](https://github.com/haskell/haskell-language-server/pull/4952)) by @crtschin+- use knownBuildTypes to populate completion targets+  ([#4950](https://github.com/haskell/haskell-language-server/pull/4950)) by @olaberglund+- Fix accidentally deleting the installed GHC in CI+  ([#4947](https://github.com/haskell/haskell-language-server/pull/4947)) by @crtschin+- Fix `transitiveReverseDependencies` recursion+  ([#4946](https://github.com/haskell/haskell-language-server/pull/4946)) by @crtschin+- Fix hls-class-plugin indentation+  ([#4937](https://github.com/haskell/haskell-language-server/pull/4937)) by @Aster89+- Never compute the DocMap with stale data+  ([#4936](https://github.com/haskell/haskell-language-server/pull/4936)) by @fendor+- Add typing burst benchmark coverage+  ([#4934](https://github.com/haskell/haskell-language-server/pull/4934)) by @soulomoon+- Avoid relying on `OccNames` when generating class methods+  ([#4932](https://github.com/haskell/haskell-language-server/pull/4932)) by @crtschin+- Fixbench+  ([#4928](https://github.com/haskell/haskell-language-server/pull/4928)) by @soulomoon+- ghcide-2.14 requires extra >= 1.8+  ([#4926](https://github.com/haskell/haskell-language-server/pull/4926)) by @juhp+- Add build-type: Hooks to Cabal completion plugin+  ([#4920](https://github.com/haskell/haskell-language-server/pull/4920)) by @sheaf+- Avoid logging `AsyncCancelled` stacktraces on session restart+  ([#4919](https://github.com/haskell/haskell-language-server/pull/4919)) by @crtschin+- Use pretty printing context when expanding records+  ([#4917](https://github.com/haskell/haskell-language-server/pull/4917)) by @crtschin+- Update splice plugin+  ([#4915](https://github.com/haskell/haskell-language-server/pull/4915)) by @georgefst+- Mark boot files to load first in `ghcSessionDepsDefinition`+  ([#4914](https://github.com/haskell/haskell-language-server/pull/4914)) by @martijnbastiaan+- Account for boot files in `processDependencyInformation`+  ([#4913](https://github.com/haskell/haskell-language-server/pull/4913)) by @martijnbastiaan+- Exclude superclass-generated names in class placeholders+  ([#4902](https://github.com/haskell/haskell-language-server/pull/4902)) by @crtschin+- Only check for garbage in key garbage collection test+  ([#4900](https://github.com/haskell/haskell-language-server/pull/4900)) by @crtschin+- Prepare release 2.14.0.0+  ([#4897](https://github.com/haskell/haskell-language-server/pull/4897)) by @wz1000+- Remove `hls-retrie-plugin`+  ([#4839](https://github.com/haskell/haskell-language-server/pull/4839)) by @omarjatoi+- Use Hackage for Documentation and Source links+  ([#4746](https://github.com/haskell/haskell-language-server/pull/4746)) by @Saizan+- Capture output of `eval` plugin and some girls scout changes+  ([#4726](https://github.com/haskell/haskell-language-server/pull/4726)) by @dschrempf+- Migrate `hls-refactor-plugin` to use structured diagnostics+  ([#4708](https://github.com/haskell/haskell-language-server/pull/4708)) by @dyniec+- Optimise module to filename+  ([#4600](https://github.com/haskell/haskell-language-server/pull/4600)) by @guibou+ ## 2.14.0.0  - Bindists for GHC 9.14.1
bench/Main.hs view
@@ -20,14 +20,12 @@     |       └── <HLS plugin>     │           ├── <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+    └── resultDiff.csv     - diff of aggregated results compared with previous version -   For diff graphs, the "previous version" is the preceding entry in the list of versions+   For diff results, 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:@@ -36,8 +34,8 @@     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"+   > stack bench --ba "bench-results/HEAD/results.csv"+   > cabal bench --benchmark-options "bench-results/HEAD/results.csv"   -} {-# LANGUAGE DeriveAnyClass     #-}@@ -165,8 +163,6 @@   benchRules build (MkBenchRules (askOracle $ GetSamples ()) benchHls warmupHls "haskell-language-server" (parallelism configStatic))   addGetParentOracle   csvRules build-  svgRules build-  heapProfileRules build   phonyRules "" binaryName NoProfiling build (examples configStatic)    whenJust (profileInterval configStatic) $ \i -> do
docs/contributing/plugin-tutorial.lhs view
@@ -16,8 +16,6 @@ 1. Suggest imports for variables not in scope, 2. Remove redundant imports, 3. Evaluate code in comments (à la [doctest](https://docs.python.org/3/library/doctest.html)),-4. Integrate the [retrie](https://github.com/facebookincubator/retrie) refactoring library.- These plugins are small but meaningful steps towards a more polished IDE experience. While writing them, I didn't have to worry about performance, UI, or distribution; another tool (usually GHC) always did the heavy lifting. @@ -77,7 +75,6 @@  - The `ormolu`, `fourmolu`, and `stylish-haskell` plugins used to format code - The `eval` plugin, a code lens provider to evaluate code in comments-- The `retrie` plugin, a code action provider to execute retrie commands  I recommend looking at the existing plugins for inspiration and reference. A few conventions shared by all plugins are: @@ -98,7 +95,6 @@         , Fourmolu.descriptor "fourmolu"         , Ormolu.descriptor "ormolu"         , StylishHaskell.descriptor "stylish-haskell"-        , Retrie.descriptor "retrie"         , Eval.descriptor "eval"         , NewPlugin.descriptor "new-plugin" -- Add new plugins here.         ]
exe/Main.hs view
@@ -1,10 +1,14 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0+{-# LANGUAGE CPP               #-} {-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedStrings #-} module Main(main) where  import           Control.Exception             (displayException)+#if MIN_VERSION_base(4,20,0)+import qualified Control.Exception.Backtrace   as Backtrace+#endif import           Control.Monad.IO.Class        (liftIO) import           Data.Bifunctor                (first) import           Data.Function                 ((&))@@ -45,6 +49,9 @@  main :: IO () main = do+#if MIN_VERSION_base(4,20,0)+    Backtrace.setBacktraceMechanismState Backtrace.IPEBacktrace True+#endif     stderrRecorder <- makeDefaultStderrRecorder Nothing     -- plugin cli commands use stderr logger for now unless we change the args     -- parser to get logging arguments first or do more complicated things
ghcide-bench/src/Experiments.hs view
@@ -40,10 +40,13 @@ import qualified Data.ByteString.Lazy               as BSL import           Data.Either                        (fromRight) import           Data.List+import           Data.List.Extra                    (groupSort) import           Data.Maybe+import           Data.Ord                           (Down (..)) import           Data.Proxy import           Data.Text                          (Text) import qualified Data.Text                          as T+import qualified Data.Text.IO                       as TIO import           Data.Version import           Development.IDE.Plugin.Test import           Development.IDE.Test.Diagnostic@@ -64,6 +67,9 @@ import           System.IO import           System.Process import           System.Time.Extra+import           Text.Layout.Table                  (columnHeaderTableS, def,+                                                     rowsG, tableLines, titlesH)+import           Text.Layout.Table.Style            (asciiS) import           Text.ParserCombinators.ReadP       (readP_to_S) import           Text.Printf @@ -83,6 +89,12 @@         , _text = "-- header comment \n"         } +typingBurstEditCount :: Int+typingBurstEditCount = 5++typingBurstDelay :: Seconds+typingBurstDelay = 0.25+ data DocumentPositions = DocumentPositions {     -- | A position that can be used to generate non null goto-def and completion responses     identifierP    :: Maybe Position,@@ -100,6 +112,14 @@   where     applicableDocs = filter (isJust . identifierP) docs +applyTypingBurst :: [DocumentPositions] -> Session ()+applyTypingBurst docs =+    forM_ [1..typingBurstEditCount] $ \n -> do+        forM_ docs $ \DocumentPositions{..} ->+            changeDoc doc [charEdit stringLiteralP]+        when (n < typingBurstEditCount) $+            liftIO $ sleep typingBurstDelay+ experiments :: HasConfig => [Bench] experiments =     [@@ -115,6 +135,15 @@                 Nothing -> return False         return $ and r,       ---------------------------------------------------------------------------------------+      bench "semanticTokens after typing burst" $ \docs -> do+        applyTypingBurst docs+        r <- forM docs $ \DocumentPositions{..} -> do+            tks <- getSemanticTokens doc+            case tks ^? LSP._L of+                Just _  -> return True+                Nothing -> return False+        return $ and r,+      ---------------------------------------------------------------------------------------       bench "hover" $ allWithIdentifierPos $ \DocumentPositions{..} ->         isJust <$> getHover doc (fromJust identifierP),       ---------------------------------------------------------------------------------------@@ -124,6 +153,11 @@         flip allWithIdentifierPos docs $ \DocumentPositions{..} ->           isJust <$> getHover doc (fromJust identifierP),       ---------------------------------------------------------------------------------------+      bench "hover after typing burst" $ \docs -> do+        applyTypingBurst docs+        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->+          isJust <$> getHover doc (fromJust identifierP),+      ---------------------------------------------------------------------------------------       bench         "hover after cradle edit"         (\docs -> do@@ -158,11 +192,16 @@         hasDefinitions <$> getDefinitions doc (fromJust identifierP),       ---------------------------------------------------------------------------------------       bench "getDefinition after edit" $ \docs -> do-          forM_ docs $ \DocumentPositions{..} ->-            changeDoc doc [charEdit stringLiteralP]-          flip allWithIdentifierPos docs $ \DocumentPositions{..} ->-            hasDefinitions <$> getDefinitions doc (fromJust identifierP),+        forM_ docs $ \DocumentPositions{..} ->+          changeDoc doc [charEdit stringLiteralP]+        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->+          hasDefinitions <$> getDefinitions doc (fromJust identifierP),       ---------------------------------------------------------------------------------------+      bench "getDefinition after typing burst" $ \docs -> do+        applyTypingBurst docs+        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->+          hasDefinitions <$> getDefinitions doc (fromJust identifierP),+      ---------------------------------------------------------------------------------------       bench "documentSymbols" $ allM $ \DocumentPositions{..} -> do         fmap (either (not . null) (not . null)) . getDocumentSymbols $ doc,       ---------------------------------------------------------------------------------------@@ -172,6 +211,11 @@         flip allM docs $ \DocumentPositions{..} ->           either (not . null) (not . null) <$> getDocumentSymbols doc,       ---------------------------------------------------------------------------------------+      bench "documentSymbols after typing burst" $ \docs -> do+        applyTypingBurst docs+        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),@@ -182,6 +226,11 @@         flip allWithIdentifierPos docs $ \DocumentPositions{..} ->           not . null <$> getCompletions doc (fromJust identifierP),       ---------------------------------------------------------------------------------------+      bench "completions after typing burst" $ \docs -> do+        applyTypingBurst docs+        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->+          not . null <$> getCompletions doc (fromJust identifierP),+      ---------------------------------------------------------------------------------------       bench         "code actions"         ( \docs -> do@@ -207,6 +256,17 @@         ),       ---------------------------------------------------------------------------------------       bench+        "code actions after typing burst"+        ( \docs -> do+            unless (any (isJust . identifierP) docs) $+                error "None of the example modules is suitable for this experiment"+            applyTypingBurst docs+            not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do+              forM identifierP $ \p ->+                getCodeActions doc (Range p p))+        ),+      ---------------------------------------------------------------------------------------+      bench         "code actions after cradle edit"         ( \docs -> do             hieYamlUri <- getDocUri "hie.yaml"@@ -317,7 +377,7 @@                     , ">>> xs = ([minBound..maxBound] ++ [minBound..maxBound] :: [T])"                     , ">>> nub xs"                     , "-}"-                    ]+                   ]             changeDoc doc [edit]         )         ( \docs -> do@@ -342,7 +402,7 @@ examplesPath = "bench/example"  defConfig :: Config-Success defConfig = execParserPure defaultPrefs (info configP fullDesc) []+Success defConfig = execParserPure defaultPrefs (info configP fullDesc) ["--example-name", "examples"]  quiet, verbose :: Config -> Bool verbose = (== All) . verbosity@@ -383,7 +443,7 @@        packageP = ExamplePackage             <$> strOption (long "example-package-name" <> value "Cabal")-            <*> option versionP (long "example-package-version" <> value (makeVersion [3,6,0,0]))+            <*> option versionP (long "example-package-version" <> value (makeVersion [3,16,1,0]))       pathOrScriptP = ExamplePath   <$> strOption (long "example-path")                   <|> ExampleScript <$> strOption (long "example-script") <*> many (strOption (long "example-script-args" <> help "arguments for the example generation script")) @@ -461,79 +521,15 @@                         runSessionWithHandles' (Just pH) inH outH conf lspTestCaps dir sess     (b,) <$> runBench run b -  -- output raw data as CSV-  let headers =-        [ "name"-        , "success"-        , "samples"-        , "startup"-        , "setup"-        , "userT"-        , "delayedT"-        , "1stBuildT"-        , "avgPerRespT"-        , "totalT"-        , "rulesBuilt"-        , "rulesChanged"-        , "rulesVisited"-        , "rulesTotal"-        , "ruleEdges"-        , "ghcRebuilds"-        ]-      rows =-        [ [ name,-            show success,-            show samples,-            showMs startup,-            showMs runSetup',-            showMs userWaits,-            showMs delayedWork,-            showMs $ 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-            showMs ((userWaits - firstResponse)/((fromIntegral samples - 1)*modules)),-            showMs 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+  let headers = map fst summaryColumns+      summaryRow showTime b r = [ renderCell showTime (cell b r) | (_, cell) <- summaryColumns ]+      csv = T.unlines $ map (T.intercalate ", ")+              (headers : [ summaryRow showMs b r | (b, r) <- results ])+  TIO.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+  mapM_ putStrLn $ ruleHistogram results+  mapM_ putStrLn $ renderTable headers+      [ summaryRow (T.pack . showDuration) b r | (b, r) <- results ]   where     ghcideArgs dir =         [ "--lsp",@@ -562,8 +558,8 @@         & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just) .~ (ClientCodeActionResolveOptions ["edit"])         & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ True -showMs :: Seconds -> String-showMs = printf "%.2f"+showMs :: Seconds -> Text+showMs = T.pack . printf "%.2f"  data BenchRun = BenchRun   { startup              :: !Seconds,@@ -574,6 +570,7 @@     firstResponse        :: !Seconds,     firstResponseDelayed :: !Seconds,     rulesBuilt           :: !Int,+    rulesBuiltByRule     :: ![(Text, Int)],     rulesChanged         :: !Int,     rulesVisited         :: !Int,     rulesTotal           :: !Int,@@ -583,7 +580,7 @@   }  badRun :: BenchRun-badRun = BenchRun 0 0 0 0 0 0 0 0 0 0 0 0 0 False+badRun = BenchRun 0 0 0 0 0 0 0 0 [] 0 0 0 0 0 False  waitForProgressStart :: Session () waitForProgressStart = void $ do@@ -651,7 +648,9 @@           (userWaits, delayedWork, (firstResponse, firstResponseDelayed)) = fromMaybe (0,0,(0,0)) result        rulesTotal <- length <$> getStoredKeys-      rulesBuilt <- either (const 0) length <$> getBuildKeysBuilt+      builtKeys <- fromRight [] <$> getBuildKeysBuilt+      let rulesBuilt = length builtKeys+          rulesBuiltByRule = ruleCounts builtKeys       rulesChanged <- either (const 0) length <$> getBuildKeysChanged       rulesVisited <- either (const 0) length <$> getBuildKeysVisited       edgesTotal   <- fromRight 0 <$> getBuildEdgesCount@@ -708,21 +707,20 @@             package = packageName <> "-" <> showVersion packageVersion             hieYamlPath = path </> "hie.yaml"         alreadySetup <- doesDirectoryExist path-        unless alreadySetup $-          case buildTool ?config of+        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"+                unless alreadySetup $+                    callCommandLogging $ "cabal get " <> cabalVerbosity <> " " <> package <> " -d " <> examplesPath                 writeFile hieYamlPath simpleCabalCradleContent                 -- Need this in case there is a parent cabal.project somewhere                 writeFile                     (path </> "cabal.project")-                    "packages: ."+                    (cabalProjectForPackage ExamplePackage{..})                 writeFile                     (path </> "cabal.project.local")                     ""-            Stack -> do+            Stack -> unless alreadySetup $ do                 let stackVerbosity = case verbosity ?config of                         Quiet  -> "--silent"                         Normal -> ""@@ -745,6 +743,11 @@                 writeFile hieYamlPath simpleStackCradleContent         return path +  checkExampleModulesExist benchDir (example ?config)+  case (buildTool ?config, exampleDetails (example ?config)) of+      (Cabal, ExampleHackage{}) -> buildCabalExample benchDir+      _                         -> return ()+   whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True    let cleanUp = case exampleDetails (example ?config) of@@ -756,6 +759,30 @@    return SetupResult{..} +checkExampleModulesExist :: FilePath -> Example -> IO ()+checkExampleModulesExist benchDir Example{..} =+    forM_ exampleModules $ \target -> do+        let fullPath = benchDir </> target+        exists <- doesFileExist fullPath+        unless exists $+            fail $ "Benchmark example " <> show exampleName+                <> " is missing target file " <> show target+                <> " at " <> fullPath++buildCabalExample :: HasConfig => FilePath -> IO ()+buildCabalExample path = do+    output $ "cabal build all -j in " <> path+    cmd_ (Cwd path) ("cabal" :: String) (["build", "all", "-j"] :: [String])++cabalProjectForPackage :: ExamplePackage -> String+cabalProjectForPackage ExamplePackage{packageName = "lsp-types"} =+    unlines+        [ "packages: ."+        , "allow-newer: boring:base"+        ]+cabalProjectForPackage _ =+    "packages: ."+ setupDocumentContents :: Config -> Session [DocumentPositions] setupDocumentContents config =         forM (exampleModules $ example config) $ \m -> do@@ -794,10 +821,61 @@  -------------------------------------------------------------------------------------------- -pad :: Int -> String -> String-pad n []     = replicate n ' '-pad 0 _      = error "pad"-pad n (x:xx) = x : pad (n-1) xx+-- | A summary value+data Cell = Time Seconds | Count Int | Str Text++renderCell :: (Seconds -> Text) -> Cell -> Text+renderCell showTime (Time s) = showTime s+renderCell _ (Count n)       = T.pack (show n)+renderCell _ (Str s)         = s++summaryColumns :: HasConfig => [(Text, Bench -> BenchRun -> Cell)]+summaryColumns =+    [ ("name", \Bench{name} _ -> Str (T.pack name))+    , ("success", \_ BenchRun{success} -> Str (T.pack (show success)))+    , ("samples", \Bench{samples} _ -> Str (T.pack (show samples)))+    , ("startup", \_ BenchRun{startup} -> Time startup)+    , ("setup", \_ BenchRun{runSetup} -> Time (if runSetup < 0.01 then 0 else runSetup))+    , ("userT", \_ BenchRun{userWaits} -> Time userWaits)+    , ("delayedT", \_ BenchRun{delayedWork} -> Time delayedWork)+    , ("1stBuildT", \_ BenchRun{firstResponse, firstResponseDelayed} ->+        Time (firstResponse + firstResponseDelayed))+      -- Exclude the first response as it has a lot of setup time included.+      -- Assume that number of requests = number of modules * number of samples+    , ("avgPerRespT",  \Bench{samples} BenchRun{userWaits, firstResponse} ->+        Time ((userWaits - firstResponse) / ((fromIntegral samples - 1) * modules)))+    , ("totalT",       \_ BenchRun{runExperiment} -> Time runExperiment)+    , ("rulesBuilt",   \_ BenchRun{rulesBuilt} -> Count rulesBuilt)+    , ("rulesChanged", \_ BenchRun{rulesChanged} -> Count rulesChanged)+    , ("rulesVisited", \_ BenchRun{rulesVisited} -> Count rulesVisited)+    , ("rulesTotal",   \_ BenchRun{rulesTotal} -> Count rulesTotal)+    , ("ruleEdges",    \_ BenchRun{edgesTotal} -> Count edgesTotal)+    , ("ghcRebuilds",  \_ BenchRun{rebuildsTotal} -> Count rebuildsTotal)+    ]+  where+    modules = fromIntegral $ length $ exampleModules $ example ?config++ruleCounts :: [T.Text] -> [(T.Text, Int)]+ruleCounts keys =+    [ (k, length g)+    | g@(k:_) <- group $ sort [ T.takeWhile (/= ';') t | t <- keys ] ]++-- | Keys built per rule, one column per benchmark.+ruleHistogram :: [(Bench, BenchRun)] -> [String]+ruleHistogram results =+    renderTable ("rule" : [ T.pack name | (Bench{name}, _) <- results ]) (map row rules ++ [totals])+  where+    counts = [ rulesBuiltByRule | (_, BenchRun{rulesBuiltByRule}) <- results ]+    rules = map fst $ sortOn (\(r, n) -> (Down n, r)) groups+    groups = [ (r, sum ns) | (r, ns) <- groupSort (concat counts) ]+    row r = r : [ num (fromMaybe 0 (lookup r c)) | c <- counts ]+    totals = "TOTAL" : [ num (sum (map snd c)) | c <- counts ]+    num = T.pack . show++renderTable :: [Text] -> [[Text]] -> [String]+renderTable hdrs rows =+    tableLines $ columnHeaderTableS (map (const def) hdrs) asciiS+                                    (titlesH hdrs) [rowsG rows]  -- | Search for a position where: --     - get definition works and returns a uri other than this file
ghcide-bench/test/Main.hs view
@@ -36,6 +36,8 @@         | e <- Bench.experiments         , Bench.name e /= "edit" -- the edit experiment does not ever fail         , Bench.name e /= "hole fit suggestions" -- is too slow!+        , not ("semanticTokens" `isInfixOf` Bench.name e) -- ghcide does not load the semantic-tokens plugin+        , not ("code actions" `isInfixOf` Bench.name e) -- ghcide does not load the code-action plugin         -- the cradle experiments are way too slow         , not ("cradle" `isInfixOf` Bench.name e)     ]
+ ghcide-test/data/THUnload/A.hs view
@@ -0,0 +1,4 @@+module A where++a :: Int+a = 1
+ ghcide-test/data/THUnload/B.hs view
@@ -0,0 +1,6 @@+module B where++import A++b :: Int+b = a
+ ghcide-test/data/THUnload/C.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TemplateHaskell #-}+module C where++import B+import Language.Haskell.TH++c :: Int+c = $(reportWarning ("b is " ++ show b) >> [| b |])
+ ghcide-test/data/THUnload/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: ["-Wmissing-signatures", "-package template-haskell", "A", "B", "C"]}}
+ ghcide-test/data/THUnloadDeep/A1.hs view
@@ -0,0 +1,4 @@+module A1 where++a1 :: Int+a1 = 1
+ ghcide-test/data/THUnloadDeep/A2.hs view
@@ -0,0 +1,6 @@+module A2 where++import A1++a2 :: Int+a2 = a1
+ ghcide-test/data/THUnloadDeep/A3.hs view
@@ -0,0 +1,6 @@+module A3 where++import A2++a3 :: Int+a3 = a2
+ ghcide-test/data/THUnloadDeep/A4.hs view
@@ -0,0 +1,6 @@+module A4 where++import A3++a4 :: Int+a4 = a3
+ ghcide-test/data/THUnloadDeep/A5.hs view
@@ -0,0 +1,6 @@+module A5 where++import A4++a5 :: Int+a5 = a4
+ ghcide-test/data/THUnloadDeep/A6.hs view
@@ -0,0 +1,6 @@+module A6 where++import A5++a6 :: Int+a6 = a5
+ ghcide-test/data/THUnloadDeep/C.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TemplateHaskell #-}+module C where++import A6+import Language.Haskell.TH++c :: Int+c = $(reportWarning ("a6 is " ++ show a6) >> [| a6 |])
+ ghcide-test/data/THUnloadDeep/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: ["-Wmissing-signatures", "-package template-haskell", "A1", "A2", "A3", "A4", "A5", "A6", "C"]}}
+ ghcide-test/data/boot-linkable/Clash/Promoted/Nat.hs view
@@ -0,0 +1,5 @@+module Clash.Promoted.Nat (SNat) where++import Clash.XException ()++data SNat = SNat
+ ghcide-test/data/boot-linkable/Clash/Promoted/Nat/Literals.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskell #-}++module Clash.Promoted.Nat.Literals where++import Clash.Promoted.Nat.TH++$(snatSplice)
+ ghcide-test/data/boot-linkable/Clash/Promoted/Nat/TH.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TemplateHaskell #-}+module Clash.Promoted.Nat.TH (snatSplice) where++import Language.Haskell.TH (Q, Dec)+import Clash.Promoted.Nat ()++snatSplice :: Q [Dec]+snatSplice = pure []
+ ghcide-test/data/boot-linkable/Clash/XException.hs view
@@ -0,0 +1,3 @@+module Clash.XException () where++import Clash.XException.Internal ()
+ ghcide-test/data/boot-linkable/Clash/XException.hs-boot view
@@ -0,0 +1,1 @@+module Clash.XException where
+ ghcide-test/data/boot-linkable/Clash/XException/Internal.hs view
@@ -0,0 +1,3 @@+module Clash.XException.Internal where++import {-# SOURCE #-} Clash.XException ()
+ ghcide-test/data/boot-linkable/hie.yaml view
@@ -0,0 +1,8 @@+cradle:+  direct:+    arguments:+      - "Clash.XException"+      - "Clash.XException.Internal"+      - "Clash.Promoted.Nat"+      - "Clash.Promoted.Nat.Literals"+      - "Clash.Promoted.Nat.TH"
+ ghcide-test/data/boot-qualified/A.hs view
@@ -0,0 +1,12 @@+module A where++import {-# SOURCE #-} B (BB(BB))++data T = T Int++-- Only present in A.hs, NOT in A.hs-boot.+extraFn :: T -> T+extraFn (T n) = T (n + 1)++wrapB :: Int -> BB+wrapB = BB
+ ghcide-test/data/boot-qualified/A.hs-boot view
@@ -0,0 +1,3 @@+module A where++data T = T Int
+ ghcide-test/data/boot-qualified/B.hs view
@@ -0,0 +1,16 @@+module B where++import {-# SOURCE #-} A (T(T))+import qualified A as QA++data BB = BB Int++-- Uses QA.extraFn, which is exported by A.hs but NOT by A.hs-boot.+-- ghcide reports+--   Variable not in scope: QA.extraFn ...+--   NB: the module 'A' does not export 'extraFn'+-- because it resolves the qualified import against the hs-boot exports+-- instead of the full module.+someBFn :: Int -> Int+someBFn n = case QA.extraFn (T n) of+  T m -> m
+ ghcide-test/data/boot-qualified/B.hs-boot view
@@ -0,0 +1,3 @@+module B where++data BB = BB Int
+ ghcide-test/data/boot-qualified/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: ["A.hs-boot", "B.hs-boot", "A.hs", "B.hs"]}}
+ ghcide-test/data/cross-cradle/a/A.hs view
@@ -0,0 +1,3 @@+module A(foo) where+foo :: Int+foo = 1
+ ghcide-test/data/cross-cradle/a/a.cabal view
@@ -0,0 +1,9 @@+name: a+version: 1.0.0+build-type: Simple+cabal-version: >= 1.2++library+  build-depends: base+  exposed-modules: A+  hs-source-dirs: .
+ ghcide-test/data/cross-cradle/cabal.project view
@@ -0,0 +1,1 @@+packages: a
+ ghcide-test/data/cross-cradle/hie.yaml view
@@ -0,0 +1,2 @@+cradle:+  cabal:
+ ghcide-test/data/cross-cradle/standalone/Standalone.hs view
@@ -0,0 +1,3 @@+module Standalone where+bar :: Int+bar = 2
+ ghcide-test/data/cross-cradle/standalone/hie.yaml view
@@ -0,0 +1,5 @@+# Files in this directory are not part of any cabal component; they are owned+# by their own direct cradle, distinct from the cabal cradle at the root.+cradle:+  direct:+    arguments: []
+ ghcide-test/data/multi-unit-eps-pollution/a/A.hs view
@@ -0,0 +1,9 @@+module A (AType, MyClass(..)) where++data AType = AType Int++class MyClass a where+  myMethod :: a -> String++instance MyClass AType where+  myMethod (AType n) = "AType " ++ show n
+ ghcide-test/data/multi-unit-eps-pollution/c/C.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wall #-}+module C where+import A++-- Omit top-level signature so we have a warning we can check against+cFoo = myMethod @AType
+ ghcide-test/data/multi-unit-eps-pollution/hie.yaml view
@@ -0,0 +1,5 @@+cradle:+  direct:+    arguments: ["-unit" ,"@a-1.0.0-inplace"+               ,"-unit" ,"@c-1.0.0-inplace"+               ]
+ ghcide-test/data/multi-unit-pkgimport/cabal.project view
@@ -0,0 +1,2 @@+packages: mmm ppp qqq+multi-repl: True
+ ghcide-test/data/multi-unit-pkgimport/hie.yaml view
@@ -0,0 +1,6 @@+cradle:+  direct:+    arguments: ["-unit" ,"@mmm-1.0.0-inplace"+               ,"-unit" ,"@ppp-1.0.0-inplace"+               ,"-unit" ,"@qqq-1.0.0-inplace"+               ]
+ ghcide-test/data/multi-unit-pkgimport/mmm/M.hs view
@@ -0,0 +1,4 @@+module M where+import "ppp" A+m :: ()+m = pVal
+ ghcide-test/data/multi-unit-pkgimport/ppp/A.hs view
@@ -0,0 +1,3 @@+module A where+pVal :: ()+pVal = ()
+ ghcide-test/data/multi-unit-pkgimport/qqq/A.hs view
@@ -0,0 +1,3 @@+module A where+qVal :: ()+qVal = ()
+ ghcide-test/data/multi-unit-reexport-rename/cabal.project view
@@ -0,0 +1,2 @@+packages: mmm rrr+multi-repl: True
+ ghcide-test/data/multi-unit-reexport-rename/hie.yaml view
@@ -0,0 +1,5 @@+cradle:+  direct:+    arguments: ["-unit" ,"@mmm-1.0.0-inplace"+               ,"-unit" ,"@rrr-1.0.0-inplace"+               ]
+ ghcide-test/data/multi-unit-reexport-rename/mmm/M.hs view
@@ -0,0 +1,4 @@+module M where+import Facade+m :: ()+m = impl
+ ghcide-test/data/multi-unit-reexport-rename/rrr/Internal/Impl.hs view
@@ -0,0 +1,3 @@+module Internal.Impl where+impl :: ()+impl = ()
+ ghcide-test/data/multi-unit-shadow/aaa/M.hs view
@@ -0,0 +1,4 @@+module M where+import X+m :: ()+m = xInAaa
+ ghcide-test/data/multi-unit-shadow/aaa/X.hs view
@@ -0,0 +1,3 @@+module X where+xInAaa :: ()+xInAaa = ()
+ ghcide-test/data/multi-unit-shadow/cabal.project view
@@ -0,0 +1,2 @@+packages: aaa zzz+multi-repl: True
+ ghcide-test/data/multi-unit-shadow/hie.yaml view
@@ -0,0 +1,5 @@+cradle:+  direct:+    arguments: ["-unit" ,"@aaa-1.0.0-inplace"+               ,"-unit" ,"@zzz-1.0.0-inplace"+               ]
+ ghcide-test/data/multi-unit-shadow/zzz/X.hs view
@@ -0,0 +1,3 @@+module X where+xInZzz :: ()+xInZzz = ()
+ ghcide-test/data/multi-unit-visibility/aaa/Priv.hs view
@@ -0,0 +1,3 @@+module Priv where+privValue :: ()+privValue = ()
+ ghcide-test/data/multi-unit-visibility/bbb/B.hs view
@@ -0,0 +1,4 @@+module B where+import Priv+b :: ()+b = privValue
+ ghcide-test/data/multi-unit-visibility/cabal.project view
@@ -0,0 +1,2 @@+packages: aaa bbb+multi-repl: True
+ ghcide-test/data/multi-unit-visibility/hie.yaml view
@@ -0,0 +1,5 @@+cradle:+  direct:+    arguments: ["-unit" ,"@aaa-1.0.0-inplace"+               ,"-unit" ,"@bbb-1.0.0-inplace"+               ]
− ghcide-test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.10.3/a-1.0.0/build/autogen/PackageInfo_a.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE NoRebindableSyntax #-}-{-# OPTIONS_GHC -Wno-missing-import-lists #-}-{-# OPTIONS_GHC -w #-}--{-|-Module      : PackageInfo_a-Description : Contents of some of the package's Cabal file's fields.--WARNING: This module was generated by Cabal. Any modifications will be-overwritten if the module is regenerated.--This module exports values that record information from some of the fields of-the package's Cabal package description file (Cabal file).--For further information about the fields in a Cabal file, see the Cabal User-Guide.--}--module PackageInfo_a (-    name,-    version,-    synopsis,-    copyright,-    homepage,-  ) where--import Data.Version (Version(..))-import Prelude---- |The content of the @name@ field of the package's Cabal file, but with any--- hyphen characters replaced by underscore characters.-name :: String-name = "a"--- |The content of the @version@ field of the package's Cabal file.-version :: Version-version = Version [1,0,0] []---- |The content of the @synopsis@ field of the package's Cabal file.-synopsis :: String-synopsis = ""--- |The content of the @copyright@ field of the package's Cabal file.-copyright :: String-copyright = ""--- |The content of the @homepage@ field of the package's Cabal file.-homepage :: String-homepage = ""
− ghcide-test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.10.3/a-1.0.0/build/autogen/Paths_a.hs 
@@ -1,132 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NoRebindableSyntax #-}-#if __GLASGOW_HASKELL__ >= 810-{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}-#endif-{-# OPTIONS_GHC -Wno-missing-import-lists #-}-{-# OPTIONS_GHC -w #-}--{-|-Module      : Paths_a-Description : Data file location, and package version and installation-              directories.--WARNING: This module was generated by Cabal. Any modifications will be-overwritten if the module is regenerated.--This module exports a function to locate data files, and values that record-the version of the package and some directories which the package has been-configured to be installed into.--For further information about Cabal's options for its configuration step, and-their default values, see the Cabal User Guide.--}--module Paths_a (-    version,-    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,-    getDataFileName, getSysconfDir-  ) where---import qualified Control.Exception as Exception-import Data.Version (Version(..))-import System.Environment (getEnv)-import Prelude---#if defined(VERSION_base)--#if MIN_VERSION_base(4,0,0)-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#else-catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a-#endif--#else-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#endif-catchIO = Exception.catch---- |The package version.-version :: Version-version = Version [1,0,0] []---- |If the argument is a filename, the result is the name of a corresponding--- file on the system on which the program is running, if the file were listed--- in the @data-files@ field of the package's Cabal package description file.--- No check is performed that the given filename is listed in that field.-getDataFileName :: FilePath -> IO FilePath-getDataFileName name = do-  dir <- getDataDir-  return (dir `joinFileName` name)---- |The location of the directory specified by Cabal's @--bindir@ option (where--- executables that the user might invoke are installed). This can be overridden--- at runtime using the environment variable a_bindir.-getBinDir :: IO FilePath---- |The location of the directory specified by Cabal's @--libdir@ option (where--- object libraries are installed). This can be overridden at runtime using the--- environment variable a_libdir.-getLibDir :: IO FilePath---- |The location of the directory specified by Cabal's @--dynlibdir@ option--- (where dynamic libraries are installed). This can be overridden at runtime--- using the environment variable a_dynlibdir.-getDynLibDir :: IO FilePath---- |The location of the directory specified by Cabal's @--datadir@ option (where--- architecture-independent data files are installed). This can be overridden at--- runtime using the environment variable a_datadir.-getDataDir :: IO FilePath---- |The location of the directory specified by Cabal's @--libexedir@ option--- (where executables that are not expected to be invoked directly by the user--- are installed). This can be overridden at runtime using the environment--- variable a_libexedir.-getLibexecDir :: IO FilePath---- |The location of the directory specified by Cabal's @--sysconfdir@ option--- (where configuration files are installed). This can be overridden at runtime--- using the environment variable a_sysconfdir.-getSysconfDir :: IO FilePath-----bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath-bindir     = "/home/zubin/.cabal/bin"-libdir     = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.10.3-415c/a-1.0.0-inplace"-dynlibdir  = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.10.3-415c"-datadir    = "/home/zubin/.cabal/share/x86_64-linux-ghc-9.10.3-415c/a-1.0.0"-libexecdir = "/home/zubin/.cabal/libexec/x86_64-linux-ghc-9.10.3-415c/a-1.0.0"-sysconfdir = "/home/zubin/.cabal/etc"--getBinDir     = catchIO (getEnv "a_bindir")     (\_ -> return bindir)-getLibDir     = catchIO (getEnv "a_libdir")     (\_ -> return libdir)-getDynLibDir  = catchIO (getEnv "a_dynlibdir")  (\_ -> return dynlibdir)-getDataDir    = catchIO (getEnv "a_datadir")    (\_ -> return datadir)-getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir)-getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir)----joinFileName :: String -> String -> FilePath-joinFileName ""  fname = fname-joinFileName "." fname = fname-joinFileName dir ""    = dir-joinFileName dir@(c:cs) fname-  | isPathSeparator (lastChar c cs) = dir ++ fname-  | otherwise                       = dir ++ pathSeparator : fname- where-  -- We do not use Data.List.NonEmpty.last, as that would limit the module to-  -- base >= 4.9.0.0 (GHC >= 8.0.1).-  lastChar x [] = x-  lastChar _ (x:xs) = lastChar x xs--pathSeparator :: Char-pathSeparator = '/'--isPathSeparator :: Char -> Bool-isPathSeparator c = c == '/'
− ghcide-test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.14.1/a-1.0.0/build/autogen/PackageInfo_a.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE NoRebindableSyntax #-}-{-# OPTIONS_GHC -Wno-missing-import-lists #-}-{-# OPTIONS_GHC -w #-}--{-|-Module      : PackageInfo_a-Description : Contents of some of the package's Cabal file's fields.--WARNING: This module was generated by Cabal. Any modifications will be-overwritten if the module is regenerated.--This module exports values that record information from some of the fields of-the package's Cabal package description file (Cabal file).--For further information about the fields in a Cabal file, see the Cabal User-Guide.--}--module PackageInfo_a (-    name,-    version,-    synopsis,-    copyright,-    homepage,-  ) where--import Data.Version (Version(..))-import Prelude---- |The content of the @name@ field of the package's Cabal file, but with any--- hyphen characters replaced by underscore characters.-name :: String-name = "a"--- |The content of the @version@ field of the package's Cabal file.-version :: Version-version = Version [1,0,0] []---- |The content of the @synopsis@ field of the package's Cabal file.-synopsis :: String-synopsis = ""--- |The content of the @copyright@ field of the package's Cabal file.-copyright :: String-copyright = ""--- |The content of the @homepage@ field of the package's Cabal file.-homepage :: String-homepage = ""
− ghcide-test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.14.1/a-1.0.0/build/autogen/Paths_a.hs 
@@ -1,132 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NoRebindableSyntax #-}-#if __GLASGOW_HASKELL__ >= 810-{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}-#endif-{-# OPTIONS_GHC -Wno-missing-import-lists #-}-{-# OPTIONS_GHC -w #-}--{-|-Module      : Paths_a-Description : Data file location, and package version and installation-              directories.--WARNING: This module was generated by Cabal. Any modifications will be-overwritten if the module is regenerated.--This module exports a function to locate data files, and values that record-the version of the package and some directories which the package has been-configured to be installed into.--For further information about Cabal's options for its configuration step, and-their default values, see the Cabal User Guide.--}--module Paths_a (-    version,-    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,-    getDataFileName, getSysconfDir-  ) where---import qualified Control.Exception as Exception-import Data.Version (Version(..))-import System.Environment (getEnv)-import Prelude---#if defined(VERSION_base)--#if MIN_VERSION_base(4,0,0)-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#else-catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a-#endif--#else-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#endif-catchIO = Exception.catch---- |The package version.-version :: Version-version = Version [1,0,0] []---- |If the argument is a filename, the result is the name of a corresponding--- file on the system on which the program is running, if the file were listed--- in the @data-files@ field of the package's Cabal package description file.--- No check is performed that the given filename is listed in that field.-getDataFileName :: FilePath -> IO FilePath-getDataFileName name = do-  dir <- getDataDir-  return (dir `joinFileName` name)---- |The location of the directory specified by Cabal's @--bindir@ option (where--- executables that the user might invoke are installed). This can be overridden--- at runtime using the environment variable a_bindir.-getBinDir :: IO FilePath---- |The location of the directory specified by Cabal's @--libdir@ option (where--- object libraries are installed). This can be overridden at runtime using the--- environment variable a_libdir.-getLibDir :: IO FilePath---- |The location of the directory specified by Cabal's @--dynlibdir@ option--- (where dynamic libraries are installed). This can be overridden at runtime--- using the environment variable a_dynlibdir.-getDynLibDir :: IO FilePath---- |The location of the directory specified by Cabal's @--datadir@ option (where--- architecture-independent data files are installed). This can be overridden at--- runtime using the environment variable a_datadir.-getDataDir :: IO FilePath---- |The location of the directory specified by Cabal's @--libexedir@ option--- (where executables that are not expected to be invoked directly by the user--- are installed). This can be overridden at runtime using the environment--- variable a_libexedir.-getLibexecDir :: IO FilePath---- |The location of the directory specified by Cabal's @--sysconfdir@ option--- (where configuration files are installed). This can be overridden at runtime--- using the environment variable a_sysconfdir.-getSysconfDir :: IO FilePath-----bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath-bindir     = "/home/zubin/.cabal/bin"-libdir     = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.14.1-ade7/a-1.0.0-inplace"-dynlibdir  = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.14.1-ade7"-datadir    = "/home/zubin/.cabal/share/x86_64-linux-ghc-9.14.1-ade7/a-1.0.0"-libexecdir = "/home/zubin/.cabal/libexec/x86_64-linux-ghc-9.14.1-ade7/a-1.0.0"-sysconfdir = "/home/zubin/.cabal/etc"--getBinDir     = catchIO (getEnv "a_bindir")     (\_ -> return bindir)-getLibDir     = catchIO (getEnv "a_libdir")     (\_ -> return libdir)-getDynLibDir  = catchIO (getEnv "a_dynlibdir")  (\_ -> return dynlibdir)-getDataDir    = catchIO (getEnv "a_datadir")    (\_ -> return datadir)-getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir)-getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir)----joinFileName :: String -> String -> FilePath-joinFileName ""  fname = fname-joinFileName "." fname = fname-joinFileName dir ""    = dir-joinFileName dir@(c:cs) fname-  | isPathSeparator (lastChar c cs) = dir ++ fname-  | otherwise                       = dir ++ pathSeparator : fname- where-  -- We do not use Data.List.NonEmpty.last, as that would limit the module to-  -- base >= 4.9.0.0 (GHC >= 8.0.1).-  lastChar x [] = x-  lastChar _ (x:xs) = lastChar x xs--pathSeparator :: Char-pathSeparator = '/'--isPathSeparator :: Char -> Bool-isPathSeparator c = c == '/'
+ ghcide-test/data/plugin-parser/dist-newstyle/build/x86_64-linux/ghc-9.10.2/plugin-1.0.0/build/autogen/PackageInfo_plugin.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE NoRebindableSyntax #-}+{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}+module PackageInfo_plugin (+    name,+    version,+    synopsis,+    copyright,+    homepage,+  ) where++import Data.Version (Version(..))+import Prelude++name :: String+name = "plugin"+version :: Version+version = Version [1,0,0] []++synopsis :: String+synopsis = ""+copyright :: String+copyright = ""+homepage :: String+homepage = ""
+ ghcide-test/data/plugin-parser/dist-newstyle/build/x86_64-linux/ghc-9.10.2/plugin-1.0.0/build/autogen/Paths_plugin.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoRebindableSyntax #-}+#if __GLASGOW_HASKELL__ >= 810+{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}+#endif+{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}+module Paths_plugin (+    version,+    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,+    getDataFileName, getSysconfDir+  ) where+++import qualified Control.Exception as Exception+import qualified Data.List as List+import Data.Version (Version(..))+import System.Environment (getEnv)+import Prelude+++#if defined(VERSION_base)++#if MIN_VERSION_base(4,0,0)+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#else+catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a+#endif++#else+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#endif+catchIO = Exception.catch++version :: Version+version = Version [1,0,0] []++getDataFileName :: FilePath -> IO FilePath+getDataFileName name = do+  dir <- getDataDir+  return (dir `joinFileName` name)++getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath+++++bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath+bindir     = "/home/hugin/.cabal/bin"+libdir     = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.10.2-d434/plugin-1.0.0-inplace"+dynlibdir  = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.10.2-d434"+datadir    = "/home/hugin/.cabal/share/x86_64-linux-ghc-9.10.2-d434/plugin-1.0.0"+libexecdir = "/home/hugin/.cabal/libexec/x86_64-linux-ghc-9.10.2-d434/plugin-1.0.0"+sysconfdir = "/home/hugin/.cabal/etc"++getBinDir     = catchIO (getEnv "plugin_bindir")     (\_ -> return bindir)+getLibDir     = catchIO (getEnv "plugin_libdir")     (\_ -> return libdir)+getDynLibDir  = catchIO (getEnv "plugin_dynlibdir")  (\_ -> return dynlibdir)+getDataDir    = catchIO (getEnv "plugin_datadir")    (\_ -> return datadir)+getLibexecDir = catchIO (getEnv "plugin_libexecdir") (\_ -> return libexecdir)+getSysconfDir = catchIO (getEnv "plugin_sysconfdir") (\_ -> return sysconfdir)++++joinFileName :: String -> String -> FilePath+joinFileName ""  fname = fname+joinFileName "." fname = fname+joinFileName dir ""    = dir+joinFileName dir fname+  | isPathSeparator (List.last dir) = dir ++ fname+  | otherwise                       = dir ++ pathSeparator : fname++pathSeparator :: Char+pathSeparator = '/'++isPathSeparator :: Char -> Bool+isPathSeparator c = c == '/'
+ ghcide-test/data/plugin-parser/dist-newstyle/build/x86_64-linux/ghc-9.10.2/usage-1.0.0/build/autogen/PackageInfo_usage.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE NoRebindableSyntax #-}+{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}+module PackageInfo_usage (+    name,+    version,+    synopsis,+    copyright,+    homepage,+  ) where++import Data.Version (Version(..))+import Prelude++name :: String+name = "usage"+version :: Version+version = Version [1,0,0] []++synopsis :: String+synopsis = ""+copyright :: String+copyright = ""+homepage :: String+homepage = ""
+ ghcide-test/data/plugin-parser/dist-newstyle/build/x86_64-linux/ghc-9.10.2/usage-1.0.0/build/autogen/Paths_usage.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoRebindableSyntax #-}+#if __GLASGOW_HASKELL__ >= 810+{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}+#endif+{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}+module Paths_usage (+    version,+    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,+    getDataFileName, getSysconfDir+  ) where+++import qualified Control.Exception as Exception+import qualified Data.List as List+import Data.Version (Version(..))+import System.Environment (getEnv)+import Prelude+++#if defined(VERSION_base)++#if MIN_VERSION_base(4,0,0)+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#else+catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a+#endif++#else+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#endif+catchIO = Exception.catch++version :: Version+version = Version [1,0,0] []++getDataFileName :: FilePath -> IO FilePath+getDataFileName name = do+  dir <- getDataDir+  return (dir `joinFileName` name)++getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath+++++bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath+bindir     = "/home/hugin/.cabal/bin"+libdir     = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.10.2-d434/usage-1.0.0-inplace"+dynlibdir  = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.10.2-d434"+datadir    = "/home/hugin/.cabal/share/x86_64-linux-ghc-9.10.2-d434/usage-1.0.0"+libexecdir = "/home/hugin/.cabal/libexec/x86_64-linux-ghc-9.10.2-d434/usage-1.0.0"+sysconfdir = "/home/hugin/.cabal/etc"++getBinDir     = catchIO (getEnv "usage_bindir")     (\_ -> return bindir)+getLibDir     = catchIO (getEnv "usage_libdir")     (\_ -> return libdir)+getDynLibDir  = catchIO (getEnv "usage_dynlibdir")  (\_ -> return dynlibdir)+getDataDir    = catchIO (getEnv "usage_datadir")    (\_ -> return datadir)+getLibexecDir = catchIO (getEnv "usage_libexecdir") (\_ -> return libexecdir)+getSysconfDir = catchIO (getEnv "usage_sysconfdir") (\_ -> return sysconfdir)++++joinFileName :: String -> String -> FilePath+joinFileName ""  fname = fname+joinFileName "." fname = fname+joinFileName dir ""    = dir+joinFileName dir fname+  | isPathSeparator (List.last dir) = dir ++ fname+  | otherwise                       = dir ++ pathSeparator : fname++pathSeparator :: Char+pathSeparator = '/'++isPathSeparator :: Char -> Bool+isPathSeparator c = c == '/'
+ ghcide-test/data/plugin-parser/dist-newstyle/build/x86_64-linux/ghc-9.10.3/plugin-1.0.0/build/autogen/PackageInfo_plugin.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE NoRebindableSyntax #-}+{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}+module PackageInfo_plugin (+    name,+    version,+    synopsis,+    copyright,+    homepage,+  ) where++import Data.Version (Version(..))+import Prelude++name :: String+name = "plugin"+version :: Version+version = Version [1,0,0] []++synopsis :: String+synopsis = ""+copyright :: String+copyright = ""+homepage :: String+homepage = ""
+ ghcide-test/data/plugin-parser/dist-newstyle/build/x86_64-linux/ghc-9.10.3/plugin-1.0.0/build/autogen/Paths_plugin.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoRebindableSyntax #-}+#if __GLASGOW_HASKELL__ >= 810+{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}+#endif+{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}+module Paths_plugin (+    version,+    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,+    getDataFileName, getSysconfDir+  ) where+++import qualified Control.Exception as Exception+import qualified Data.List as List+import Data.Version (Version(..))+import System.Environment (getEnv)+import Prelude+++#if defined(VERSION_base)++#if MIN_VERSION_base(4,0,0)+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#else+catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a+#endif++#else+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#endif+catchIO = Exception.catch++version :: Version+version = Version [1,0,0] []++getDataFileName :: FilePath -> IO FilePath+getDataFileName name = do+  dir <- getDataDir+  return (dir `joinFileName` name)++getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath+++++bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath+bindir     = "/home/hugin/.cabal/bin"+libdir     = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.10.3-415c/plugin-1.0.0-inplace"+dynlibdir  = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.10.3-415c"+datadir    = "/home/hugin/.cabal/share/x86_64-linux-ghc-9.10.3-415c/plugin-1.0.0"+libexecdir = "/home/hugin/.cabal/libexec/x86_64-linux-ghc-9.10.3-415c/plugin-1.0.0"+sysconfdir = "/home/hugin/.cabal/etc"++getBinDir     = catchIO (getEnv "plugin_bindir")     (\_ -> return bindir)+getLibDir     = catchIO (getEnv "plugin_libdir")     (\_ -> return libdir)+getDynLibDir  = catchIO (getEnv "plugin_dynlibdir")  (\_ -> return dynlibdir)+getDataDir    = catchIO (getEnv "plugin_datadir")    (\_ -> return datadir)+getLibexecDir = catchIO (getEnv "plugin_libexecdir") (\_ -> return libexecdir)+getSysconfDir = catchIO (getEnv "plugin_sysconfdir") (\_ -> return sysconfdir)++++joinFileName :: String -> String -> FilePath+joinFileName ""  fname = fname+joinFileName "." fname = fname+joinFileName dir ""    = dir+joinFileName dir fname+  | isPathSeparator (List.last dir) = dir ++ fname+  | otherwise                       = dir ++ pathSeparator : fname++pathSeparator :: Char+pathSeparator = '/'++isPathSeparator :: Char -> Bool+isPathSeparator c = c == '/'
+ ghcide-test/data/plugin-parser/dist-newstyle/build/x86_64-linux/ghc-9.10.3/usage-1.0.0/build/autogen/PackageInfo_usage.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE NoRebindableSyntax #-}+{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}+module PackageInfo_usage (+    name,+    version,+    synopsis,+    copyright,+    homepage,+  ) where++import Data.Version (Version(..))+import Prelude++name :: String+name = "usage"+version :: Version+version = Version [1,0,0] []++synopsis :: String+synopsis = ""+copyright :: String+copyright = ""+homepage :: String+homepage = ""
+ ghcide-test/data/plugin-parser/dist-newstyle/build/x86_64-linux/ghc-9.10.3/usage-1.0.0/build/autogen/Paths_usage.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoRebindableSyntax #-}+#if __GLASGOW_HASKELL__ >= 810+{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}+#endif+{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}+module Paths_usage (+    version,+    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,+    getDataFileName, getSysconfDir+  ) where+++import qualified Control.Exception as Exception+import qualified Data.List as List+import Data.Version (Version(..))+import System.Environment (getEnv)+import Prelude+++#if defined(VERSION_base)++#if MIN_VERSION_base(4,0,0)+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#else+catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a+#endif++#else+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#endif+catchIO = Exception.catch++version :: Version+version = Version [1,0,0] []++getDataFileName :: FilePath -> IO FilePath+getDataFileName name = do+  dir <- getDataDir+  return (dir `joinFileName` name)++getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath+++++bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath+bindir     = "/home/hugin/.cabal/bin"+libdir     = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.10.3-415c/usage-1.0.0-inplace"+dynlibdir  = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.10.3-415c"+datadir    = "/home/hugin/.cabal/share/x86_64-linux-ghc-9.10.3-415c/usage-1.0.0"+libexecdir = "/home/hugin/.cabal/libexec/x86_64-linux-ghc-9.10.3-415c/usage-1.0.0"+sysconfdir = "/home/hugin/.cabal/etc"++getBinDir     = catchIO (getEnv "usage_bindir")     (\_ -> return bindir)+getLibDir     = catchIO (getEnv "usage_libdir")     (\_ -> return libdir)+getDynLibDir  = catchIO (getEnv "usage_dynlibdir")  (\_ -> return dynlibdir)+getDataDir    = catchIO (getEnv "usage_datadir")    (\_ -> return datadir)+getLibexecDir = catchIO (getEnv "usage_libexecdir") (\_ -> return libexecdir)+getSysconfDir = catchIO (getEnv "usage_sysconfdir") (\_ -> return sysconfdir)++++joinFileName :: String -> String -> FilePath+joinFileName ""  fname = fname+joinFileName "." fname = fname+joinFileName dir ""    = dir+joinFileName dir fname+  | isPathSeparator (List.last dir) = dir ++ fname+  | otherwise                       = dir ++ pathSeparator : fname++pathSeparator :: Char+pathSeparator = '/'++isPathSeparator :: Char -> Bool+isPathSeparator c = c == '/'
+ ghcide-test/data/transitive-recomp/M0.hs view
@@ -0,0 +1,4 @@+module M0 (m0val) where++m0val :: Int+m0val = 0
+ ghcide-test/data/transitive-recomp/M1.hs view
@@ -0,0 +1,5 @@+module M1 (m1val) where++import M0++m1val = m0val
+ ghcide-test/data/transitive-recomp/M2.hs view
@@ -0,0 +1,6 @@+module M2 (m2val) where++import M1++m2val :: Int+m2val = m1val
+ ghcide-test/data/transitive-recomp/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: ["-Wmissing-signatures", "M0", "M1", "M2"]}}
ghcide-test/exe/BootTests.hs view
@@ -52,4 +52,12 @@   , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do       _ <- openDoc (dir </> "A.hs") "haskell"       expectNoMoreDiagnostics 2+  , testCase "qualified import alongside SOURCE import resolves to full module" $+      runWithExtraFiles "boot-qualified" $ \dir -> do+        _ <- openDoc (dir </> "B.hs") "haskell"+        expectNoMoreDiagnostics 5+  , testCase "GetLinkable on hs-boot via TH splice (clash-compiler reproducer)" $+      runWithExtraFiles "boot-linkable" $ \dir -> do+        _ <- openDoc (dir </> "Clash" </> "Promoted" </> "Nat.hs") "haskell"+        expectNoMoreDiagnostics 10   ]
ghcide-test/exe/CompletionTests.hs view
@@ -513,7 +513,37 @@         compls <- getCompletions doc (Position 2 12)         let item = head compls         liftIO $ do-          item ^. L.label @?= "anidentifier"+          item ^. L.label @?= "anidentifier",+      testSessionEmptyWithCradle "refresh completions after changing an import alias"+                  "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" $ do+        _ <- createDoc "A.hs" "haskell" $ T.unlines+            [ "module A (anidentifier) where"+            , "anidentifier = ()"+            ]+        _ <- waitForDiagnostics+        doc <- createDoc "B.hs" "haskell" $ T.unlines+            [ "module B where"+            , "import A as CM"+            , "before = CM."+            ]+        _ <- waitForDiagnostics+        before <- getCompletions doc (Position 2 12)++        changeDoc doc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ T.unlines+            [ "module B where"+            , "import A as C"+            , "after = C."+            , "stale = CM."+            ]]+        void $ waitForTypecheck doc+        after <- getCompletions doc (Position 2 10)+        stale <- getCompletions doc (Position 3 11)++        liftIO $ do+          listToMaybe (map (^. L.label) before) @?= Just "anidentifier"+          listToMaybe (map (^. L.label) after) @?= Just "anidentifier"+          assertBool "the old alias is still treated as an active import alias" $+            listToMaybe (map (^. L.label) stale) /= Just "anidentifier"     ]  completionDocTests :: [TestTree]
ghcide-test/exe/Config.hs view
@@ -24,6 +24,7 @@     , pattern R     , mkR     , checkDefs+    , assertDefsFile     , mkL     , withLongTimeout     , lspTestCaps@@ -167,6 +168,15 @@     let hasRange = any (\Location{_range=foundRange} -> foundRange == expectedRange) actualRanges     unless hasRange $ liftIO $ assertFailure $       "expected range: " <> show expectedRange <> "\nbut got ranges: " <> show defs++-- | Assert that there is at least one definition and all of them point into+-- the given file.+assertDefsFile :: FilePath -> (Definition |? ([DefinitionLink] |? Null)) -> Session ()+assertDefsFile expectedFile (defToLocation -> locs) = liftIO $ do+    expected <- canonicalizeUri (filePathToUri expectedFile)+    actual <- mapM canonicalizeUri [ uri | Location uri _ <- locs ]+    assertBool ("expected definitions in " <> show expected <> ", got: " <> show actual)+      (not (null actual) && all (== expected) actual)  canonicalizeLocation :: Location -> IO Location canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range
ghcide-test/exe/CradleTests.hs view
@@ -1,15 +1,18 @@ +{-# LANGUAGE CPP       #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs     #-}  module CradleTests (tests) where -import           Config                          (checkDefs, dummyPlugin,+import           Config                          (Expect (..), assertDefsFile,+                                                  checkDefs, dummyPlugin,                                                   lspTestCaps, mkIdeTestFs, mkL,                                                   runWithExtraFiles,                                                   testWithDummyPluginEmpty') import           Control.Applicative.Combinators import           Control.Lens                    ((^.))+import           Control.Monad                   (when) import           Control.Monad.IO.Class          (liftIO) import qualified Data.Aeson                      as A import           Data.Proxy                      (Proxy (..))@@ -17,7 +20,8 @@ import           Development.IDE.GHC.Util import           Development.IDE.Plugin.Test     (TestRequest (..),                                                   WaitForIdeRuleResult (..))-import           Development.IDE.Test            (expectDiagnostics,+import           Development.IDE.Test            (expectCurrentDiagnostics,+                                                  expectDiagnostics,                                                   expectDiagnosticsWithTags,                                                   expectNoMoreDiagnostics,                                                   isReferenceReady,@@ -35,33 +39,61 @@                                                   mkRange) import           Language.LSP.Test import           System.FilePath-import           Test.Hls                        (TestConfig (..), def,+import           Test.Hls                        (GhcVersion (..),+                                                  TestConfig (..), def,+                                                  expectFailBecause,+                                                  ignoreTestBecause,                                                   runSessionWithTestConfig,+                                                  setHlsConfig,                                                   waitForBuildQueue) import           Test.Hls.FileSystem import           Test.Hls.Util                   (EnvSpec (..), OS (..),+                                                  ignoreForGhcVersions,                                                   ignoreInEnv) import           Test.Tasty import           Test.Tasty.HUnit +defComponentLoadingConf :: SessionLoadingPreferenceConfig+defComponentLoadingConf = componentsLoading def +wholeProjectConf :: SessionLoadingPreferenceConfig+wholeProjectConf = PreferMultiWholeProjectLoading+ tests :: TestTree tests = testGroup "cradle"-    [testGroup "dependencies" [sessionDepsArePickedUp]-    ,testGroup "ignore-fatal" [ignoreFatalWarning]-    ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle]-    ,testGroup "regression.batch" batchLoadRegressionTests-    ,testGroup "multi"   (multiTests "multi")-    ,testGroup "multi-unit" (multiTests "multi-unit")-    ,testGroup "sub-directory"   [simpleSubDirectoryTest]-    ,testGroup "multi-unit-rexport" [multiRexportTest]+  [ testGroup "whole project"+    [ testGroup "dependencies" [sessionDepsArePickedUp wholeProjectConf]+    , testGroup "ignore-fatal" [ignoreFatalWarning wholeProjectConf]+    , testGroup "loading" [loadCradleOnlyOnce wholeProjectConf, retryFailedCradle wholeProjectConf]+    , testGroup "regression.batch" (batchLoadRegressionTests wholeProjectConf)+    , testGroup "cross-cradle" [crossCradleBatchIsolationTest wholeProjectConf]+    , testGroup "multi"   (multiTests wholeProjectConf "multi")+    , testGroup "multi-unit" (multiTests wholeProjectConf "multi-unit")+    , testGroup "sub-directory" [simpleSubDirectoryTest wholeProjectConf]+    , testGroup "multi-unit-rexport" [multiRexportTest wholeProjectConf]+    , testGroup "multi-unit-import-resolution" (multiUnitImportResolutionTests wholeProjectConf)+    , testGroup "undeclared-module" (undeclaredModuleTests wholeProjectConf)     ]--loadCradleOnlyonce :: TestTree-loadCradleOnlyonce = testGroup "load cradle only once"-    [ testWithDummyPluginEmpty' "implicit" implicit-    , testWithDummyPluginEmpty' "direct"   direct+  , testGroup "default"+    [ testGroup "dependencies" [sessionDepsArePickedUp defComponentLoadingConf]+    , testGroup "ignore-fatal" [ignoreFatalWarning defComponentLoadingConf]+    , testGroup "loading" [loadCradleOnlyOnce defComponentLoadingConf, retryFailedCradle defComponentLoadingConf]+    , testGroup "regression.batch" (batchLoadRegressionTests defComponentLoadingConf)+    , testGroup "cross-cradle" [crossCradleBatchIsolationTest defComponentLoadingConf]+    , testGroup "multi"   (multiTests defComponentLoadingConf "multi")+    , testGroup "multi-unit" (multiTests defComponentLoadingConf "multi-unit")+    , testGroup "sub-directory" [simpleSubDirectoryTest defComponentLoadingConf]+    , testGroup "multi-unit-rexport" [multiRexportTest defComponentLoadingConf]+    , testGroup "multi-unit-import-resolution" (multiUnitImportResolutionTests defComponentLoadingConf)+    , testGroup "undeclared-module" (undeclaredModuleTests defComponentLoadingConf)     ]+  ]++loadCradleOnlyOnce :: SessionLoadingPreferenceConfig -> TestTree+loadCradleOnlyOnce conf = testGroup "load cradle only once"+  [ testWithDummyPluginEmpty' "implicit" implicit+  , testWithDummyPluginEmpty' "direct"   direct+  ]     where         direct dir = do             liftIO $ atomicFileWriteStringUTF8 (dir </> "hie.yaml")@@ -69,6 +101,7 @@             test dir         implicit dir = test dir         test _dir = do+            setComponentsLoadingPreference conf             doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"             msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics))             liftIO $ length msgs @?= 1@@ -79,8 +112,9 @@             msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics))             liftIO $ length msgs @?= 0 -retryFailedCradle :: TestTree-retryFailedCradle = testWithDummyPluginEmpty' "retry failed" $ \dir -> do+retryFailedCradle :: SessionLoadingPreferenceConfig -> TestTree+retryFailedCradle conf = testWithDummyPluginEmpty' "retry failed" $ \dir -> do+  setComponentsLoadingPreference conf   -- The false cradle always fails   let hieContents = "cradle: {bios: {shell: \"false\"}}"       hiePath = dir </> "hie.yaml"@@ -108,16 +142,18 @@ cradleLoadedMethod :: String cradleLoadedMethod = "ghcide/cradle/loaded" -ignoreFatalWarning :: TestTree-ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do+ignoreFatalWarning :: SessionLoadingPreferenceConfig -> TestTree+ignoreFatalWarning conf = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do+    setComponentsLoadingPreference conf     let srcPath = dir </> "IgnoreFatal.hs"     src <- liftIO $ readFileUtf8 srcPath     _ <- createDoc srcPath "haskell" src     expectNoMoreDiagnostics 5 -simpleSubDirectoryTest :: TestTree-simpleSubDirectoryTest =+simpleSubDirectoryTest :: SessionLoadingPreferenceConfig -> TestTree+simpleSubDirectoryTest conf =   testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do+    setComponentsLoadingPreference conf     let mainPath = dir </> "a/src/Main.hs"     mainSource <- liftIO $ readFileUtf8 mainPath     _mdoc <- createDoc mainPath "haskell" mainSource@@ -126,19 +162,31 @@       ]     expectNoMoreDiagnostics 0.5 -multiTests :: FilePath -> [TestTree]-multiTests dir =-  [ simpleMultiTest dir-  , simpleMultiTest2 dir-  , simpleMultiTest3 dir-  , simpleMultiDefTest dir+multiTests :: SessionLoadingPreferenceConfig -> FilePath -> [TestTree]+multiTests conf odir =+  [ runOneTest testName test+  | (name,test) <-+  [ ("test",simpleMultiTest)+  , ("test2",simpleMultiTest2)+  , ("test3",simpleMultiTest3)+  , ("def-test",simpleMultiDefTest)   ]+  ,+  let testName = multiTestName odir name+  ]+  where+    runOneTest testName act = ignoreForWindows testName $ testCase testName $ runWithExtraFiles odir $ \dir -> do+      setComponentsLoadingPreference conf+      act dir+    ignoreForWindows testName+        | testName == "simple-multi-def-test" = ignoreInEnv [HostOS Windows] "Test is flaky on Windows, see #4270"+        | otherwise = id  multiTestName :: FilePath -> String -> String multiTestName dir name = "simple-" ++ dir ++ "-" ++ name -simpleMultiTest :: FilePath -> TestTree-simpleMultiTest variant = testCase (multiTestName variant "test") $ runWithExtraFiles variant $ \dir -> do+simpleMultiTest :: FilePath -> Session ()+simpleMultiTest = \dir -> do     let aPath = dir </> "a/A.hs"         bPath = dir </> "b/B.hs"     adoc <- openDoc aPath "haskell"@@ -153,8 +201,8 @@     expectNoMoreDiagnostics 0.5  -- Like simpleMultiTest but open the files in the other order-simpleMultiTest2 :: FilePath -> TestTree-simpleMultiTest2 variant = testCase (multiTestName variant "test2") $ runWithExtraFiles variant $ \dir -> do+simpleMultiTest2 :: FilePath -> Session ()+simpleMultiTest2 = \dir -> do     let aPath = dir </> "a/A.hs"         bPath = dir </> "b/B.hs"     bdoc <- openDoc bPath "haskell"@@ -167,9 +215,8 @@     expectNoMoreDiagnostics 0.5  -- Now with 3 components-simpleMultiTest3 :: FilePath -> TestTree-simpleMultiTest3 variant =-  testCase (multiTestName variant "test3") $ runWithExtraFiles variant $ \dir -> do+simpleMultiTest3 :: FilePath -> Session ()+simpleMultiTest3 = \ dir -> do     let aPath = dir </> "a/A.hs"         bPath = dir </> "b/B.hs"         cPath = dir </> "c/C.hs"@@ -234,6 +281,23 @@     checkDefs locs (pure [fooL])     expectNoMoreDiagnostics 0.5 +-- | Several files across different components of the same cradle are all+-- pending before the first load starts. Ensure they are submitted in the same+-- batch.+runRegressionInitialOpenSingleBatchLoad :: FilePath -> Session ()+runRegressionInitialOpenSingleBatchLoad dir = do+    let aPath = dir </> "a/A.hs"+        bPath = dir </> "b/B.hs"+        cPath = dir </> "c/C.hs"+    adoc <- openDoc aPath "haskell"+    bdoc <- openDoc bPath "haskell"+    cdoc <- openDoc cPath "haskell"+    _ <- waitForBuildQueue+    (results, loads) <- waitForTypeChecksCountingCradleLoads [adoc, bdoc, cdoc]+    liftIO $ do+      assertBool "A, B and C should all typecheck" (all ideResultSuccess results)+      assertEqual "cradle loads for the initial batch of files" 1 loads+ sendTestRequest :: TestRequest -> Session A.Value sendTestRequest req = do   let method = SMethod_CustomMethod (Proxy @"test")@@ -243,6 +307,27 @@     Left err -> liftIO (assertFailure $ "test plugin request failed: " <> show err) >> pure A.Null     Right val -> pure val +-- | Like 'waitForTypeChecksBatched', but additionally count the+-- @ghcide/cradle/loaded@ notifications the server emits while satisfying the+-- request, i.e. how many cradle loads it took to serve all the files.+waitForTypeChecksCountingCradleLoads :: [TextDocumentIdentifier] -> Session ([WaitForIdeRuleResult], Int)+waitForTypeChecksCountingCradleLoads docs = do+  let uris = map (\TextDocumentIdentifier{_uri} -> _uri) docs+      method = SMethod_CustomMethod (Proxy @"test")+  reqId <- sendRequest method (A.toJSON (WaitForIdeRules "TypeCheck" uris))+  let+    go loads = do+      next <- skipManyTill anyMessage $+        (Left <$> cradleLoadedMessage) <|> (Right <$> responseForId method reqId)+      case next of+        Left _ -> go (loads + 1)+        Right TResponseMessage{_result} -> case _result of+          Left err -> liftIO $ assertFailure $ "test plugin request failed: " <> show err+          Right val -> case A.fromJSON val of+            A.Success res -> pure (res, loads)+            A.Error parseErr -> liftIO $ assertFailure $ "batched typecheck parse failed: " <> parseErr+  go 0+ waitForTypeChecksBatched :: [TextDocumentIdentifier] -> Session [WaitForIdeRuleResult] waitForTypeChecksBatched docs = do   let uris = map (\TextDocumentIdentifier{_uri} -> _uri) docs@@ -251,34 +336,99 @@     A.Success res -> pure res     A.Error parseErr -> liftIO (assertFailure $ "batched typecheck parse failed: " <> parseErr) >> pure [] -batchLoadRegressionTests :: [TestTree]-batchLoadRegressionTests =+batchLoadRegressionTests :: SessionLoadingPreferenceConfig -> [TestTree]+batchLoadRegressionTests conf =   -- Note [Batch regression scheduling semantics]   -- `didOpen` alone does not enqueue session-loader pending files.   -- Pending entries come from GhcSession demand. For these tests, the `test`   -- plugin uses `WaitForIdeRules` plus a pending-size barrier in session-loader   -- to force all requested files into pending before load begins.   [ testCase "m1-open-a-then-b-batch-pending-and-success" $-      runWithExtraFilesMultiComponent "multi" runRegressionMultiOpenAThenB+      runWithExtraFilesMultiComponent conf "multi" runRegressionMultiOpenAThenB   , testCase "m2-open-b-then-a-batch-pending-and-success" $-      runWithExtraFilesMultiComponent "multi" runRegressionMultiOpenBThenA+      runWithExtraFilesMultiComponent conf "multi" runRegressionMultiOpenBThenA   , testCase "m3-open-b-then-a-then-c-batch-pending-and-success" $-      runWithExtraFilesMultiComponent "multi" runRegressionMultiOpenBThenAThenC-  , testCase "f1-batch-pending-failure-isolates-broken-file" $-      runWithExtraFilesMultiComponent "multi" regressionBatchFailureIsolatesBrokenFile-  , testCase "f2-failed-file-keeps-failing-until-cradle-fix" $-      runWithExtraFilesMultiComponent "multi" regressionFailedFileKeepsFailingUntilFix+      runWithExtraFilesMultiComponent conf "multi" runRegressionMultiOpenBThenAThenC+  , testCase "m4-initial-multi-file-open-loads-cradle-once" $+      runWithExtraFilesMultiComponent conf "multi" runRegressionInitialOpenSingleBatchLoad+  , expectBrokenWithWholeProjectLoading conf $+    testCase "f1-batch-pending-failure-isolates-broken-file" $+      runWithExtraFilesMultiComponent conf "multi" regressionBatchFailureIsolatesBrokenFile+  , expectBrokenWithWholeProjectLoading conf $+    testCase "f2-failed-file-keeps-failing-until-cradle-fix" $+      runWithExtraFilesMultiComponent conf "multi" regressionFailedFileKeepsFailingUntilFix+  , onlyWholeProjectLoading conf $+    testCase "f3-batch-pending-failure-does-not-isolate-broken-component" $+      runWithExtraFilesMultiComponent conf "multi" regressionBatchFailureDoesNotIsolateBrokenComponent   , testCase "r1-failed-file-recovers-after-cradle-fix" $-      runWithExtraFilesMultiComponent "multi" regressionFailedFileRecoversAfterFix-  , testCase "s1-no-stale-outcomes-across-restart-paths" $-      runWithExtraFilesMultiComponent "multi" regressionNoStaleOutcomesOnRestart+      runWithExtraFilesMultiComponent conf "multi" regressionFailedFileRecoversAfterFix+  , expectBrokenWithWholeProjectLoading conf $+    testCase "s1-no-stale-outcomes-across-restart-paths" $+      runWithExtraFilesMultiComponent conf "multi" regressionNoStaleOutcomesOnRestart+  , testCase "s2-no-stale-outcomes-across-restart-paths" $+      runWithExtraFilesMultiComponent conf "multi" regressionNoStaleOutcomesOnRestartNotHealthyInBetween   ] -runWithExtraFilesMultiComponent :: String -> (FilePath -> Session a) -> IO a-runWithExtraFilesMultiComponent dirName action = do+-- | A module the user has written but not added to the cabal file yet is the+-- normal state of code under development, so it has to work: it lies under an+-- import path of a component, which is where GHC's own finder would look for+-- it, so it is compiled as part of that component and only warned about.+undeclaredModuleTests :: SessionLoadingPreferenceConfig -> [TestTree]+undeclaredModuleTests conf =+  [ testCase "a module missing from the cabal file still loads" $+      withUndeclared $ \_dir -> do+        udoc <- openDoc ("a" </> "Undeclared.hs") "haskell"+        assertTypeCheckSuccess udoc "the undeclared module should typecheck"+        diags <- getCurrentDiagnostics udoc+        -- Only the whole project load knows the file is missing from the cabal+        -- file. Loading one component at a time asks the build tool about this+        -- very file, and it answers with the options of the component it lies+        -- in, so nothing distinguishes it from a module that is listed.+        when (conf == wholeProjectConf) $ liftIO $ assertBool+          ("expected a warning about the cabal file, got: " <> show diags)+          (any isMissingFromCabalWarning diags)+  , testCase "importing a module missing from the cabal file still loads" $+      withUndeclared $ \dir -> do+        liftIO $ atomicFileWriteString (dir </> "a" </> "A.hs") $ unlines+          [ "module A where"+          , "import Undeclared"+          , "foo :: Int"+          , "foo = u"+          ]+        adoc <- openDoc ("a" </> "A.hs") "haskell"+        assertTypeCheckSuccess adoc "the importing module should typecheck"+        expectCurrentDiagnostics adoc []+  ]+  where+    withUndeclared act = runWithExtraFilesMultiComponent conf "multi" $ \dir -> do+      -- Undeclared.hs is under a's hs-source-dirs but is in no cabal field+      liftIO $ atomicFileWriteString (dir </> "a" </> "Undeclared.hs") $ unlines+        [ "module Undeclared where"+        , "u :: Int"+        , "u = 1"+        ]+      act dir+    isMissingFromCabalWarning d =+         d ^. L.severity == Just DiagnosticSeverity_Warning+      && "cabal" `T.isInfixOf` (d ^. L.message)++expectBrokenWithWholeProjectLoading :: SessionLoadingPreferenceConfig -> TestTree -> TestTree+expectBrokenWithWholeProjectLoading conf =+  if conf == wholeProjectConf+    then expectFailBecause "We can't load the whole project if the hie.yaml file is invalid"+    else id++onlyWholeProjectLoading :: SessionLoadingPreferenceConfig -> TestTree -> TestTree+onlyWholeProjectLoading conf =+  if conf == wholeProjectConf+    then id+    else ignoreTestBecause "This test only works with PreferMultiWholeProjectLoading"++runWithExtraFilesMultiComponent :: SessionLoadingPreferenceConfig -> String -> (FilePath -> Session a) -> IO a+runWithExtraFilesMultiComponent sesLoading dirName action = do   let vfs = mkIdeTestFs [copyDir dirName]       lspConfig :: Config-      lspConfig = def { sessionLoading = PreferMultiComponentLoading }+      lspConfig = def { componentsLoading = sesLoading }       conf :: TestConfig ()       conf = def         { testPluginDescriptor = dummyPlugin@@ -321,6 +471,11 @@   WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc   liftIO $ assertBool msg (not ideResultSuccess) +setComponentsLoadingPreference :: SessionLoadingPreferenceConfig -> Session ()+setComponentsLoadingPreference pref = do+  setIgnoringConfigurationRequests False+  setHlsConfig def{componentsLoading = pref}+ regressionBatchFailureIsolatesBrokenFile :: FilePath -> Session () regressionBatchFailureIsolatesBrokenFile dir = do   writeBrokenMultiHieYaml dir@@ -333,6 +488,19 @@   liftIO $ assertBool "A should typecheck when B cradle mapping is broken" (ideResultSuccess aRes)   liftIO $ assertBool "B should fail with a broken cradle mapping" (not $ ideResultSuccess bRes) +-- | With whole-project loading a failed component blocks the whole session.+regressionBatchFailureDoesNotIsolateBrokenComponent :: FilePath -> Session ()+regressionBatchFailureDoesNotIsolateBrokenComponent dir = do+  writeBrokenMultiHieYaml dir+  let aPath = dir </> "a/A.hs"+      bPath = dir </> "b/B.hs"+  adoc <- openDoc aPath "haskell"+  bdoc <- openDoc bPath "haskell"+  _ <- waitForBuildQueue+  [aRes, bRes] <- waitForTypeChecksBatched [adoc, bdoc]+  liftIO $ assertBool "A should not typecheck when B cradle mapping is broken" (not $ ideResultSuccess aRes)+  liftIO $ assertBool "B should fail with a broken cradle mapping" (not $ ideResultSuccess bRes)+ regressionFailedFileKeepsFailingUntilFix :: FilePath -> Session () regressionFailedFileKeepsFailingUntilFix dir = do   writeBrokenMultiHieYaml dir@@ -396,10 +564,53 @@     [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ bSource <> "\n"]   assertTypeCheckSuccess bdoc "B should not keep stale failure after cradle restart" +-- | Like 'regressionNoStaleOutcomesOnRestart', but we don't check that+-- unrelated components can still be loaded.+--+-- When we load the whole project, we can't load intermediate components, since the hie.yaml =+-- is broken.+regressionNoStaleOutcomesOnRestartNotHealthyInBetween :: FilePath -> Session ()+regressionNoStaleOutcomesOnRestartNotHealthyInBetween dir = do+  let hiePath = dir </> "hie.yaml"+      bPath = dir </> "b/B.hs"+      cPath = dir </> "c/C.hs"+  validHie <- liftIO $ readFileUtf8 hiePath+  writeBrokenMultiHieYaml dir++  bdoc <- openDoc bPath "haskell"+  assertTypeCheckFailure bdoc "B should fail before cradle fix"++  liftIO $ atomicFileWriteStringUTF8 hiePath (T.unpack validHie)+  notifyHieYamlChanged dir++  cdoc <- openDoc cPath "haskell"+  assertTypeCheckSuccess cdoc "C should typecheck after cradle restart"++  bSource <- liftIO $ readFileUtf8 bPath+  changeDoc bdoc+    [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ bSource <> "\n"]+  assertTypeCheckSuccess bdoc "B should not keep stale failure after cradle restart"++-- | Files loaded by one cradle must not be handed to another cradle's+-- multi-component load. Here @standalone/Standalone.hs@ is owned by a direct+-- cradle; once it is loaded, opening @a/A.hs@ (owned by the root cabal cradle)+-- used to batch the standalone file into @cabal repl@, which cannot map it to+-- any component and fails wholesale, poisoning the load of A.+crossCradleBatchIsolationTest :: SessionLoadingPreferenceConfig -> TestTree+crossCradleBatchIsolationTest conf =+  testCase "direct-cradle-file-does-not-poison-cabal-load" $+    runWithExtraFilesMultiComponent conf "cross-cradle" $ \dir -> do+      let standalonePath = dir </> "standalone/Standalone.hs"+          aPath = dir </> "a/A.hs"+      sdoc <- openDoc standalonePath "haskell"+      assertTypeCheckSuccess sdoc "standalone file (direct cradle) should typecheck"+      adoc <- openDoc aPath "haskell"+      assertTypeCheckSuccess adoc+        "cabal-cradle file should typecheck after a direct-cradle file was loaded"+ -- Like simpleMultiTest but open the files in component 'a' in a separate session-simpleMultiDefTest :: FilePath -> TestTree-simpleMultiDefTest variant = ignoreForWindows $ testCase testName $-    runWithExtraFiles variant $ \dir -> do+simpleMultiDefTest :: FilePath -> Session ()+simpleMultiDefTest = \dir -> do     let aPath = dir </> "a/A.hs"         bPath = dir </> "b/B.hs"     adoc <- openDoc aPath "haskell"@@ -411,15 +622,11 @@     let fooL = mkL (adoc ^. L.uri) 2 0 2 3     checkDefs locs (pure [fooL])     expectNoMoreDiagnostics 0.5-  where-    testName = multiTestName variant "def-test"-    ignoreForWindows-        | testName == "simple-multi-def-test" = ignoreInEnv [HostOS Windows] "Test is flaky on Windows, see #4270"-        | otherwise = id -multiRexportTest :: TestTree-multiRexportTest =+multiRexportTest :: SessionLoadingPreferenceConfig -> TestTree+multiRexportTest conf =   testCase "multi-unit-reexport-test"  $ runWithExtraFiles "multi-unit-reexport" $ \dir -> do+    setComponentsLoadingPreference conf     let cPath = dir </> "c/C.hs"     cdoc <- openDoc cPath "haskell"     WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc@@ -429,10 +636,50 @@     checkDefs locs (pure [fooL])     expectNoMoreDiagnostics 0.5 -sessionDepsArePickedUp :: TestTree-sessionDepsArePickedUp = testWithDummyPluginEmpty'+-- | Tests that import resolution respects home unit boundaries: which units+-- are visible from the importing unit, and in which order they are searched.+multiUnitImportResolutionTests :: SessionLoadingPreferenceConfig -> [TestTree]+multiUnitImportResolutionTests conf =+  [ testCase "visibility" $ runWithExtraFiles "multi-unit-visibility" $ \_dir -> do+      setComponentsLoadingPreference conf+      -- bbb does not depend on aaa, so aaa's module Priv must not be visible+      bdoc <- openDoc ("bbb" </> "B.hs") "haskell"+      expectDiagnostics [("bbb" </> "B.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module", Nothing)])]+      locs <- getDefinitions bdoc (Position 1 7)+      checkDefs locs (pure [ExpectNoDefinitions])+  , testCase "own unit shadows other units" $ runWithExtraFiles "multi-unit-shadow" $ \dir -> do+      setComponentsLoadingPreference conf+      -- M lives in unit aaa: its import of X must resolve to aaa's own X,+      -- not the X of the unrelated unit zzz+      mdoc <- openDoc ("aaa" </> "M.hs") "haskell"+      assertTypeCheckSuccess mdoc "M should typecheck using aaa's own X"+      locs <- getDefinitions mdoc (Position 1 7)+      assertDefsFile (dir </> "aaa" </> "X.hs") locs+  , ignoreForGhcVersions [GHC96, GHC98, GHC910] "Renaming reexports only exist from GHC 9.12"+    $ testCase "renaming reexport resolves to the original module" $+      runWithExtraFiles "multi-unit-reexport-rename" $ \dir -> do+      setComponentsLoadingPreference conf+      -- rrr reexports Internal.Impl as Facade, so importing Facade has to+      -- find rrr's Internal.Impl, under its own name+      mdoc <- openDoc ("mmm" </> "M.hs") "haskell"+      assertTypeCheckSuccess mdoc "M should typecheck through the renaming reexport"+      locs <- getDefinitions mdoc (Position 1 7)+      assertDefsFile (dir </> "rrr" </> "Internal" </> "Impl.hs") locs+  , testCase "package import picks the named unit" $ runWithExtraFiles "multi-unit-pkgimport" $ \dir -> do+      setComponentsLoadingPreference conf+      -- the package-qualified import names unit ppp: it must resolve to+      -- ppp's A, not qqq's+      mdoc <- openDoc ("mmm" </> "M.hs") "haskell"+      assertTypeCheckSuccess mdoc "M should typecheck using ppp's A"+      locs <- getDefinitions mdoc (Position 1 13)+      assertDefsFile (dir </> "ppp" </> "A.hs") locs+  ]++sessionDepsArePickedUp :: SessionLoadingPreferenceConfig -> TestTree+sessionDepsArePickedUp conf = testWithDummyPluginEmpty'   "session-deps-are-picked-up"   $ \dir -> do+    setComponentsLoadingPreference conf     liftIO $       atomicFileWriteStringUTF8         (dir </> "hie.yaml")
ghcide-test/exe/DiagnosticTests.hs view
@@ -187,6 +187,113 @@       let contentA = T.unlines [ "module ModuleA where" ]       _ <- createDoc (tmpDir </> "ModuleA.hs") "haskell" contentA       expectDiagnostics [(tmpDir </> "ModuleB.hs", [])]+    -- The file watch capability is disabled so that opening a document is the+    -- only thing that registers it: lsp-test otherwise sends a watched file+    -- notification for it first, which would register it through the watcher+    -- instead.+  , testCase "add missing hs-boot (unsaved)" $+    runSessionWithTestConfig def+        { testPluginDescriptor = dummyPlugin+        , testConfigCaps = lspTestCapsNoFileWatches+        , testDirLocation =+            Right (mkIdeTestFs+              [ directCradle ["ModuleA", "ModuleB"]+              , file "ModuleA.hs" (text "module ModuleA where\n")+              , file "ModuleB.hs" (text "module ModuleB where\nimport {-# SOURCE #-} ModuleA ()\n")+              ])+        }+    $ \dir -> do+      -- ModuleA.hs-boot is a candidate location of the declared target+      -- ModuleA, so opening it later reuses the cached session instead of+      -- consulting the cradle again. Resolving the import must not depend on+      -- that reload happening.+      _ <- openDoc (dir </> "ModuleB.hs") "haskell"+      expectDiagnostics [(dir </> "ModuleB.hs", [(DiagnosticSeverity_Error, (1, 22), "Could not find module", Nothing)])]+      _ <- createDoc (dir </> "ModuleA.hs-boot") "haskell" "module ModuleA where"+      expectDiagnostics [(dir </> "ModuleB.hs", [])]+  , testCase "closing an unsaved module unregisters it" $+    runSessionWithTestConfig def+        { testPluginDescriptor = dummyPlugin+        , testConfigCaps = lspTestCapsNoFileWatches+        , testDirLocation = Right (mkIdeTestFs [directCradle ["ModuleA", "ModuleB"]])+        }+    $ \dir -> do+      adoc <- createDoc (dir </> "ModuleA.hs") "haskell" "module ModuleA where"+      bdoc <- createDoc (dir </> "ModuleB.hs") "haskell" $ T.unlines+        [ "module ModuleB where"+        , "import ModuleA ()"+        ]+      WaitForIdeRuleResult{ideResultSuccess} <- waitForAction "TypeCheck" bdoc+      liftIO $ assertBool "ModuleB should typecheck against the open ModuleA" ideResultSuccess+      closeDoc adoc+      -- Closing also makes ModuleA itself report that it is gone, so only look+      -- at the import resolution, which is what "not found" is reported by+      diags <- waitForDiagnosticsSource "not found"+      liftIO $ assertBool ("expected ModuleA to be unresolvable, got: " <> show diags)+        (any (T.isInfixOf "ModuleA" . (^. L.message)) diags)+  , testWithDummyPlugin "import path order determines module file"+        (mkIdeTestFs+          [ -- GHC searches import paths in order: with -isrcA -isrcB, a module+            -- present in both directories must resolve to the file in srcA.+            directCradle ["-isrcA", "-isrcB", "T", "C"]+          , directory "srcA"+            [ file "C.hs" $ sources+              [ "module C where"+              , "cA :: ()"+              , "cA = ()"+              ]+            , file "T.hs" $ sources+              [ "module T where"+              , "import C"+              , "t :: ()"+              , "t = cA"+              ]+            ]+          , directory "srcB"+            [ file "C.hs" $ sources+              [ "module C where"+              , "cB :: ()"+              , "cB = ()"+              ]+            ]+          ]+        ) $ do+      tdoc <- openDoc ("srcA" </> "T.hs") "haskell"+      WaitForIdeRuleResult{ideResultSuccess} <- waitForAction "TypeCheck" tdoc+      liftIO $ assertBool "T should typecheck using srcA's C" ideResultSuccess+      expectCurrentDiagnostics tdoc []+      locs <- getDefinitions tdoc (Position 1 7)+      assertDefsFile ("srcA" </> "C.hs") locs+  , testWithDummyPlugin' "unlistable directory hides only itself"+        (mkIdeTestFs+          [ directCradle ["-isrc", "B"]+          , directory "src"+            [ file "B.hs" $ sources+              [ "module B where"+              , "import A ()"+              ]+            , file "A.hs" $ sources+              [ "module A where"+              ]+            , directory "Locked" []+            ]+          ]+        ) $ \ dir -> do+      -- A directory we cannot list must not take the modules next to it down+      -- with it. On Windows the directory stays listable and the test passes+      -- trivially.+      let locked = dir </> "src" </> "Locked"+      liftIO $ do+        setPermissions locked emptyPermissions+      bdoc <- openDoc ("src" </> "B.hs") "haskell"+      WaitForIdeRuleResult{ideResultSuccess} <- waitForAction "TypeCheck" bdoc+      -- Restore before asserting, so that a failure still leaves a removable+      -- temporary directory behind+      liftIO $ setPermissions locked+        $ setOwnerReadable True $ setOwnerSearchable True+        $ setOwnerWritable True emptyPermissions+      liftIO $ assertBool "B should find A in the same directory" ideResultSuccess+      expectCurrentDiagnostics bdoc []   , testWithDummyPluginEmpty "cyclic module dependency" $ do       let contentA = T.unlines             [ "module ModuleA where"@@ -291,6 +398,20 @@       _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot       _ <- createDoc "ModuleC.hs" "haskell" contentC       expectDiagnostics [("ModuleC.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding", Just "GHC-38417")])]+  , testWithDummyPluginEmpty "hs-boot without a source file is not a module" $ do+      -- GHC looks for the source file and takes the boot file beside it, so a+      -- boot file on its own provides nothing+      let contentB = T.unlines+            [ "module ModuleB where"+            , "import {-# SOURCE #-} ModuleA"+            ]+      let contentAboot = T.unlines+            [ "module ModuleA where"+            ]+      _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      expectDiagnostics+        [("ModuleB.hs", [(DiagnosticSeverity_Error, (1, 22), "Could not find module", Nothing)])]   , testWithDummyPluginEmpty "redundant import" $ do       let contentA = T.unlines ["module ModuleA where"]       let contentB = T.unlines@@ -450,7 +571,6 @@      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@@ -464,10 +584,12 @@       [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'", Just "GHC-83865")])       ] -    -- Open A and edit to fix the type error-    adoc <- createDoc aPath "haskell" aSource-    changeDoc adoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $-                    T.unlines ["module A where", "import B", "x :: Bool", "x = y"]]+    -- Open A with the type error already fixed. If we open it as it is on disk+    -- and fix it afterwards, we race with a republish of the error: A was a+    -- dependency, so the error was deferred, and we typecheck a file of+    -- interest without deferring, which gives a different diagnostic.+    _adoc <- createDoc aPath "haskell" $+      T.unlines ["module A where", "import B", "x :: Bool", "x = y"]      expectDiagnostics       [ ( "P.hs",
+ ghcide-test/exe/EpsPollutionTests.hs view
@@ -0,0 +1,99 @@+-- | Regression test: edits that break typechecking can leave HLS's+-- shared 'ExternalPackageState' ('EPS') polluted with interfaces and+-- instances from /home-package/ modules. The next successful typecheck+-- of a module that also legitimately has those home modules in its HPT+-- reports \"Overlapping instance\" with both matches pointing at the+-- same source location, because 'tcGetInstEnvs' returns the same+-- 'ClsInst' twice (once via @ie_global@ from the EPS, once via+-- @ie_local@ from 'hptInstancesBelow').+--+-- The pollution entered through 'Development.IDE.Spans.Documentation.mkDocMap'.+-- Its 'Rules.GetDocMap' rule read three inputs via independent+-- @useWithStale_@ calls: 'TypeCheck', 'GhcSessionDeps' and 'GetHieAst'.+-- These three can diverge: an edit that merely changes imports lets+-- 'GhcSessionDeps' re-evaluate (fresh, with a different HPT) while+-- 'TypeCheck' and 'GetHieAst' fall back to their last-successful values.+-- If the stale 'RefMap' references a name whose module is no longer in+-- the fresh HPT, 'mkDocMap' asks 'getDocsBatch' for its docs;+-- 'loadSysInterface' does not find the module in the HUG and calls+-- 'loadInterface', which puts the home-module interface -- /with its+-- instance environment/ -- into the shared EPS @IORef@. The EPS never+-- evicts anything, so the pollution is permanent for the session.+module EpsPollutionTests (tests) where++import           Config                      (Expect (ExpectHoverText),+                                              runWithExtraFiles)+import           Control.Lens                ((^.))+import           Control.Monad               (void)+import qualified Data.Text                   as T+import           Development.IDE.GHC.Util    (readFileUtf8)+import           Hover+import qualified Language.LSP.Protocol.Lens  as L+import           Language.LSP.Protocol.Types+import           Language.LSP.Test+import           System.FilePath+import           Test.Hls++tests :: TestTree+tests = testGroup "eps-pollution"+    [ staleHieProvokesOverlapping+    ]++-- The fixture at ghcide-test/data/multi-unit-eps-pollution/ sets up two+-- home units: unit @a@ provides module @A@ which defines @MyClass@ and+-- @instance MyClass AType@; unit @c@ provides module @C@ which imports+-- @A@ and uses @myMethod@ on an @AType@ value (forcing instance+-- resolution).++staleHieProvokesOverlapping :: TestTree+staleHieProvokesOverlapping =+  testCase "Stale RefMap must not provoke overlapping-instance error" $+  runWithExtraFiles "multi-unit-eps-pollution" $ \dir -> do+    let cPath = dir </> "c" </> "C.hs"+    originalC <- liftIO $ readFileUtf8 cPath+    let brokenC = T.replace "import A" "" originalC+    cdoc <- openDoc cPath "haskell"+    void $ waitForTypecheck cdoc+    -- Hovering triggers the hover pipeline, which forces GetDocMap.+    -- While C is healthy this populates GetHieAst with a RefMap+    -- referencing A's names -- the stale value we rely on below.+    hover <- getHover cdoc (hoverOnMyMethod originalC)+    checkHover hover [ExpectHoverText ["myMethod", "MyClass"]]++    -- Break C's import of A. C fails to typecheck, but GhcSessionDeps+    -- re-evaluates successfully (it only needs the import list) with an+    -- HPT that no longer contains A. A further hover forces GetDocMap+    -- to run with the fresh GhcSessionDeps alongside the stale RefMap;+    -- loadSysInterface(A) then runs and pollutes the EPS.+    changeDoc cdoc [TextDocumentContentChangeEvent . InR .+      TextDocumentContentChangeWholeDocument $ brokenC]++    void $ waitForDiagnosticsFrom cdoc+    void $ getHover cdoc (hoverOnMyMethod brokenC)+    -- Repair C. The next typecheck legitimately has A in its HPT; with+    -- the polluted EPS it also has A's ClsInst in eps_inst_env, so+    -- instance resolution for 'myMethod x :: AType -> String' finds+    -- two matches with identical source locations.+    changeDoc cdoc [TextDocumentContentChangeEvent . InR .+      TextDocumentContentChangeWholeDocument $ originalC]+    diags <- waitForDiagnosticsFrom cdoc+    liftIO $ assertBool+      ("Expected no overlapping-instance errors, got diagnostics:\n"+        ++ unlines (map (T.unpack . (^. L.message)) diags))+      (not (any isOverlappingInstance diags))+  where+    isOverlappingInstance d =+      "Overlapping instance" `T.isInfixOf` (d ^. L.message)++-- | 'Position' at the first occurrence of @myMethod@ in the given source.+--   Computed rather than hard-coded because the broken variant has one+--   fewer line than the original.+hoverOnMyMethod :: T.Text -> Position+hoverOnMyMethod src =+    case [ Position row (fromIntegral (T.length prefix))+         | (row, line) <- zip [0..] (T.lines src)+         , let (prefix, rest) = T.breakOn "myMethod" line+         , not (T.null rest)+         ] of+      p : _ -> p+      []    -> error "hoverOnMyMethod: no occurrence of 'myMethod'"
ghcide-test/exe/FindDefinitionAndHoverTests.hs view
@@ -1,26 +1,20 @@ {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE ViewPatterns       #-}  module FindDefinitionAndHoverTests (tests) where -import           Control.Monad-import           Data.Foldable+import           Config+import           Control.Lens               ((^.)) import           Data.Maybe import qualified Data.Text                  as T+import           Development.IDE.Test       (expectDiagnostics)+import           Hover import qualified Language.LSP.Protocol.Lens as L import           Language.LSP.Test import           System.Info.Extra          (isWindows)--import           Config-import           Control.Category           ((>>>))-import           Control.Lens               ((^.))-import           Development.IDE.Test       (expectDiagnostics,-                                             standardizeQuotes)-import           Hover+import           Ide.Types import           Test.Hls import           Test.Hls.FileSystem        (copyDir)-import           Text.Regex.TDFA            ((=~))  tests :: TestTree tests = let@@ -34,64 +28,6 @@         check found targetRange  --  checkHover :: (HasCallStack) => Maybe Hover -> Session [Expect] -> Session ()-  checkHover hover expectations = traverse_ check =<< expectations where--    check :: (HasCallStack) => Expect -> Session ()-    check expected =-      case hover of-        Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"-        Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg})-                  ,_range    = rangeInHover } ->-          case expected of-            ExpectRange  expectedRange -> checkHoverRange expectedRange rangeInHover msg-            ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg-            ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets-            ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets-            ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool)-            ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover-            _ -> pure () -- all other expectations not relevant to hover-        _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover--  extractLineColFromHoverMsg :: T.Text -> [T.Text]-  extractLineColFromHoverMsg =-    -- Hover messages contain multiple lines, and we are looking for the definition-    -- site-    T.lines-    -- The line we are looking for looks like: "*Defined at /tmp/GotoHover.hs:22:3*"-    -- So filter by the start of the line-    >>> mapMaybe (T.stripPrefix "*Defined at")-    -- There can be multiple definitions per hover message!-    -- See the test "field in record definition" for example.-    -- The tests check against the last line that contains the above line.-    >>> last-    -- [" /tmp/", "22:3*"]-    >>> T.splitOn (sourceFileName <> ":")-    -- "22:3*"-    >>> last-    -- ["22:3", ""]-    >>> T.splitOn "*"-    -- "22:3"-    >>> head-    -- ["22", "3"]-    >>> T.splitOn ":"--  checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()-  checkHoverRange expectedRange rangeInHover msg =-    let-      lineCol = extractLineColFromHoverMsg msg-      -- looks like hovers use 1-based numbering while definitions use 0-based-      -- turns out that they are stored 1-based in RealSrcLoc by GHC itself.-      adjust Position{_line = l, _character = c} =-        Position{_line = l + 1, _character = c + 1}-    in-    case map (read . T.unpack) lineCol of-      [l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c-      _     -> liftIO $ assertFailure $-        "expected: " <> show ("[...]" <> sourceFileName <> ":<LINE>:<COL>**[...]", Just expectedRange) <>-        "\n but got: " <> show (msg, rangeInHover)-   sourceFilePath = T.unpack sourceFileName   sourceFileName = "GotoHover.hs" @@ -104,15 +40,17 @@           , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _", Just "GHC-88464")])           ]]     , testGroup "type-definition" typeDefinitionTests-    , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ]+    , testGroup "hover-record-dot-syntax" recordDotSyntaxTests+    , testGroup "source-and-doc-links" linkToTests+    ]    typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 sourceFilePath (pure tcData) "Saturated data con"                         , tst (getTypeDefinitions, checkDefs) aL20 sourceFilePath (pure [ExpectNoDefinitions]) "Polymorphic variable"]    recordDotSyntaxTests =-    [ tst (getHover, checkHover) (Position 17 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent"-    , tst (getHover, checkHover) (Position 17 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child"-    , tst (getHover, checkHover) (Position 17 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child"+    [ tst (getHover, checkHoverM) (Position 17 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent"+    , tst (getHover, checkHoverM) (Position 17 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child"+    , tst (getHover, checkHoverM) (Position 17 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child"     ]    test :: (HasCallStack) => (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b)@@ -128,7 +66,7 @@     ( runDef   $ tst def   look sourceFilePath expect title     , runHover $ tst hover look sourceFilePath expect title ) where       def   = (getDefinitions, checkDefs)-      hover = (getHover      , checkHover)+      hover = (getHover      , checkHoverM)    -- search locations            expectations on results   -- TODO: Lookup of record field should return exactly one result@@ -253,3 +191,63 @@    testWithDummyPlugin ("hover: Does " ++ fp ++ " compile") (mkIdeTestFs [copyDir "hover"]) $ do     _ <- openDoc fp "haskell"     diag++linkToTests :: [TestTree]+linkToTests =+  [ testGroup "LinkToHackage" linkToHackageTests+  , testGroup "LinkToLocal" linkToLocalTests+  ]+  where+    linkToHackageTests =+      [ testGroup "doc link uses hackage URL"+        [ testWithConfig "function" (hoverConfig (def { linkDocTo = LinkToHackage })) $+            hoverCheck (Position 24 8) "GotoHover.hs"+              [ ExpectHoverTextRegex (hackageUrlRegex "Documentation" "text" "v:pack") ]+        , testWithConfig "type" (hoverConfig (def { linkDocTo = LinkToHackage })) $+            hoverCheck (Position 8 11) "GotoHover.hs"+              [ ExpectHoverTextRegex (hackageUrlRegex "Documentation" "text" "t:Text") ]+        ]+        , testGroup "source link uses hackage URL"+        [ testWithConfig "function" (hoverConfig (def { linkSourceTo = LinkToHackage })) $+          hoverCheck (Position 24 8) "GotoHover.hs"+            [ ExpectHoverTextRegex (hackageUrlRegex "Source" "text" "pack") ]+        , testWithConfig "type" (hoverConfig (def { linkSourceTo = LinkToHackage })) $+          hoverCheck (Position 8 11) "GotoHover.hs"+            [ ExpectHoverTextRegex (hackageUrlRegex "Source" "text" "Text") ]+        ]+      ]+    linkToLocalTests =+      [ testGroup "doc link does not use hackage URL"+        [ testWithConfig "function" (hoverConfig (def { linkDocTo = LinkToLocal })) $+            hoverCheck (Position 24 8) "GotoHover.hs"+              [ ExpectHoverExcludeText [hackageUrlPrefix "Documentation"] ]+        , testWithConfig "type" (hoverConfig (def { linkDocTo = LinkToLocal })) $+            hoverCheck (Position 8 11) "GotoHover.hs"+              [ ExpectHoverExcludeText [hackageUrlPrefix "Documentation"] ]+        ]+        , testGroup "source link does not use hackage URL"+        [ testWithConfig "function" (hoverConfig (def { linkSourceTo = LinkToLocal })) $+          hoverCheck (Position 24 8) "GotoHover.hs"+            [ ExpectHoverExcludeText [hackageUrlPrefix "Source"] ]+        , testWithConfig "type" (hoverConfig (def { linkSourceTo = LinkToLocal })) $+          hoverCheck (Position 8 11) "GotoHover.hs"+            [ ExpectHoverExcludeText [hackageUrlPrefix "Source"] ]+        ]+      ]+    hackageUrlPrefix linkText = "\\[" <> linkText <> "\\]\\(https://hackage\\.haskell\\.org/package/"+    hackageUrlRegex linkText pkg anchor+      = hackageUrlPrefix linkText+        <> pkg <> "-[0-9\\.]+/docs/[^#)]+\\.html#" <> anchor+    hoverConfig lspConf = def+        { testPluginDescriptor = dummyPlugin+        , testDirLocation = Right (mkIdeTestFs [copyDir "hover"])+        , testConfigCaps = lspTestCaps+        , testShiftRoot = True+        , testLspConfig = lspConf+        }+    hoverCheck pos fp expects = do+        doc <- openDoc fp "haskell"+        waitForProgressDone+        _ <- waitForTypecheck doc+        hover <- getHover doc pos+        checkHover hover expects
ghcide-test/exe/GarbageCollectionTests.hs view
@@ -30,12 +30,12 @@         , testWithDummyPluginEmpty' "are deleted from the state" $ \dir -> do             liftIO $ atomicFileWriteString (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)+            let garbageStillPresent = Set.intersection (Set.fromList garbage) (Set.fromList keys1)+            liftIO $ garbageStillPresent @?= mempty          , testWithDummyPluginEmpty' "are not regenerated unless needed" $ \dir -> do             liftIO $ atomicFileWriteString (dir </> "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}"@@ -43,13 +43,13 @@             _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+            let garbageStillPresent = Set.intersection (Set.fromList garbage) (Set.fromList keysAfterGC)             liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state"-                (length keysAfterGC < length keysBeforeGC)+                (Set.null garbageStillPresent)              -- re-typecheck B and check that the keys for A have not materialized back             _docB <- generateGarbage "B" dir
ghcide-test/exe/Hover.hs view
@@ -1,10 +1,19 @@-module Hover where+module Hover (+  assertFoundIn,+  assertNotFoundIn,+  checkHover,+  checkHoverM,+) where  import           Config+import           Control.Arrow+import           Control.Lens import           Control.Monad import           Data.Foldable-import qualified Data.Text            as T+import           Data.Maybe                 (mapMaybe)+import qualified Data.Text                  as T import           Development.IDE.Test+import qualified Language.LSP.Protocol.Lens as L import           Test.Hls import           Text.Regex.TDFA @@ -21,20 +30,79 @@         (not . T.isInfixOf part $ whole)  checkHover :: (HasCallStack) => Maybe Hover -> [Expect] -> Session ()-checkHover hover expectations = traverse_ check expectations+checkHover hover expectations = checkHoverM hover (pure expectations)++checkHoverM :: (HasCallStack) => Maybe Hover -> Session [Expect] -> Session ()+checkHoverM hover expectations =+  traverse_ check =<< expectations   where     check :: (HasCallStack) => Expect -> Session ()     check expected =       case hover of         Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"         Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg})-                  ,_range    = _rangeInHover } ->+                  ,_range    = rangeInHover } ->           case expected of-            ExpectRange  _expectedRange -> liftIO $ assertFailure $ "ExpectRange assertion not implemented, yet."-            ExpectHoverRange _expectedRange -> liftIO $ assertFailure $ "ExpectHoverRange assertion not implemented, yet."+            ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg+            ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg             ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets             ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets             ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool)             ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover             _ -> pure () -- all other expectations not relevant to hover         _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover++    checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()+    checkHoverRange expectedRange rangeInHover msg =+      let+        lineCol = extractLineColFromHoverMsg msg+        -- looks like hovers use 1-based numbering while definitions use 0-based+        -- turns out that they are stored 1-based in RealSrcLoc by GHC itself.+        adjust Position{_line = l, _character = c} =+          Position{_line = l + 1, _character = c + 1}+      in+      case map (read . T.unpack) lineCol of+        [l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c+        _     -> liftIO $ assertFailure $+          "expected: " <> show ("[...]<FILE_NAME>:<LINE>:<COL>**[...]", Just expectedRange) <>+          "\n but got: " <> show (msg, rangeInHover)++-- | Extract the source position from a message such as+--+-- @+--   "*Defined at C://file-name.hs:22:3*"+-- @+--+-- >>> extractLineColFromHoverMsg "*Defined at C://tmp/GotoHover.hs:22:3*"+-- ["22","3"]+--+-- >>> extractLineColFromHoverMsg "*Defined at /tmp/GotoHover.hs:22:3*"+-- ["22","3"]+extractLineColFromHoverMsg :: T.Text -> [T.Text]+extractLineColFromHoverMsg =+  -- Windows: "*Defined at C://tmp/GotoHover.hs:22:3*"+  -- Linux:   "*Defined at /tmp/GotoHover.hs:22:3*"+  T.lines+  -- Windows: ["*Defined at C://tmp/GotoHover.hs:22:3*"]+  -- Linux:   ["*Defined at /tmp/GotoHover.hs:22:3*"]+  >>> mapMaybe (T.stripPrefix "*Defined at ")+  -- Windows: ["C://tmp/GotoHover.hs:22:3*"]+  -- Linux:   ["/tmp/GotoHover.hs:22:3*"]+  >>> last+  -- Windows: "C://tmp/GotoHover.hs:22:3*"+  -- Linux:   "/tmp/GotoHover.hs:22:3*"+  >>> T.dropEnd 1+  -- Windows: "C://tmp/GotoHover.hs:22:3"+  -- Linux:   "/tmp/GotoHover.hs:22:3"+  >>> T.splitOn ":"+  -- Windows: ["C", "//tmp/GotoHover.hs", "22", "3"]+  -- Linux:   ["/tmp/GotoHover.hs", "22", "3"]+  >>> reverse+  -- Windows: ["3", "22", "//tmp/GotoHover.hs", "C"]+  -- Linux:   ["3", "22", "/tmp/GotoHover.hs"]+  >>> take 2+  -- Windows: ["3", "22"]+  -- Linux:   ["3", "22"]+  >>> reverse+  -- Windows: ["22", "3"]+  -- Linux:   ["22", "3"]
ghcide-test/exe/IfaceTests.hs view
@@ -28,6 +28,7 @@     , ifaceErrorTest2     , ifaceErrorTest3     , ifaceTHTest+    , ifaceTransitivePropagationTest     ]  @@ -136,6 +137,37 @@       ]      expectNoMoreDiagnostics 2++-- | Saving a file should propagate type errors to its transitive reverse+-- dependencies, not just immediate importers. The fixture is a 3-module chain+-- M0 <- M1 <- M2 where M2 does not import M0 directly. Flipping M0's exported+-- type from Int to Bool must surface a diagnostic in M2.+ifaceTransitivePropagationTest :: TestTree+ifaceTransitivePropagationTest = testWithExtraFiles "iface-transitive-propagation" "transitive-recomp" $ \dir -> do+    configureCheckProject False+    let m0Path = dir </> "M0.hs"+        m2Path = dir </> "M2.hs"+    m0Source <- liftIO $ readFileUtf8 m0Path+    m2Source <- liftIO $ readFileUtf8 m2Path+    -- Open M2 first to bring the whole chain (M2 -> M1 -> M0) into the module+    -- graph. After this we close M2 so it leaves the FOI set.+    m2doc <- createDoc m2Path "haskell" m2Source+    expectDiagnostics+      [("M1.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding", Just "GHC-38417")])]+    closeDoc m2doc+    m0doc <- createDoc m0Path "haskell" m0Source+    -- Flip M0's exported value from Int to Bool.+    changeDoc m0doc+      [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $+          T.unlines ["module M0 (m0val) where", "m0val :: Bool", "m0val = True"]]+    sendNotification SMethod_TextDocumentDidSave (DidSaveTextDocumentParams m0doc Nothing)+    -- m1val is type-inferred and becomes Bool, so M2 (which has+    -- m2val :: Int = m1val) now fails. The M2 diagnostic only reaches the+    -- client if typecheckParents walks the transitive reverse-dep set.+    expectDiagnostics+      [ ("M1.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding", Just "GHC-38417")])+      , ("M2.hs", [(DiagnosticSeverity_Error, (5, 8), "Couldn't match expected type 'Int' with actual type 'Bool'", Just "GHC-83865")])+      ]  ifaceErrorTest3 :: TestTree ifaceErrorTest3 = testWithExtraFiles "iface-error-test-3" "recomp" $ \dir -> do
ghcide-test/exe/Main.hs view
@@ -33,6 +33,7 @@ import qualified HieDbRetry import           Test.Tasty import           Test.Tasty.Ingredients.Rerun+import           Test.Hls (defaultTestRunner)  import           AsyncTests import           BootTests@@ -44,6 +45,7 @@ import           CradleTests import           DependentFileTest import           DiagnosticTests+import           EpsPollutionTests import           ExceptionTests import           FindDefinitionAndHoverTests import           FindImplementationAndHoverTests@@ -71,7 +73,7 @@ main :: IO () main = do   -- We mess with env vars so run single-threaded.-  defaultMainWithRerun $ testGroup "ghcide"+  defaultTestRunner $ testGroup "ghcide"     [ OpenCloseTest.tests     , InitializeResponseTests.tests     , CompletionTests.tests@@ -94,6 +96,7 @@     , WatchedFileTests.tests     , CradleTests.tests     , DependentFileTest.tests+    , EpsPollutionTests.tests     , NonLspCommandLine.tests     , IfaceTests.tests     , BootTests.tests
ghcide-test/exe/THTests.hs view
@@ -72,6 +72,8 @@     -- Regression test for https://github.com/haskell/haskell-language-server/issues/891     , thLinkingTest False     , thLinkingTest True+    , thStaleBytecodeTest+    , thStaleBytecodeDeepTest     , testWithDummyPluginEmpty "findsTHIdentifiers" $ do         let sourceA =               T.unlines@@ -267,6 +269,50 @@     name = "reloading-th-test" <> if unboxed then "-unboxed" else ""     dir | unboxed = "THUnboxed"         | otherwise = "TH"++-- | Test that a value change in a dependency without an interface change is+-- seen by splices: the loaded bytecode of the intermediate modules must be+-- relinked against the new leaf even though they are not recompiled.+--+-- The leaf and C are open; the intermediate modules are intentionally not, so+-- they stay non-FOI and are not recompiled when the leaf changes.+thStaleBytecodeTestFor :: String -> String -> FilePath -> T.Text -> TestTree+thStaleBytecodeTestFor name dataDir leafFile tag = testCase name $ runWithExtraFiles dataDir $ \dir -> do+    let aPath = dir </> leafFile+        cPath = dir </> "C.hs"++    aSource <- liftIO $ readFileUtf8 aPath -- <leaf> = 1+    cSource <- liftIO $ readFileUtf8 cPath -- c = $(reportWarning (tag ++ show <top>) >> [| <top> |])++    adoc <- createDoc aPath "haskell" aSource+    cdoc <- createDoc cPath "haskell" cSource++    expectDiagnostics [("C.hs", [(DiagnosticSeverity_Warning, (7, 5), tag <> " 1", Nothing)])]++    -- Change the value of the leaf without changing its interface, so the+    -- modules in between are not recompiled and only their loaded bytecode+    -- can go stale+    changeDoc adoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $+        T.replace "= 1" "= 2" aSource]+    -- sentinel warning so a stale splice result fails fast instead of timing out+    changeDoc cdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $+        cSource <> "foo=()"]++    expectDiagnostics+        [("C.hs", [ (DiagnosticSeverity_Warning, (7, 5), tag <> " 2", Nothing)+                  , (DiagnosticSeverity_Warning, (8, 0), "Top-level binding", Just "GHC-38417")+                  ])]++    closeDoc adoc+    closeDoc cdoc++-- | C splices a value from B, which imports it from A. A is edited.+thStaleBytecodeTest :: TestTree+thStaleBytecodeTest = thStaleBytecodeTestFor "th-stale-bytecode" "THUnload" "A.hs" "b is"++-- | C splices a6, whose value flows through the chain A6 <- ... <- A1. A1 is edited.+thStaleBytecodeDeepTest :: TestTree+thStaleBytecodeDeepTest = thStaleBytecodeTestFor "th-stale-bytecode-deep" "THUnloadDeep" "A1.hs" "a6 is"  thLinkingTest :: Bool -> TestTree thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do
ghcide-test/exe/UnitTests.hs view
@@ -1,41 +1,54 @@  module UnitTests (tests) where -import           Config                            (mkIdeTestFs)+import           Config                                       (mkIdeTestFs) import           Control.Concurrent-import           Control.Monad.IO.Class            (liftIO)+import           Control.Monad.IO.Class                       (liftIO)+import qualified Data.HashMap.Strict                          as HMS+import qualified Data.IntMap.Strict                           as IntMap+import qualified Data.IntSet                                  as IntSet import           Data.IORef-import           Data.IORef.Extra                  (atomicModifyIORef_)+import           Data.IORef.Extra                             (atomicModifyIORef_) import           Data.List.Extra-import           Data.String                       (IsString (fromString))-import qualified Data.Text                         as T-import           Development.IDE.Core.FileStore    (getModTime)-import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide-import qualified Development.IDE.Types.Diagnostics as Diagnostics+import           Data.String                                  (IsString (fromString))+import qualified Data.Text                                    as T+import           Development.IDE.Core.FileStore               (getModTime)+import           Development.IDE.Import.DependencyInformation (DependencyInformation (..),+                                                               FilePathId (..),+                                                               PathIdMap (..),+                                                               ShowableModuleEnv (..),+                                                               transitiveReverseDependencies)+import           Development.IDE.Import.FindImports           (ArtifactsLocation (..))+import qualified Development.IDE.Plugin.HLS.GhcIde            as Ghcide+import qualified Development.IDE.Types.Diagnostics            as Diagnostics import           Development.IDE.Types.Location import qualified FuzzySearch-import           Ide.Logger                        (Recorder, WithPriority)-import           Ide.PluginUtils                   (pluginDescToIdePlugins)+import           GHC.Unit.Module.Env                          (emptyModuleEnv)+import           GHC.Unit.Module.Graph                        (emptyMG)+import           Ide.Logger                                   (Recorder,+                                                               WithPriority)+import           Ide.PluginUtils                              (pluginDescToIdePlugins) import           Ide.Types import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Types       hiding-                                                   (SemanticTokenAbsolute (..),-                                                    SemanticTokenRelative (..),-                                                    SemanticTokensEdit (..),-                                                    mkRange)+import           Language.LSP.Protocol.Types                  hiding+                                                              (SemanticTokenAbsolute (..),+                                                               SemanticTokenRelative (..),+                                                               SemanticTokensEdit (..),+                                                               mkRange) import           Language.LSP.Test import           Network.URI import qualified Progress-import           System.IO.Extra                   hiding (withTempDir)-import           System.Mem                        (performGC)-import           Test.Hls                          (IdeState, def,-                                                    runSessionWithServerInTmpDir,-                                                    waitForProgressDone)+import           System.IO.Extra                              hiding+                                                              (withTempDir)+import           System.Mem                                   (performGC)+import           Test.Hls                                     (IdeState, def,+                                                               runSessionWithServerInTmpDir,+                                                               waitForProgressDone) import           Test.Hls.FileSystem import           Test.Tasty import           Test.Tasty.ExpectedFailure import           Test.Tasty.HUnit-import           Text.Printf                       (printf)+import           Text.Printf                                  (printf)  tests :: TestTree tests = do@@ -97,6 +110,39 @@            resolution_us <- findResolution_us 1            let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us            assertBool msg (resolution_us <= 1000)+     , testCase "transitiveReverseDependencies follows the chain" $ do+         -- Chain: 0 imported by 1, 1 imported by 2, 2 imported by 3.+         -- transitiveReverseDependencies of node 0 must contain {1, 2, 3},+         -- not just the immediate reverse-dep {1}.+         let path :: Int -> NormalizedFilePath+             path i = toNormalizedFilePath' ("/M" ++ show i ++ ".hs")+             loc :: Int -> ArtifactsLocation+             loc i = ArtifactsLocation (path i) Nothing True Nothing+             pathIdMap = PathIdMap+               { idToPathMap = IntMap.fromList [(i, loc i) | i <- [0..3]]+               , pathToIdMap = HMS.fromList   [(path i, FilePathId i) | i <- [0..3]]+               , nextFreshId = 4+               }+             revDeps = IntMap.fromList+               [ (0, IntSet.fromList [1])+               , (1, IntSet.fromList [2])+               , (2, IntSet.fromList [3])+               ]+             depInfo = DependencyInformation+               { depErrorNodes        = IntMap.empty+               , depModules           = IntMap.empty+               , depModuleDeps        = IntMap.empty+               , depReverseModuleDeps = revDeps+               , depPathIdMap         = pathIdMap+               , depBootMap           = IntMap.empty+               , depModuleFiles       = ShowableModuleEnv emptyModuleEnv+               , depModuleGraph       = emptyMG+               , depTransDepsFingerprints            = IntMap.empty+               , depTransReverseDepsFingerprints     = IntMap.empty+               , depImmediateReverseDepsFingerprints = IntMap.empty+               }+         (sort <$> transitiveReverseDependencies (path 0) depInfo)+           @?= Just [path 1, path 2, path 3]      , Progress.tests      , FuzzySearch.tests      ]
ghcide-test/exe/WatchedFileTests.hs view
@@ -9,9 +9,13 @@ import           Control.Applicative.Combinators import           Control.Monad.IO.Class          (liftIO) import qualified Data.Aeson                      as A+import           Data.List                       (nub) import qualified Data.Text                       as T import qualified Data.Text.IO                    as T-import           Development.IDE.Test            (expectDiagnostics)+import           Development.IDE.Plugin.Test     (WaitForIdeRuleResult (..))+import           Development.IDE.Test            (expectDiagnostics,+                                                  expectNoMoreDiagnostics,+                                                  waitForAction) import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types     hiding                                                  (SemanticTokenAbsolute (..),@@ -48,6 +52,15 @@         -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle         liftIO $ length watchedFileRegs @?= 2 +    , testWithDummyPluginEmpty' "distinct registration ids" $ \sessionDir -> do+        liftIO $ atomicFileWriteString (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}"+        _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"+        setIgnoringRegistrationRequests False+        ids <- getWatchedFilesRegistrationIdsUntil SMethod_TextDocumentPublishDiagnostics++        liftIO $ length ids @?= 2+        liftIO $ assertEqual "registration ids must be distinct" (nub ids) ids+     -- TODO add a test for didChangeWorkspaceFolder     ]   , testGroup "Changes"@@ -73,6 +86,106 @@         sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams                [FileEvent (filePathToUri $ sessionDir </> "B.hs") FileChangeType_Changed ]         expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Int'", Just "GHC-83865")])]+      , testWithDummyPlugin' "created module file resolves import"+          (mkIdeTestFs+            [ directCradle ["-isrc", "A", "B"]+            , directory "src" []+            ])+          $ \sessionDir -> do++        _doc <- createDoc ("src" </> "A.hs") "haskell" $ T.unlines+          [ "module A where"+          , "import B"+          , "a :: Bool"+          , "a = b"+          ]+        expectDiagnostics [("src" </> "A.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module", Nothing)])]+        -- create B off editor, as e.g. a git checkout would+        liftIO $ do+          createDirectoryIfMissing True (sessionDir </> "src")+          atomicFileWriteString (sessionDir </> "src" </> "B.hs") $ unlines+            [ "module B where"+            , "b :: Bool"+            , "b = True"+            ]+        sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams+               [FileEvent (filePathToUri $ sessionDir </> "src" </> "B.hs") FileChangeType_Created ]+        expectDiagnostics [("src" </> "A.hs", [])]+      , testWithDummyPlugin' "deleted module file breaks import"+          (mkIdeTestFs+            [ directCradle ["-isrc", "A", "B"]+            , directory "src"+              [ file "B.hs" $ sources+                [ "module B where"+                , "b :: Bool"+                , "b = True"+                ]+              ]+            ])+          $ \sessionDir -> do+        adoc <- createDoc ("src" </> "A.hs") "haskell" $ T.unlines+          [ "module A where"+          , "import B"+          , "a :: Bool"+          , "a = b"+          ]+        WaitForIdeRuleResult{ideResultSuccess} <- waitForAction "TypeCheck" adoc+        liftIO $ assertBool "A should typecheck" ideResultSuccess+        -- delete B off editor+        liftIO $ removeFile (sessionDir </> "src" </> "B.hs")+        sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams+               [FileEvent (filePathToUri $ sessionDir </> "src" </> "B.hs") FileChangeType_Deleted ]+        expectDiagnostics [("src" </> "A.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module", Nothing)])]+      , testWithDummyPlugin' "deleted non-target module leaves the module map"+          (mkIdeTestFs+            [ directCradle ["-isrc", "A"]+            , directory "src"+              [ file "U.hs" $ sources+                [ "module U where"+                , "u :: Bool"+                , "u = True"+                ]+              ]+            ])+          $ \sessionDir -> do+        -- U is not a target of the cradle, so it is only known through the+        -- scan of the import directory. Assert on the import resolution+        -- itself: GHC's own finder also reports a deleted module, so a+        -- diagnostic would not tell us whether HLS resolved the import.+        adoc <- createDoc ("src" </> "A.hs") "haskell" $ T.unlines+          [ "module A where"+          , "import U"+          , "a :: Bool"+          , "a = u"+          ]+        WaitForIdeRuleResult{ideResultSuccess} <- waitForAction "TypeCheck" adoc+        liftIO $ assertBool "A should typecheck" ideResultSuccess+        liftIO $ removeFile (sessionDir </> "src" </> "U.hs")+        sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams+               [FileEvent (filePathToUri $ sessionDir </> "src" </> "U.hs") FileChangeType_Deleted ]+        _ <- waitForDiagnosticsSource "not found"+        pure ()+      , testWithDummyPluginEmpty' "created file no component claims is not a target" $ \sessionDir -> do+        -- Such a file has no session to be compiled in, so making it part of+        -- the project only buys a cradle load that rejects it+        liftIO $ do+          atomicFileWriteString (sessionDir </> "hie.yaml") $ unlines+            [ "cradle:"+            , "  multi:"+            , "    - path: \"./src\""+            , "      config: {cradle: {direct: {arguments: [\"-isrc\", \"A\"]}}}"+            ]+          createDirectoryIfMissing True (sessionDir </> "src")+          createDirectoryIfMissing True (sessionDir </> "elsewhere")+          atomicFileWriteString (sessionDir </> "src" </> "A.hs") "module A where"+        adoc <- openDoc ("src" </> "A.hs") "haskell"+        WaitForIdeRuleResult{ideResultSuccess} <- waitForAction "TypeCheck" adoc+        liftIO $ assertBool "A should typecheck" ideResultSuccess+        let stray = sessionDir </> "elsewhere" </> "Stray.hs"+        liftIO $ atomicFileWriteString stray "module Stray where"+        sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams+               [FileEvent (filePathToUri stray) FileChangeType_Created ]+        expectNoMoreDiagnostics 2       , testWithDummyPlugin' "reload HLS after .cabal file changes" (mkIdeTestFs [copyDir ("watched-files" </> "reload")]) $ \sessionDir -> do           let hsFile = "src" </> "MyLib.hs"           _ <- openDoc hsFile "haskell"@@ -86,6 +199,15 @@           expectDiagnostics [(hsFile, [])]     ]   ]++getWatchedFilesRegistrationIdsUntil :: forall m. SServerMethod m -> Session [T.Text]+getWatchedFilesRegistrationIdsUntil m = do+      msgs <- manyTill (Just <$> message SMethod_ClientRegisterCapability <|> Nothing <$ anyMessage) (message m)+      return+            [ _id+            | Just TRequestMessage{_params = RegistrationParams regs} <- msgs+            , Registration _id "workspace/didChangeWatchedFiles" _ <- regs+            ]  getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions] getWatchedFilesSubscriptionsUntil m = do
haskell-language-server.cabal view
@@ -1,7 +1,7 @@ cabal-version:      3.4 category:           Development name:               haskell-language-server-version:            2.14.0.0+version:            2.15.0.0 synopsis:           LSP server for GHC description:   Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -136,8 +136,8 @@   build-depends:     , directory     , filepath-    , ghcide          == 2.14.0.0-    , hls-plugin-api  == 2.14.0.0+    , ghcide          == 2.15.0.0+    , hls-plugin-api  == 2.15.0.0     , lens     , lsp-types     , mtl@@ -157,8 +157,8 @@     , filepath     , haskell-language-server:hls-cabal-plugin     , haskell-language-server:hls-cabal-fmt-plugin-    , hls-plugin-api        == 2.14.0.0-    , hls-test-utils        == 2.14.0.0+    , hls-plugin-api        == 2.15.0.0+    , hls-test-utils        == 2.15.0.0    if flag(isolateCabalfmtTests)     build-tool-depends: cabal-fmt:cabal-fmt ^>=0.1.12@@ -193,8 +193,8 @@   build-depends:     , directory     , filepath-    , ghcide          == 2.14.0.0-    , hls-plugin-api  == 2.14.0.0+    , ghcide          == 2.15.0.0+    , hls-plugin-api  == 2.15.0.0     , lsp-types     , text     , mtl@@ -213,8 +213,8 @@     , filepath     , haskell-language-server:hls-cabal-plugin     , haskell-language-server:hls-cabal-gild-plugin-    , hls-plugin-api        == 2.14.0.0-    , hls-test-utils        == 2.14.0.0+    , hls-plugin-api        == 2.15.0.0+    , hls-test-utils        == 2.15.0.0    if flag(isolateCabalGildTests)     -- https://github.com/tfausak/cabal-gild/issues/89@@ -274,10 +274,10 @@     , directory     , filepath     , extra                 >=1.7.4-    , ghcide                == 2.14.0.0+    , ghcide                == 2.15.0.0     , hashable-    , hls-plugin-api        == 2.14.0.0-    , hls-graph             == 2.14.0.0+    , hls-plugin-api        == 2.15.0.0+    , hls-graph             == 2.15.0.0     , lens     , lsp                   ^>=2.8     , lsp-types             ^>=2.4@@ -316,7 +316,7 @@     , filepath     , ghcide     , haskell-language-server:hls-cabal-plugin-    , hls-test-utils    == 2.14.0.0+    , hls-test-utils    == 2.15.0.0     , lens     , lsp-types     , text@@ -353,12 +353,11 @@     , extra     , ghc     , ghc-exactprint  >= 1.5 && < 1.15-    , ghcide          == 2.14.0.0+    , ghcide          == 2.15.0.0     , hls-graph-    , hls-plugin-api  == 2.14.0.0+    , hls-plugin-api  == 2.15.0.0     , lens     , lsp-    , mtl     , text     , transformers @@ -376,7 +375,7 @@   build-depends:     , filepath     , haskell-language-server:hls-class-plugin-    , hls-test-utils     == 2.14.0.0+    , hls-test-utils     == 2.15.0.0     , lens     , lsp-types     , text@@ -411,9 +410,9 @@     , containers     , extra     , ghc-    , ghcide                == 2.14.0.0+    , ghcide                == 2.15.0.0     , hiedb                 ^>= 0.8.0.0-    , hls-plugin-api        == 2.14.0.0+    , hls-plugin-api        == 2.15.0.0     , lens     , lsp                    >=2.8     , sqlite-simple@@ -434,7 +433,7 @@     , extra     , filepath     , haskell-language-server:hls-call-hierarchy-plugin-    , hls-test-utils        == 2.14.0.0+    , hls-test-utils        == 2.15.0.0     , lens     , lsp     , lsp-test@@ -480,15 +479,16 @@     , deepseq     , Diff                  ^>=0.5 || ^>=1.0.0     , dlist+    , exceptions     , extra     , filepath     , ghc     , ghc-boot-th-    , ghcide                == 2.14.0.0+    , ghcide                == 2.15.0.0     , hls-graph-    , hls-plugin-api        == 2.14.0.0+    , hls-plugin-api        == 2.15.0.0     , lens-    , lsp+    , lsp                   ^>=2.8     , lsp-types     , megaparsec            >=9.0     , mtl@@ -517,7 +517,7 @@     , filepath     , haskell-language-server:hls-eval-plugin     , hls-plugin-api-    , hls-test-utils   == 2.14.0.0+    , hls-test-utils   == 2.15.0.0     , lens     , lsp-types     , text@@ -547,9 +547,9 @@     , containers     , deepseq     , ghc-    , ghcide                == 2.14.0.0+    , ghcide                == 2.15.0.0     , hls-graph-    , hls-plugin-api        == 2.14.0.0+    , hls-plugin-api        == 2.15.0.0     , lens     , lsp     , mtl@@ -570,130 +570,122 @@     , extra     , filepath     , haskell-language-server:hls-explicit-imports-plugin-    , hls-test-utils   == 2.14.0.0+    , hls-test-utils   == 2.15.0.0     , lens     , lsp-types     , text  -------------------------------- rename plugin+-- case split plugin ----------------------------- -flag rename-  description: Enable rename plugin+flag caseSplit+  description: Enable caseSplit plugin   default:     True   manual:      True -common rename-  if flag(rename)-    build-depends: haskell-language-server:hls-rename-plugin-    cpp-options: -Dhls_rename+common caseSplit+  if flag(casesplit) && !impl(ghc < 9.14)+    build-depends: haskell-language-server:hls-case-split-plugin+    cpp-options: -Dhls_caseSplit -library hls-rename-plugin+library hls-case-split-plugin   import:           defaults, pedantic, warnings-  if !flag(rename)+  if !flag(casesplit) || impl(ghc < 9.14)     buildable: False-  exposed-modules:-    Ide.Plugin.Rename-    Ide.Plugin.Rename.ModuleName-  hs-source-dirs:   plugins/hls-rename-plugin/src+  exposed-modules:  Ide.Plugin.CaseSplit+  hs-source-dirs:   plugins/hls-case-split-plugin/src   build-depends:-    , aeson-    , containers-    , filepath+    , extra     , ghc-    , ghcide                == 2.14.0.0-    , hashable-    , hiedb                 ^>= 0.8.0.0-    , hls-plugin-api        == 2.14.0.0     , haskell-language-server:hls-refactor-plugin+    , ghcide                == 2.15.0.0+    , hls-plugin-api        == 2.15.0.0     , lens-    , lsp-types+    , lsp     , mtl-    , mod     , syb     , text-    , text-rope     , transformers-    , unordered-containers+    , ghc-exactprint        >= 1.14.1.0 +  default-extensions:+    DataKinds -test-suite hls-rename-plugin-tests+test-suite hls-case-split-plugin-tests   import:           defaults, pedantic, test-defaults, warnings-  if !flag(rename)+  if !flag(casesplit) || impl(ghc < 9.14)     buildable: False   type:             exitcode-stdio-1.0-  hs-source-dirs:   plugins/hls-rename-plugin/test+  hs-source-dirs:   plugins/hls-case-split-plugin/test   main-is:          Main.hs   build-depends:-    , aeson-    , containers     , filepath-    , hls-plugin-api-    , haskell-language-server:hls-rename-plugin-    , hls-test-utils             == 2.14.0.0+    , haskell-language-server:hls-case-split-plugin+    , hls-test-utils   == 2.15.0.0     , lens     , lsp-types     , text  -------------------------------- retrie plugin+-- rename plugin ----------------------------- -flag retrie-  description: Enable retrie plugin+flag rename+  description: Enable rename plugin   default:     True   manual:      True -common retrie-  if flag(retrie) && (impl(ghc < 9.10) || flag(ignore-plugins-ghc-bounds))-    build-depends: haskell-language-server:hls-retrie-plugin-    cpp-options: -Dhls_retrie+common rename+  if flag(rename)+    build-depends: haskell-language-server:hls-rename-plugin+    cpp-options: -Dhls_rename -library hls-retrie-plugin+library hls-rename-plugin   import:           defaults, pedantic, warnings-  if !(flag(retrie) && (impl(ghc < 9.10) || flag(ignore-plugins-ghc-bounds)))+  if !flag(rename)     buildable: False-  exposed-modules:  Ide.Plugin.Retrie-  hs-source-dirs:   plugins/hls-retrie-plugin/src+  exposed-modules:+    Ide.Plugin.Rename+    Ide.Plugin.Rename.ModuleName+  hs-source-dirs:   plugins/hls-rename-plugin/src   build-depends:     , aeson-    , bytestring     , containers-    , extra+    , filepath     , ghc-    , ghcide                == 2.14.0.0+    , ghcide                == 2.15.0.0     , hashable-    , hls-plugin-api        == 2.14.0.0+    , hiedb                 ^>= 0.8.0.0+    , hls-plugin-api        == 2.15.0.0     , haskell-language-server:hls-refactor-plugin     , lens-    , lsp     , lsp-types     , mtl-    , retrie                >=0.1.1.0-    , safe-exceptions-    , stm+    , mod+    , syb     , text     , text-rope     , transformers     , unordered-containers -  default-extensions:-    DataKinds -test-suite hls-retrie-plugin-tests+test-suite hls-rename-plugin-tests   import:           defaults, pedantic, test-defaults, warnings-  if !(flag(retrie) && (impl(ghc < 9.10) || flag(ignore-plugins-ghc-bounds)))+  if !flag(rename)     buildable: False   type:             exitcode-stdio-1.0-  hs-source-dirs:   plugins/hls-retrie-plugin/test+  hs-source-dirs:   plugins/hls-rename-plugin/test   main-is:          Main.hs   build-depends:+    , aeson     , containers     , filepath     , hls-plugin-api-    , haskell-language-server:{hls-refactor-plugin, hls-retrie-plugin}-    , hls-test-utils             == 2.14.0.0+    , haskell-language-server:hls-rename-plugin+    , hls-test-utils             == 2.15.0.0+    , lens+    , lsp-types     , text  -----------------------------@@ -737,10 +729,10 @@     , containers     , deepseq     , filepath-    , ghcide                == 2.14.0.0+    , ghcide                == 2.15.0.0     , hashable     , hlint                 >= 3.5 && < 3.11-    , hls-plugin-api        == 2.14.0.0+    , hls-plugin-api        == 2.15.0.0     , lens     , mtl     , refact@@ -793,7 +785,7 @@     , filepath     , haskell-language-server:hls-hlint-plugin     , hls-plugin-api-    , hls-test-utils      == 2.14.0.0+    , hls-test-utils      == 2.15.0.0     , lens     , lsp-types     , text@@ -847,7 +839,7 @@     , filepath     , haskell-language-server:hls-stan-plugin     , hls-plugin-api-    , hls-test-utils      == 2.14.0.0+    , hls-test-utils      == 2.15.0.0     , lens     , lsp-types     , text@@ -881,8 +873,8 @@   build-depends:     , containers     , ghc-    , ghcide                == 2.14.0.0-    , hls-plugin-api        == 2.14.0.0+    , ghcide                == 2.15.0.0+    , hls-plugin-api        == 2.15.0.0     , lsp-types     , text     , transformers@@ -898,7 +890,7 @@   build-depends:     , ghcide     , haskell-language-server:hls-signature-help-plugin-    , hls-test-utils             == 2.14.0.0+    , hls-test-utils             == 2.15.0.0     , text   default-extensions:     DerivingStrategies@@ -928,8 +920,8 @@     , aeson     , extra     , fuzzy-    , ghcide                == 2.14.0.0-    , hls-plugin-api        == 2.14.0.0+    , ghcide                == 2.15.0.0+    , hls-plugin-api        == 2.15.0.0     , lens     , lsp     , text@@ -946,7 +938,7 @@     , aeson     , filepath     , haskell-language-server:hls-pragmas-plugin-    , hls-test-utils      == 2.14.0.0+    , hls-test-utils      == 2.15.0.0     , lens     , lsp-types     , text@@ -961,13 +953,13 @@   manual:      True  common splice-  if flag(splice) && (impl(ghc < 9.10) || flag(ignore-plugins-ghc-bounds))+  if flag(splice)     build-depends: haskell-language-server:hls-splice-plugin     cpp-options: -Dhls_splice  library hls-splice-plugin   import:           defaults, pedantic, warnings-  if !(flag(splice) && (impl(ghc < 9.10) || flag(ignore-plugins-ghc-bounds)))+  if !(flag(splice))     buildable: False   exposed-modules:     Ide.Plugin.Splice@@ -979,8 +971,8 @@     , extra     , foldl     , ghc-    , ghcide                == 2.14.0.0-    , hls-plugin-api        == 2.14.0.0+    , ghcide                == 2.15.0.0+    , hls-plugin-api        == 2.15.0.0     , haskell-language-server:hls-refactor-plugin     , lens     , lsp@@ -995,7 +987,7 @@  test-suite hls-splice-plugin-tests   import:           defaults, pedantic, test-defaults, warnings-  if !(flag(splice) && (impl(ghc < 9.10) || flag(ignore-plugins-ghc-bounds)))+  if !(flag(splice))     buildable: False   type:             exitcode-stdio-1.0   hs-source-dirs:   plugins/hls-splice-plugin/test@@ -1003,7 +995,7 @@   build-depends:     , filepath     , haskell-language-server:hls-splice-plugin-    , hls-test-utils == 2.14.0.0+    , hls-test-utils == 2.15.0.0     , text  -----------------------------@@ -1030,10 +1022,10 @@   build-depends:     , containers     , extra-    , ghcide               == 2.14.0.0+    , ghcide               == 2.15.0.0     , ghc-boot-th     , hls-graph-    , hls-plugin-api       == 2.14.0.0+    , hls-plugin-api       == 2.15.0.0     , lens     , lsp                  ^>=2.8     , mtl@@ -1058,7 +1050,7 @@     , containers     , filepath     , haskell-language-server:hls-alternate-number-format-plugin-    , hls-test-utils       == 2.14.0.0+    , hls-test-utils       == 2.15.0.0     , regex-tdfa     , tasty-quickcheck     , text@@ -1091,8 +1083,8 @@   build-depends:     , containers     , ghc-    , ghcide                == 2.14.0.0-    , hls-plugin-api        == 2.14.0.0+    , ghcide                == 2.15.0.0+    , hls-plugin-api        == 2.15.0.0     , lens     , lsp     , text@@ -1114,7 +1106,7 @@     , text     , filepath     , haskell-language-server:hls-qualify-imported-names-plugin-    , hls-test-utils             == 2.14.0.0+    , hls-test-utils             == 2.15.0.0  ----------------------------- -- code range plugin@@ -1145,9 +1137,9 @@     , deepseq     , extra     , ghc-    , ghcide           == 2.14.0.0+    , ghcide           == 2.15.0.0     , hashable-    , hls-plugin-api   == 2.14.0.0+    , hls-plugin-api   == 2.15.0.0     , lens     , lsp     , mtl@@ -1169,7 +1161,7 @@     , bytestring     , filepath     , haskell-language-server:hls-code-range-plugin-    , hls-test-utils             == 2.14.0.0+    , hls-test-utils             == 2.15.0.0     , lens     , lsp     , lsp-test@@ -1197,8 +1189,8 @@   exposed-modules:  Ide.Plugin.ChangeTypeSignature   hs-source-dirs:   plugins/hls-change-type-signature-plugin/src   build-depends:-    , ghcide           == 2.14.0.0-    , hls-plugin-api   == 2.14.0.0+    , ghcide           == 2.15.0.0+    , hls-plugin-api   == 2.15.0.0     , lens     , lsp-types     , regex-tdfa@@ -1224,7 +1216,7 @@   build-depends:     , filepath     , haskell-language-server:hls-change-type-signature-plugin-    , hls-test-utils       == 2.14.0.0+    , hls-test-utils       == 2.15.0.0     , regex-tdfa     , text   default-extensions:@@ -1257,9 +1249,9 @@     , containers     , extra     , ghc-    , ghcide                 == 2.14.0.0+    , ghcide                 == 2.15.0.0     , ghc-exactprint-    , hls-plugin-api         == 2.14.0.0+    , hls-plugin-api         == 2.15.0.0     , haskell-language-server:hls-refactor-plugin     , lens     , lsp                    >=2.8@@ -1279,7 +1271,7 @@   build-depends:     , filepath     , haskell-language-server:hls-gadt-plugin-    , hls-test-utils              == 2.14.0.0+    , hls-test-utils              == 2.15.0.0     , text  -----------------------------@@ -1306,9 +1298,9 @@     , containers     , deepseq     , extra-    , ghcide                == 2.14.0.0+    , ghcide                == 2.15.0.0     , hashable-    , hls-plugin-api        == 2.14.0.0+    , hls-plugin-api        == 2.15.0.0     , lsp                   >=2.8     , text @@ -1324,7 +1316,7 @@   build-depends:     , filepath     , haskell-language-server:hls-explicit-fixity-plugin-    , hls-test-utils              == 2.14.0.0+    , hls-test-utils              == 2.15.0.0     , text  -----------------------------@@ -1348,8 +1340,8 @@   exposed-modules:  Ide.Plugin.ExplicitFields   build-depends:     , ghc-    , ghcide                == 2.14.0.0-    , hls-plugin-api        == 2.14.0.0+    , ghcide                == 2.15.0.0+    , hls-plugin-api        == 2.15.0.0     , lsp     , lens     , hls-graph@@ -1375,7 +1367,7 @@     , text     , ghcide     , haskell-language-server:hls-explicit-record-fields-plugin-    , hls-test-utils              == 2.14.0.0+    , hls-test-utils              == 2.15.0.0  ----------------------------- -- overloaded record dot plugin@@ -1421,7 +1413,7 @@     , filepath     , text     , haskell-language-server:hls-overloaded-record-dot-plugin-    , hls-test-utils              == 2.14.0.0+    , hls-test-utils              == 2.15.0.0   -----------------------------@@ -1434,26 +1426,24 @@   manual:      True  common fourmolu-  -- fourmolu depends on ghc-lib-parser which doesn't support GHC 9.14-  if flag(fourmolu) && !impl(ghc >= 9.14)+  if flag(fourmolu)     build-depends: haskell-language-server:hls-fourmolu-plugin     cpp-options: -Dhls_fourmolu  library hls-fourmolu-plugin   import:           defaults, pedantic, warnings-  -- fourmolu depends on ghc-lib-parser which doesn't support GHC 9.14-  if !flag(fourmolu) || impl(ghc >= 9.14)+  if !flag(fourmolu)     buildable: False   exposed-modules:  Ide.Plugin.Fourmolu   hs-source-dirs:   plugins/hls-fourmolu-plugin/src   build-depends:     , filepath-    , fourmolu        ^>= 0.14 || ^>= 0.15 || ^>= 0.16 || ^>=0.17 || ^>=0.18 || ^>=0.19+    , fourmolu        ^>= 0.14 || ^>= 0.15 || ^>= 0.16 || ^>=0.17 || ^>=0.18 || ^>=0.19 || ^>=0.20     , ghc-boot-th-    , ghcide          == 2.14.0.0-    , hls-plugin-api  == 2.14.0.0+    , ghcide          == 2.15.0.0+    , hls-plugin-api  == 2.15.0.0     , lens-    , lsp+    , lsp             ^>= 2.8     , mtl     , process-extras  >= 0.7.1     , text@@ -1462,8 +1452,7 @@  test-suite hls-fourmolu-plugin-tests   import:           defaults, pedantic, test-defaults, warnings-  -- fourmolu depends on ghc-lib-parser which doesn't support GHC 9.14-  if !flag(fourmolu) || impl(ghc >= 9.14)+  if !flag(fourmolu)     buildable: False   type:             exitcode-stdio-1.0   hs-source-dirs:   plugins/hls-fourmolu-plugin/test@@ -1479,7 +1468,7 @@     , filepath     , haskell-language-server:hls-fourmolu-plugin     , hls-plugin-api-    , hls-test-utils       == 2.14.0.0+    , hls-test-utils       == 2.15.0.0     , lens     , lsp-test     , lsp-types@@ -1495,15 +1484,13 @@   manual:      True  common ormolu-  -- ormolu depends on ghc-lib-parser which doesn't support GHC 9.14-  if flag(ormolu) && !impl(ghc >= 9.14)+  if flag(ormolu)     build-depends: haskell-language-server:hls-ormolu-plugin     cpp-options: -Dhls_ormolu  library hls-ormolu-plugin   import:           defaults, pedantic, warnings-  -- ormolu depends on ghc-lib-parser which doesn't support GHC 9.14-  if !flag(ormolu) || impl(ghc >= 9.14)+  if !flag(ormolu)     buildable: False   exposed-modules:  Ide.Plugin.Ormolu   hs-source-dirs:   plugins/hls-ormolu-plugin/src@@ -1511,8 +1498,8 @@     , extra     , filepath     , ghc-boot-th-    , ghcide          == 2.14.0.0-    , hls-plugin-api  == 2.14.0.0+    , ghcide          == 2.15.0.0+    , hls-plugin-api  == 2.15.0.0     , lsp     , mtl     , process-extras  >= 0.7.1@@ -1523,8 +1510,7 @@  test-suite hls-ormolu-plugin-tests   import:           defaults, pedantic, test-defaults, warnings-  -- ormolu depends on ghc-lib-parser which doesn't support GHC 9.14-  if !flag(ormolu) || impl(ghc >= 9.14)+  if !flag(ormolu)     buildable: False   type:             exitcode-stdio-1.0   hs-source-dirs:   plugins/hls-ormolu-plugin/test@@ -1540,7 +1526,7 @@     , filepath     , haskell-language-server:hls-ormolu-plugin     , hls-plugin-api-    , hls-test-utils     == 2.14.0.0+    , hls-test-utils     == 2.15.0.0     , lens     , lsp-types     , ormolu@@ -1573,8 +1559,8 @@     , directory     , filepath     , ghc-boot-th-    , ghcide           == 2.14.0.0-    , hls-plugin-api   == 2.14.0.0+    , ghcide           == 2.15.0.0+    , hls-plugin-api   == 2.15.0.0     , lsp-types     , mtl     , stylish-haskell  >=0.12 && <0.16@@ -1592,7 +1578,7 @@   build-depends:     , filepath     , haskell-language-server:hls-stylish-haskell-plugin-    , hls-test-utils              == 2.14.0.0+    , hls-test-utils              == 2.15.0.0  ----------------------------- -- refactor plugin@@ -1644,8 +1630,9 @@     , bytestring     , ghc-boot     , regex-tdfa-    , ghcide                == 2.14.0.0-    , hls-plugin-api        == 2.14.0.0+    , ghcide                == 2.15.0.0+    , haskell-language-server:hls-exactprint-utils+    , hls-plugin-api        == 2.15.0.0     , lsp     , text     , text-rope@@ -1680,7 +1667,7 @@     , filepath     , ghcide:ghcide     , haskell-language-server:hls-refactor-plugin-    , hls-test-utils      == 2.14.0.0+    , hls-test-utils      == 2.15.0.0     , lens     , lsp-test     , lsp-types@@ -1727,8 +1714,8 @@     , text-rope     , mtl                   >= 2.2     , ghc-    , ghcide                == 2.14.0.0-    , hls-plugin-api        == 2.14.0.0+    , ghcide                == 2.15.0.0+    , hls-plugin-api        == 2.15.0.0     , lens     , lsp                    >=2.8     , text@@ -1737,7 +1724,7 @@     , array     , deepseq     , dlist-    , hls-graph == 2.14.0.0+    , hls-graph == 2.15.0.0     , template-haskell     , data-default     , stm@@ -1758,10 +1745,10 @@     , containers     , data-default     , filepath-    , ghcide                == 2.14.0.0+    , ghcide                == 2.15.0.0     , haskell-language-server:hls-semantic-tokens-plugin-    , hls-plugin-api        == 2.14.0.0-    , hls-test-utils        == 2.14.0.0+    , hls-plugin-api        == 2.15.0.0+    , hls-test-utils        == 2.15.0.0     , lens     , lsp     , lsp-test@@ -1791,9 +1778,9 @@   hs-source-dirs:     plugins/hls-notes-plugin/src   build-depends:     , array-    , ghcide == 2.14.0.0-    , hls-graph == 2.14.0.0-    , hls-plugin-api == 2.14.0.0+    , ghcide == 2.15.0.0+    , hls-graph == 2.15.0.0+    , hls-plugin-api == 2.15.0.0     , lens     , lsp >=2.8     , mtl >= 2.2@@ -1819,9 +1806,86 @@   build-depends:     , filepath     , haskell-language-server:hls-notes-plugin-    , hls-test-utils == 2.14.0.0+    , hls-test-utils == 2.15.0.0   default-extensions: OverloadedStrings +-----------------------------+-- export plugin+-----------------------------++library hls-exactprint-utils+  import: defaults, pedantic, warnings+  exposed-modules:+    Development.IDE.GHC.ExactPrint.Annotation+    Development.IDE.GHC.ExactPrint.CPP+  hs-source-dirs:     hls-exactprint-utils/src+  build-depends:+    , ghc+    , ghc-exactprint+    , ghcide          == 2.15.0.0+    , lsp             >=2.8+    , text+    , text-rope+  default-extensions:+      CPP++flag export+  description: Enable export plugin+  default:     True+  manual:      True++common export+  if flag(export)+    build-depends: haskell-language-server:hls-export-plugin+    cpp-options: -Dhls_export++library hls-export-plugin+  import: defaults, pedantic, warnings+  if !flag(export)+    buildable: False+  exposed-modules:+    Ide.Plugin.Export+  other-modules:+    Ide.Plugin.Export.Cursor+    Ide.Plugin.Export.ExactPrint+    Ide.Plugin.Export.Exports+    Ide.Plugin.Export.Utils+  hs-source-dirs:     plugins/hls-export-plugin/src+  default-language:   GHC2021+  build-depends:+    , containers+    , ghc+    , ghc-boot-th+    , ghc-exactprint+    , ghcide          == 2.15.0.0+    , haskell-language-server:hls-exactprint-utils+    , hls-plugin-api  == 2.15.0.0+    , lens+    , lsp >=2.8+    , stm+    , text+    , text-rope+  default-extensions:+    , DataKinds+    , LambdaCase+    , OverloadedStrings++test-suite hls-export-plugin-tests+  import:           defaults, pedantic, test-defaults, warnings+  if !flag(export)+    buildable: False+  type:             exitcode-stdio-1.0+  hs-source-dirs:   plugins/hls-export-plugin/test+  main-is:          Main.hs+  build-depends:+    , filepath+    , haskell-language-server:hls-export-plugin+    , hls-test-utils == 2.15.0.0+    , lens+    , lsp-types+    , text+  default-extensions: OverloadedStrings+ ---------------------------- ---------------------------- -- HLS@@ -1841,8 +1905,8 @@                   , class                   , eval                   , importLens+                  , caseSplit                   , rename-                  , retrie                   , hlint                   , stan                   , signatureHelp@@ -1861,6 +1925,7 @@                   , overloadedRecordDot                   , semanticTokens                   , notes+                  , export    exposed-modules:     Ide.Arguments@@ -1878,10 +1943,10 @@     , extra     , filepath     , ghc-    , ghcide                == 2.14.0.0+    , ghcide                == 2.15.0.0     , githash               >=0.1.6.1     , hie-bios-    , hls-plugin-api        == 2.14.0.0+    , hls-plugin-api        == 2.15.0.0     , optparse-applicative     , optparse-simple     , prettyprinter         >= 1.7@@ -1984,7 +2049,7 @@     , ghcide:ghcide     , hashable     , hls-plugin-api-    , hls-test-utils == 2.14.0.0+    , hls-test-utils == 2.15.0.0     , lens     , lsp-test     , lsp-types@@ -2026,7 +2091,7 @@    build-depends:     , extra-    , hls-test-utils              == 2.14.0.0+    , hls-test-utils              == 2.15.0.0     , process    hs-source-dirs:     test/wrapper@@ -2040,8 +2105,7 @@     main-is: Main.hs     hs-source-dirs: bench     build-tool-depends:-        haskell-language-server:ghcide-bench,-        eventlog2html:eventlog2html,+        haskell-language-server:ghcide-bench     default-extensions:         LambdaCase         RecordWildCards@@ -2095,6 +2159,7 @@     , enummapset     , extra     , filepath+    , ghc     , ghcide     , hls-plugin-api     , lens@@ -2119,7 +2184,7 @@     , text     , text-rope     , unordered-containers-    , hls-test-utils == 2.14.0.0+    , hls-test-utils == 2.15.0.0    if impl(ghc <9.3)     build-depends: ghc-typelits-knownnat@@ -2140,6 +2205,7 @@     CradleTests     DependentFileTest     DiagnosticTests+    EpsPollutionTests     ExceptionTests     FindDefinitionAndHoverTests     FindImplementationAndHoverTests@@ -2238,6 +2304,7 @@         process,         safe-exceptions,         shake,+        table-layout,         text,         hls-test-utils,         row-types
+ hls-exactprint-utils/src/Development/IDE/GHC/ExactPrint/Annotation.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE RecordWildCards #-}++-- | Version-agnostic primitives for ghc-exactprint annotations, shared by the+-- refactor and export plugins.+module Development.IDE.GHC.ExactPrint.Annotation+  ( epl+  , isCommaAnn+  , trailingAnns+  , overTrailingAnns+  , removeTrailingCommaAnn+  , ensureTrailingComma+  , withTrailingComma+  , modifyAnns+  , addParens+  , parenthesizeName+  ) where++import           Data.Bifunctor                  (first)+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Orphans     ()+import           GHC                             (LocatedN)+#if MIN_VERSION_ghc(9,11,0)+import           GHC                             (DeltaPos (..), EpAnn (..),+                                                  EpToken (..), EpaLocation,+                                                  EpaLocation' (..),+                                                  NameAdornment (..),+                                                  SrcSpanAnnA, TrailingAnn (..))+import           GHC.Types.SrcLoc                (UnhelpfulSpanReason (..))+#elif MIN_VERSION_ghc(9,9,0)+import           GHC                             (DeltaPos (..), EpAnn (..),+                                                  EpaLocation,+                                                  EpaLocation' (..),+                                                  NameAdornment (..),+                                                  SrcSpanAnnA, TrailingAnn (..))+#else+import           GHC                             (Anchor (..),+                                                  AnchorOperation (..),+                                                  DeltaPos (..), EpAnn (..),+                                                  EpaLocation (..),+                                                  NameAdornment (NameParens),+                                                  SrcSpanAnn' (..), SrcSpanAnnA,+                                                  TrailingAnn (..),+                                                  emptyComments, realSrcSpan)+import           GHC.Types.SrcLoc                (generatedSrcSpan)+#endif+import           Language.Haskell.GHC.ExactPrint (addComma)++-- | An entry delta of @n@ spaces on the same line.+epl :: Int -> EpaLocation+#if MIN_VERSION_ghc(9,11,0)+epl n = EpaDelta (UnhelpfulSpan UnhelpfulNoLocationInfo) (SameLine n) []+#else+epl n = EpaDelta (SameLine n) []+#endif++isCommaAnn :: TrailingAnn -> Bool+isCommaAnn AddCommaAnn{} = True+isCommaAnn _             = False++trailingAnns :: SrcSpanAnnA -> [TrailingAnn]+#if MIN_VERSION_ghc(9,9,0)+trailingAnns (EpAnn _ (AnnListItem as) _) = as+#else+trailingAnns sa = case ann sa of+  EpAnn _ (AnnListItem as) _ -> as+  _                          -> []+#endif++-- | Map over an item's trailing annotations, hiding the version-specific 'AnnListItem' shape.+overTrailingAnns :: ([TrailingAnn] -> [TrailingAnn]) -> SrcSpanAnnA -> SrcSpanAnnA+#if MIN_VERSION_ghc(9,9,0)+overTrailingAnns f (EpAnn anc (AnnListItem as) cs) = EpAnn anc (AnnListItem (f as)) cs+#else+overTrailingAnns _ it@(SrcSpanAnn EpAnnNotUsed _) = it+overTrailingAnns f (SrcSpanAnn (EpAnn anc (AnnListItem as) cs) l) =+  SrcSpanAnn (EpAnn anc (AnnListItem (f as)) cs) l+#endif++removeTrailingCommaAnn :: SrcSpanAnnA -> SrcSpanAnnA+removeTrailingCommaAnn = overTrailingAnns (filter (not . isCommaAnn))++ensureTrailingComma :: SrcSpanAnnA -> SrcSpanAnnA+ensureTrailingComma ann+  | any isCommaAnn (trailingAnns ann) = ann+  | otherwise = addComma ann++-- | Replace an item's trailing comma with @c@, preserving its delta.+withTrailingComma :: TrailingAnn -> SrcSpanAnnA -> SrcSpanAnnA+withTrailingComma c = overTrailingAnns (\as -> filter (not . isCommaAnn) as ++ [c])++modifyAnns :: LocatedAn a ast -> (a -> a) -> LocatedAn a ast+#if MIN_VERSION_ghc(9,9,0)+modifyAnns x f = first (fmap f) x+#else+modifyAnns x f = first ((fmap . fmap) f) x+#endif++addParens :: Bool -> NameAnn -> NameAnn+#if MIN_VERSION_ghc(9,11,0)+addParens True it@NameAnn{} =+  it{nann_adornment = NameParens (EpTok (epl 0)) (EpTok (epl 0)) }+addParens True it@NameAnnCommas{} =+  it{nann_adornment = NameParens (EpTok (epl 0)) (EpTok (epl 0)) }+addParens True it@NameAnnOnly{} =+  it{nann_adornment = NameParens (EpTok (epl 0)) (EpTok (epl 0)) }+addParens True it@NameAnnTrailing{} =+  NameAnn{nann_adornment = NameParens (EpTok (epl 0)) (EpTok (epl 0)), nann_name = epl 0, nann_trailing = nann_trailing it}+#else+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, ..}+#endif+addParens _ it = it++-- | Parenthesize an operator name for an export/import item, e.g. @(<|)@.+parenthesizeName :: LocatedN RdrName -> LocatedN RdrName+#if MIN_VERSION_ghc(9,9,0)+parenthesizeName ln = modifyAnns ln (addParens True)+#else+-- A freshly built name carries EpAnnNotUsed pre-9.9, giving 'addParens' no+-- NameAnn to act on, so install a concrete annotation first.+parenthesizeName (L (SrcSpanAnn ann l) rdr) =+    L (SrcSpanAnn (EpAnn anc (addParens True nameAnn) cs) l) rdr+  where+    (anc, nameAnn, cs) = case ann of+      EpAnn a n c  -> (a, n, c)+      EpAnnNotUsed -> (genAnchor0, NameAnnTrailing [], emptyComments)++genAnchor0 :: Anchor+genAnchor0 = Anchor (realSrcSpan generatedSrcSpan) (MovedAnchor (SameLine 0))+#endif
+ hls-exactprint-utils/src/Development/IDE/GHC/ExactPrint/CPP.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}++module Development.IDE.GHC.ExactPrint.CPP+  ( spanHasCpp+  , isCppDirective+  ) where++import           Data.Text                   (Text)+import qualified Data.Text                   as T+import           Data.Text.Utf16.Rope.Mixed  (Rope)+import           Development.IDE.Core.Text   (takeLineRange)+import           Language.LSP.Protocol.Types (Position (..), Range (..))++-- | Whether the source over @range@ holds a CPP directive.+spanHasCpp :: Maybe Rope -> Range -> Bool+spanHasCpp Nothing _ = False+spanHasCpp (Just rope) (Range (Position l0 _) (Position l1 _)) =+  any isCppDirective (takeLineRange (fromIntegral l0) (fromIntegral l1) rope)++-- | Whether a line is a CPP directive. In a source compiled with CPP a directive+-- is the only line whose first non-space character is @#@.+isCppDirective :: Text -> Bool+isCppDirective = T.isPrefixOf "#" . T.stripStart
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Data.hs view
@@ -9,6 +9,7 @@ import           Distribution.CabalSpecVersion                  (CabalSpecVersion (CabalSpecV2_2),                                                                  showCabalSpecVersion) import           Distribution.Pretty                            (prettyShow)+import           Distribution.Types.BuildType                   (knownBuildTypes) import           Ide.Plugin.Cabal.Completion.Completer.FilePath import           Ide.Plugin.Cabal.Completion.Completer.Module import           Ide.Plugin.Cabal.Completion.Completer.Paths@@ -53,7 +54,7 @@   Map.fromList     [ ("name:", nameCompleter),       ("version:", noopCompleter),-      ("build-type:", constantCompleter ["Simple", "Custom", "Configure", "Make"]),+      ("build-type:", constantCompleter (fmap (T.pack . show) knownBuildTypes)),       ("license:", weightedConstantCompleter licenseNames weightedLicenseNames),       ("license-file:", filePathCompleter),       ("license-files:", filePathCompleter),
+ plugins/hls-case-split-plugin/src/Ide/Plugin/CaseSplit.hs view
@@ -0,0 +1,775 @@+{-# LANGUAGE ApplicativeDo     #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE MultiWayIf        #-}+{-# LANGUAGE OrPatterns        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE ViewPatterns      #-}++{- | __Implementation strategy__++  The present plugin achieves its target of appending the missing patterns to a+  non-exhaustive @case@ (or @\\case@) expression via the following strategy:++    1. the HLS utility 'activeDiagnosticsInRange' retrieves the+       @['FileDiagnostic']@ under the client-provided range,++    2. @'getInnermost' . 'extractDiagAndMissingCtors'@ is used to extract the+       'Diagnostic' and the 'NonEmpty' list of missing 'PmAltConApp' from the+       innermost ("innermost" intended according to 'isSubrangeOf') among the+       "non-exhaustive patterns" diagnostics (i.e. those containing a+       'DsMessage' constructed via 'DsNonExhaustivePatterns'),++    3. some functions running in the @'ExceptT' 'PluginError' ('HandlerM'+       'Config')@ monad are used retrieve some context necessary to construct+       the 'WorkspaceEdit' and to apply it:++          - the 'ParsedSource' describing the AST before the change to be+            applied,+          - whether the 'UnicodeSyntax' extension is in use,+          - the 'ClientCapabilities',+          - the 'VersionedTextDocumentIdentifier',++    4. 'graftMissingPatterns' uses 'everywhereM' to traverse the AST, for the+       purpose of++          - pinpointing the one node representing the innermost @case@ (or+            @\\case@) expression encompassing the client-provided range,++                - in this phase, the relevant @case@ expression is parsed+                  for detecting the current layout (whether the existing+                  alternatives, if any, are between @{@ and @}@, and in that+                  case, what's the indentation of the first existing+                  alternative),++          - turning the missing 'PmAltConApp's patterns (obtained from the+            diagnostic in step 2 above) into 'LMatch'es (to be inserted in the+            AST) via 'makeMatch',++               - 'makeMatch' can currently "fail" (by returning in 'Either')+                 because we don't support missing patterns that are not+                 'PmAltConLike' or, if they are, that are not 'RealDataCon', in+                 which case we simply log this fact and return an empty list of+                 'CodeAction's.++          - appending those 'LMatch'es to the existing ones, honoring the+            existing layout.+-}++module Ide.Plugin.CaseSplit+  ( caseSplitPluginCodeActionTitle+  , descriptor+  , Log+  ) where++import           Control.Applicative                   (ZipList (ZipList, getZipList))+import           Control.Arrow                         ((&&&), (>>>))+import           Control.Lens                          ((^.), (^?))+import           Control.Monad                         ((>=>))+import           Control.Monad.Except                  (runExceptT, throwError)+import           Control.Monad.IO.Class                (MonadIO (liftIO))+import           Control.Monad.State.Strict            (MonadState (get, put),+                                                        State, evalState)+import           Control.Monad.Trans                   (lift)+import           Control.Monad.Trans.Except            (ExceptT)+import           Data.Data                             (Data)+import           Data.Function                         (on, (&))+import           Data.Generics.Schemes                 (everywhereM)+import           Data.List.Extra                       (chunksOf, dropEnd,+                                                        takeEnd)+import           Data.List.NonEmpty                    (NonEmpty ((:|)),+                                                        nonEmpty)+import qualified Data.List.NonEmpty                    as NE+import           Data.List.NonEmpty.Extra              ((|:))+import           Data.Maybe                            (isJust, listToMaybe,+                                                        mapMaybe, maybeToList)+import           Data.Semigroup                        (sconcat)+import           Data.Text                             (Text)+import qualified Data.Text                             as T+import           Development.IDE                       (FileDiagnostic (fdStructuredMessage),+                                                        GetParsedModule (GetParsedModule),+                                                        GhcSessionDeps (GhcSessionDeps),+                                                        HscEnvEq (hscEnv),+                                                        IdeState (shakeExtras),+                                                        Pretty (pretty), Range,+                                                        Recorder, WithPriority,+                                                        runAction,+                                                        spanContainsRange)+import           Development.IDE.Core.FileStore        (getVersionedTextDoc)+import           Development.IDE.Core.PluginUtils      (activeDiagnosticsInRange,+                                                        runActionE, useE)+import           Development.IDE.GHC.Compat            (ConLike (PatSynCon, RealDataCon),+                                                        HoleKind (HoleVar),+                                                        HsMatchContext (CaseAlt),+                                                        HscEnv (hsc_dflags), Id,+                                                        NamedThing (getName),+                                                        Outputable (ppr),+                                                        getLoc, showSDocUnsafe)+import           Development.IDE.GHC.Compat.Core       (AnnListItem,+                                                        EpAnnHsCase (EpAnnHsCase),+                                                        GrhsAnn (..),+                                                        HasSrcSpan,+                                                        HsLamVariant (LamCase),+                                                        HsMatchContext (LamAlt),+                                                        LocatedAn,+                                                        lann_trailing,+                                                        srcSpanStartCol,+                                                        srcSpanStartLine)+import qualified Development.IDE.GHC.Compat.Core       as Ext+import           Development.IDE.GHC.Compat.Error      (DsMessage (DsNonExhaustivePatterns),+                                                        _DsMessage,+                                                        msgEnvelopeErrorL)+import           Development.IDE.GHC.Compat.ExactPrint (d0, d1, exactPrint,+                                                        getEntryDP,+                                                        noAnnSrcSpanDP1,+                                                        setEntryDP)+import           Development.IDE.Types.Diagnostics     (FileDiagnostic (fdLspDiagnostic),+                                                        _SomeStructuredMessage)+import           GHC                                   (AnnList (AnnList),+                                                        AnnListBrackets (ListBraces),+                                                        DynFlags (extensions),+                                                        EpAnn (EpAnn),+                                                        EpToken (EpTok),+                                                        HasLoc (getHasLoc),+                                                        LMatch,+                                                        ParsedModule (pm_parsed_source),+                                                        ParsedSource,+                                                        realSrcSpan)+import           GHC.Driver.DynFlags                   (OnOff (On))+import           GHC.Hs                                (DeltaPos (deltaColumn),+                                                        EpAnnLam (EpAnnLam),+                                                        GhcPs,+                                                        HsRecFields (HsRecFields),+                                                        XCase, XLam, deltaPos,+                                                        getDeltaLine,+                                                        unnamedHoleRdrName)+import           GHC.HsToCore.Pmc.Solver.Types         (Nabla (nabla_tm_st),+                                                        PmAltCon (..),+                                                        PmAltConApp (..),+                                                        TmState (ts_facts),+                                                        VarInfo (vi_pos))+import           GHC.Parser.Annotation                 (EpUniToken (EpUniTok),+                                                        IsUnicodeSyntax (NormalSyntax, UnicodeSyntax),+                                                        TrailingAnn (AddSemiAnn),+                                                        addTrailingAnnToA,+                                                        emptyComments,+                                                        noSrcSpanA)+import           GHC.Types.Name.Reader                 (nameRdrName)+import           GHC.Types.SrcLoc                      (GenLocated (L),+                                                        SrcSpan (RealSrcSpan),+                                                        combineSrcSpans)+import           GHC.Types.Unique.SDFM                 (lookupUSDFM)+import           Ide.Logger                            (Priority (Warning),+                                                        logWith)+import           Ide.Plugin.Error                      (PluginError,+                                                        getNormalizedFilePathE)+import           Ide.PluginUtils                       (WithDeletions (IncludeDeletions),+                                                        diffText)+import           Ide.Types                             (Config, HandlerM,+                                                        PluginDescriptor (pluginHandlers),+                                                        PluginId,+                                                        PluginMethodHandler,+                                                        defaultPluginDescriptor,+                                                        mkPluginHandler,+                                                        pluginGetClientCapabilities)+import           Language.Haskell.Syntax               (HsConDetails (PrefixCon, RecCon),+                                                        HsLocalBindsLR (EmptyLocalBinds),+                                                        LHsExpr,+                                                        MatchGroup (MG, mg_alts),+                                                        NoExtField (NoExtField),+                                                        Pat (..))+import           Language.Haskell.Syntax.Expr          (GRHS (GRHS),+                                                        GRHSs (GRHSs),+                                                        HsExpr (HsCase, HsHole, HsLam),+                                                        Match (..))+import qualified Language.LSP.Protocol.Lens            as L+import           Language.LSP.Protocol.Message         (Method (Method_TextDocumentCodeAction))+import qualified Language.LSP.Protocol.Message         as LSP+import           Language.LSP.Protocol.Types           (ClientCapabilities,+                                                        CodeAction (..),+                                                        CodeActionKind (CodeActionKind_QuickFix),+                                                        CodeActionParams (CodeActionParams, _range, _textDocument),+                                                        Diagnostic,+                                                        NormalizedFilePath,+                                                        TextDocumentIdentifier,+                                                        VersionedTextDocumentIdentifier,+                                                        WorkspaceEdit,+                                                        isSubrangeOf,+                                                        type (|?) (InL, InR))+import qualified Language.LSP.Protocol.Types           as Diag (Diagnostic (_range))+import           Type.Reflection                       (eqTypeRep,+                                                        type (:~~:) (HRefl),+                                                        typeOf, typeRep)++data Log where+  LogPatternNotSupportedYet :: String -> Log++instance Pretty Log where+  pretty (LogPatternNotSupportedYet unsupportedPat) = "The case-split plugin does not support the pattern " <> pretty unsupportedPat <> " yet."++descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId = (defaultPluginDescriptor plId "Provides the split case code action")+  { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCodeAction (suggestCaseSplitProvider recorder)+  }++caseSplitPluginCodeActionTitle :: Text+caseSplitPluginCodeActionTitle = "Add placeholders for missing patterns"++suggestCaseSplitProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction+suggestCaseSplitProvider recorder state _ CodeActionParams{..}+  = do++  nfp <- getNormalizedFilePathE $ _textDocument ^. L.uri++  fileDiags <- activeDiagnosticsInRange (shakeExtras state) nfp _range++  let diagAndMissingCtors = getInnermost . extractDiagAndMissingCtors $ fileDiags++  arrowSyntax <- getArrowSyntax state nfp+  psOld <- getParsedSource state nfp+  caps <- lift pluginGetClientCapabilities+  verTxtDocId <- lift $ getVerTxtDocId state _textDocument++  codeAction <- case traverse (makeCodeAction caps verTxtDocId psOld arrowSyntax) diagAndMissingCtors of+                     Left unsupportedPat -> do logWith recorder Warning $ LogPatternNotSupportedYet unsupportedPat+                                               pure Nothing+                     Right cAct -> pure cAct++  pure $ InL $ InR <$> maybeToList codeAction++  where+    makeCodeAction :: ClientCapabilities+                   -> VersionedTextDocumentIdentifier+                   -> ParsedSource+                   -> IsUnicodeSyntax+                   -> (Diagnostic, MissingPatterns)+                   -> Either String CodeAction+    makeCodeAction caps verTxtDocId psOld arrowSyntax (diag, pmAltsConApps)+        = do psNew <- graftMissingPatterns psOld _range pmAltsConApps arrowSyntax+             pure $ make diag $ makeEditText caps verTxtDocId psOld psNew+      where+        make :: Diagnostic -> WorkspaceEdit -> CodeAction+        make diag edit+          = CodeAction { _title       = caseSplitPluginCodeActionTitle+                       , _kind        = Just CodeActionKind_QuickFix+                       , _diagnostics = Just [diag]+                       , _isPreferred = Nothing+                       , _disabled    = Nothing+                       , _edit        = Just edit+                       , _command     = Nothing+                       , _data_       = Nothing }++-- | Retrieve 'VersionedTextDocumentIdentifier' from the handler.+getVerTxtDocId :: IdeState -> TextDocumentIdentifier -> HandlerM Config VersionedTextDocumentIdentifier+getVerTxtDocId state textDoc = liftIO $ runAction "CaseSplit.GetVersionedTextDoc" state $ getVersionedTextDoc textDoc++-- | Retrieve 'ParsedSource' from the handler.+getParsedSource :: IdeState -> NormalizedFilePath -> ExceptT PluginError (HandlerM Config) ParsedSource+getParsedSource state nfp = pm_parsed_source <$> runActionE "CaseSplit.GetParsedModule"+                                                            state+                                                            (useE GetParsedModule nfp)++-- | Retrieve 'IsUnicodeSyntax' from the handler.+getArrowSyntax :: IdeState -> NormalizedFilePath -> ExceptT PluginError (HandlerM Config) IsUnicodeSyntax+getArrowSyntax state nfp = do+  (hsc_dflags . hscEnv -> dynFlags) <- runActionE "CaseSplit.GhcSessionDeps" state $ useE GhcSessionDeps nfp+  pure $ if On Ext.UnicodeSyntax `elem` extensions dynFlags+    then UnicodeSyntax+    else NormalSyntax++-- | Obtain a 'WorkspaceEdit' as 'diffText' of 'exactPrint'-ed versions of old+-- and new 'ParsedSource's.+makeEditText :: ClientCapabilities -> VersionedTextDocumentIdentifier -> ParsedSource -> ParsedSource -> WorkspaceEdit+makeEditText caps verTxtDocId psOld psNew = do+  let old = T.pack $ exactPrint psOld+  let new = T.pack $ exactPrint psNew+  diffText caps (verTxtDocId, old) new IncludeDeletions++-- | Type synonym for slighly improved readability.+type MissingPatterns = NonEmpty PmAltConApp++-- | Given a @[FileDiagnostic]@ retain only those relative+-- to the GHC-62161 diagnostic and extract the list of missing+-- patterns from those.+extractDiagAndMissingCtors :: [FileDiagnostic] -> [(Diagnostic, MissingPatterns)]+extractDiagAndMissingCtors = map -- For each 'FileDiagnostic',+                                 (fdLspDiagnostic -- extract is 'Diagnostic'+                                 &&&+                                 -- and 'Maybe' a 'NonEmpty' list of 'PmAltConApp',+                                 (getDsMessage >=> getPmAltConApps >=> nonEmpty))+                          -- finally, discard the irrelevant diagnostics.+                          >>> (mapMaybe sequence :: [(a, Maybe b)] -> [(a, b)])+  where++    getDsMessage :: FileDiagnostic -> Maybe DsMessage+    getDsMessage d = fdStructuredMessage d ^? _SomeStructuredMessage . msgEnvelopeErrorL . _DsMessage++    getPmAltConApps :: DsMessage -> Maybe [PmAltConApp]+    getPmAltConApps =+      \case DsNonExhaustivePatterns CaseAlt _ _ [identifier] nablas -> nablasToPmAlts identifier nablas+            DsNonExhaustivePatterns (LamAlt LamCase) _ _ [identifier] nablas -> nablasToPmAlts identifier nablas+            _ -> Nothing++-- | Get the innermost (in the sense of 'isSubrangeOf') @(Diagnostic, a)@,+-- accounting for failure.+getInnermost :: [(Diagnostic, a)] -> Maybe (Diagnostic, a)+getInnermost [] = Nothing+getInnermost (a : as) = foldl' go (Just a) as+  where+    go Nothing _ = Nothing+    go (Just acc) a = case (ordSubrange `on` Diag._range . fst) acc a of+      Just GT -> Just a+      Just _  -> Just acc+      Nothing -> Nothing -- If non-total order, give up.++-- | Assign an 'Ordering' to two 'Range's @r1@ and @r2@ according to the+-- 'isSubrangeOf' relationshipt between them. If neither 'isSubrangeOf' the+-- other, return `Nothing`.+ordSubrange :: Range -> Range -> Maybe Ordering+ordSubrange r1 r2+  | r1 == r2 = Just EQ+  | r1 `isSubrangeOf` r2 = Just LT+  | r2 `isSubrangeOf` r1 = Just GT+  | otherwise = Nothing++-- | Retrieve list of pattern match constructors+-- for the type identified by the given 'Id'.+--+-- Relevant information at https://simon.peytonjones.org/assets/pdfs/lower-your-guards.pdf+nablasToPmAlts :: Id -> [Nabla] -> Maybe [PmAltConApp]+nablasToPmAlts identifier nablas = fmap concat $ traverse go nablas+  where+    go = fmap vi_pos+       . flip lookupUSDFM identifier+       . ts_facts+       . nabla_tm_st++-- | Given a 'ParsedSource' and a 'Range' on it, this function uses a bottom-up+-- traversal of the AST to detect the innermost @case@/@\\case@ expression+-- encompassing the user-provided 'Range', and it appends the 'MissingPatterns' to+-- the existing ones, if any, using the syntax @->@ or @→@ depending on the+-- provided 'IsUnicodeSyntax'. The new 'ParsedSource' is returned in the+-- 'Maybe' monad to account for failure.+--+-- Implementation detail: since we want to update exactly one node of the AST+-- we run the computation in a 'State Bool' monad to bail out after one update.+graftMissingPatterns :: ParsedSource -> Range -> MissingPatterns -> IsUnicodeSyntax -> Either String ParsedSource+graftMissingPatterns ps range missingPs arrowSyntax+  = runExceptT (everywhereM go ps) `evalState` False+    where+      go :: forall a. Data a => a -> ExceptT String (State Bool) a+      go node = do+          found <- get+          if | -- Proceed only if we haven't found & edited the node yet,+               not found+               -- only inspect nodes of the appropriate type,+             , Just HRefl <- typeOf node `eqTypeRep` typeRep @(HsExpr GhcPs)+               -- parse the current @case@-like expressions into a 'CaseLike'+               -- (see also 'parseCaseLikeExpr' for more details),+             , Just (CaseLike {_expr, _span, _layout}) <- parseCaseLikeExpr node+               -- make sure the 'range' is somewhere in the span of that+               -- expression,+             , Just True <- _span `spanContainsRange` range+               -> do -- take note we've found the node,+                     put True+                     -- extract existing matches+                     let existingMatches = _matchGroup _expr+                     -- make a match out of each missing pattern,+                     case traverse (makeMatch arrowSyntax) missingPs of+                        -- If this sort of pattern is not supported, we abort,+                        Left unsupportedPat  -> throwError unsupportedPat+                        -- otherwise we continue+                        Right missingMatches -> -- by appending the missing matches to the existing ones+                                               appendMissingPats _layout existingMatches missingMatches+                                               -- and setting those matches in a new expression.+                                             & setMatches _expr+                                             & pure+             -- Anything else, leave the node unchanged.+             | otherwise -> pure node++-- | While @HsExpr GhcPs@ can contain any expression, the following refined+-- type can only contain a @case@ or a @\\case@ expression.+data CaseLikeExpr = Case { _extCase    :: XCase GhcPs+                         , _scrut      :: LHsExpr GhcPs+                         , _matchGroup :: MatchGroup GhcPs (LHsExpr GhcPs)+                         }+                  | LambdaCase { _extLamCase :: XLam GhcPs+                               , _matchGroup :: MatchGroup GhcPs (LHsExpr GhcPs)+                               }++-- | A 'CaseLikeExpr' enriched with the 'SrcSpan' it occupies, together with+-- its 'MatchLayout'.+data CaseLike = CaseLike { _expr   :: CaseLikeExpr+                         , _span   :: SrcSpan+                         , _layout :: MatchLayout+                         }++-- | Parse an @HsCase _ _ mg@ or @HsLam _ LamCase mg@ out of a @HsExpr GhcPs@+-- into the refined type 'ConLike'.+parseCaseLikeExpr :: HsExpr GhcPs -> Maybe CaseLike++parseCaseLikeExpr (HsCase ext scrut matchGroup)+  | EpAnnHsCase (EpTok caseTok) (EpTok ofTok) <- ext+  , let caseSSpan = getHasLoc caseTok+        ofSSpan = getHasLoc ofTok+  , MG _ (L (EpAnn endTok _ _) _) <- matchGroup+  , let endSSpan = getHasLoc endTok+        span = caseExprSpan caseSSpan ofSSpan endSSpan+  = Just $ CaseLike { _expr = Case ext scrut matchGroup+                    , _span = span+                    , _layout = parseMatchLayout matchGroup+                    }++parseCaseLikeExpr (HsLam ext LamCase matchGroup)+  | EpAnnLam (EpTok backslashTok) (Just caseTok) <- ext+  , let backslashSSpan = getHasLoc backslashTok+        caseSSpan = getHasLoc caseTok+  , MG _ (L (EpAnn endTok _ _) _) <- matchGroup+  , let endSSpan = getHasLoc endTok+        span = caseExprSpan backslashSSpan caseSSpan endSSpan+  = Just $ CaseLike { _expr = LambdaCase ext matchGroup+                    , _span = span+                    , _layout = parseMatchLayout matchGroup+                    }++parseCaseLikeExpr _ = Nothing++-- | Isomorphic to @'Maybe' 'Matches'@, this type encodes whether a @case@-like+-- expression has braces; if it does, the type also records whether there are+-- pre-existing matches.+data MatchLayout = Braced Matches | NonBraced++-- | Isomorphic to @Maybe Int@, this type encodes whether there are+-- pre-existing matches in a @case@-like expression **with braces**, and - if+-- there are -  what's the indentation of the first of them.+--+-- Note: it could also model the same concept for the non-braced case, but that's+-- not needed (see also 'MatchLayout').+data Matches = NoMatches | SomeMatches !Int++-- | Given a 'MatchGroup', this function returns its 'MatchLayout'.+parseMatchLayout :: MatchGroup GhcPs (LHsExpr GhcPs) -> MatchLayout+parseMatchLayout (MG { mg_alts = L altsLoc existingMatches })+  = case (getOpeningBraceCol altsLoc, getStartCol <$> listToMaybe existingMatches) of+      (Nothing, _) -> NonBraced+      (_, Nothing) -> Braced NoMatches+      (Just openingBraceCol, Just fstExistingMatchCol)+        -> let indent = fstExistingMatchCol - openingBraceCol+           in Braced $ SomeMatches indent++-- | Given a @case@ or @\\case@ expression wrapped in the refined 'CaseLikeExpr'+-- type and a 'MatchGroup', it creates an actual corresponding @HsExpr GhcPs@+-- with that 'MatchGroup' in it.+setMatches :: CaseLikeExpr -> MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs+setMatches (Case x s _) mg     = HsCase x s mg+setMatches (LambdaCase x _) mg = HsLam x LamCase mg++-- | Given the 'SrcSpan' of the @case@ token, the @of@ token, and the end of+-- the alternatives, this function combines them to return a 'SrcSpan' that goes+-- from the @case@ token to the end of the whole @case@ expression.+caseExprSpan :: SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan+caseExprSpan caseSSpan _ endSSpan@(RealSrcSpan _ _) = combineSrcSpans caseSSpan endSSpan+caseExprSpan caseSSpan ofSSpan _ = combineSrcSpans caseSSpan ofSSpan++-- | Given a 'MatchGroup' and a list of 'LMatch'es, this function inserts the+-- latter matches in the former group, trying to honor the existing layout,+-- returning the new 'MatchGroup' in the 'Maybe' monad to account for failure.+--+-- For the meaning of the first argument of type @Maybe Int@, see+-- 'getIndentation'.+--+-- Honoring the existing layout means two things:+--+--   1. producing valid code, which means:+--+--      - adding semicolons wherever they are needed, i.e.+--+--        - if matches are braced, for every matches,+--+--        - otherwise, for all but the last matches for groups of matches+--          that are not aligned vertically, e.g.+--+--            - matches shown on the same line, which this plugin can produce,+--+--            - matches shown on different lines but in a "staircase" way,+--              which this plugin never produces).+--+--      - using the correct indentation when matches are not braced (when+--        matches are braced, the code will stay valid irrespective of the+--        indentation of the alternatives).+--+--   2. such valid code tries to adhere to the existing layout, which means:+--+--      - don't alter position of existing matches nor of the opening @{@;+--+--      - when matches are not braced, we align the first match we insert+--        with the pre-existing previous match+--+--      - we have to make some arbitrary decision+--+--        - when matches are not braced and no previous match exists,+--          we indent by @indentation def@ with respect to whatever layout+--          context is the current one;+--+--        - as regards the number of matches to print per line, we inspect the+--          last group of matches appearing on one line, to determine how many+--          matches per line we insert.+--+--        - when matches are braced, we also align them vertically (it would+--          not be necessary, in principle).+--+--+-- Refer to test cases to see practical examples.+appendMissingPats :: MatchLayout+                  -> MatchGroup GhcPs (LHsExpr GhcPs)+                  -> NonEmpty (LMatch GhcPs (LHsExpr GhcPs))+                  -> MatchGroup GhcPs (LHsExpr GhcPs)+appendMissingPats matchLayout mg@(MG { mg_alts = L altsLoc existingMatches }) missingMatches+  = let -- Choose how many patterns per line we are emitting:+        chunkSize = case existingMatches of+                 [] -> 1 -- trivially 1 if there's no existing matches,+                      -- otherwise, set the size equal to the length+                      -- of the last group of @existingMatches@ that+                      -- are on the same line:+                 _ -> NE.length+                    $ NE.last+                    $ NE.groupBy1 startSameLine (NE.fromList existingMatches)++        -- Chunkify the matches to be inserted:+        missingGroup :| missingGroups = prettyChunksOf chunkSize missingMatches++        -- Detect if the list of alternatives is between @{@ and @}@:+        isBraced = isJust $ getOpeningBraceCol altsLoc++        -- Finally, lay out the missing matches:+        missingMatchesEP = -- indent the first group and the following ones (see discussion above)+                           mapFirst indentHead missingGroup :| map (mapFirst indentTail) missingGroups+                           -- add a semicolon to the end of each group only if the alternatives are braced+                         & (if isBraced then addSemicols else id)+                           -- put each group on its own line+                         & NE.map (mapFirst putOnNewLine)+                           -- concatenate the groups+                         & sconcat+                           -- turn into an ordinary list+                         & NE.toList+          where+            -- add semicolons:+            addSemicols = NE.zipWith ($)+                                      -- for each one-line group of matches,+                                     (replicate (length missingGroups)+                                                -- only to the last match of the group,+                                                (mapLast addSemiCol)+                                      -- except for the last group+                                      |: id)++            -- Indentation is complicated.+            --+            -- For a non-braced @case@-like expression, the first match **of the+            -- whole expression** (I mean, not the first match **to be inserted**)+            -- has some anchor that depends on the surrounding code, while the+            -- following matches all use their own predecessor as the anchor.+            --+            -- Otherwise (i.e. for a braced @case@-like expression), all matches+            -- including the first one have the same anchor that depends on the+            -- surrounding code.+            --+            -- Therefore, here's how we set the DeltaPos for the first and+            -- following matches:+            (setDPCol -> indentHead, setDPCol -> indentTail)+               = case matchLayout of+                   NonBraced | null existingMatches  -> (indentation def, 0)+                   NonBraced                         -> (0, 0)+                   Braced (SomeMatches indent)       -> (indent, indent)+                   Braced NoMatches                  -> let indent = indentation def+                                                        in (indent, indent)++        -- Only if there's braces do we need to make sure the last of the+        -- existing matches ends with @;@:+        existingMatchesEP = if isBraced+                               then dropEnd 1 existingMatches <> (addSemiCol <$> takeEnd 1 existingMatches)+                               else existingMatches++    in mg { mg_alts = L altsLoc (existingMatchesEP <> missingMatchesEP) }++-- | Accepts a @NonEmpty (LocatedAn AnnListItem a)@ and chunkifies it by the given 'size',+-- putting all matches of each chunk on the same line, leaving 1 space in between, and+-- keeping the code valid by adding semicolons to all but the last match of each chunk.+prettyChunksOf :: Int -> NonEmpty (LocatedAn AnnListItem a) -> NonEmpty (NonEmpty (LocatedAn AnnListItem a))+prettyChunksOf size allMatches = do+  -- For each chunk+  chunk <- chunksOf1 size allMatches+  pure $ fromZipList+       $ do -- of all the matches of chunk+            match       <- toZipList chunk+            -- from the second match onwards, they go the same line, one space apart+            putBeside   <- toZipList $ id :| repeat (setDP 0 1)+            -- all but the last match get a semicolon+            addSemicols <- toZipList $ replicate (length chunk - 1) addSemiCol |: id+            -- apply+            pure $ addSemicols $ putBeside match+  where+    toZipList = ZipList . NE.toList+    fromZipList = NE.fromList . getZipList++-- | Given a 'IsUnicodeSyntax', describing whether to use @->@ or @→@, and a+-- 'PmAltConApp', this function produces an 'LMatch' (to be inserted in the+-- list of existing 'LMatch'es contained by a 'MatchGroup'), returning it into+-- a 'Maybe' to account for failure.+--+-- The 'LMatch' is constructed in its entirety, by passing "default" values wherever+-- possible, except, obviously, for two:+--+--  - the constructor name,+--  - the arguments to the constructor, all rendered as individual underscores+--    when there's less than @maxUnderscores def@, or as a single @{}@ otherwise.+makeMatch :: IsUnicodeSyntax -> PmAltConApp -> Either String (LMatch GhcPs (LHsExpr GhcPs))+makeMatch arrow pmAltConApp = makeLMatch <$> parseSimpleConMatch arrow pmAltConApp++parseSimpleConMatch :: IsUnicodeSyntax -> PmAltConApp -> Either String SimpleConMatch+parseSimpleConMatch arrow PACA{ paca_con = PmAltConLike con+                              , paca_ids+                              }+  = let dataCon = case con of+                    RealDataCon dataCon -> getName dataCon+                    PatSynCon dataCon   -> getName dataCon++        locatedCon = L noSrcSpanA $ nameRdrName dataCon++        conPat = if length paca_ids <= maxUnderscores def -- for low number of arguments+                     -- create as many underscores as needed+                   then ConPat { pat_con_ext = (Nothing, Nothing)+                               , pat_con = locatedCon+                               , pat_args = PrefixCon $ map (const $ L noAnnSrcSpanDP1 $ WildPat NoExtField) paca_ids+                               }+                     -- otherwise use braces.+                   else ConPat { pat_con_ext = (Just (EpTok d1), Just (EpTok d0))+                               , pat_con = locatedCon+                               , pat_args = RecCon (HsRecFields NoExtField [] Nothing)+                               }+    in Right+     $ SimpleConMatch { _arrow = arrow+                      , _conPat = conPat }++parseSimpleConMatch _ paca = Left $ showSDocUnsafe $ ppr paca++-- | Wrapper to the all the non-default info needed to construct an 'LMatch':+--+--      - the arrow syntax (@->@ or @→@),+--      - the constructor pattern (e.g. @Foo _ _@ for a binary constructor).+data SimpleConMatch = SimpleConMatch { _arrow  :: IsUnicodeSyntax+                                     , _conPat :: Pat GhcPs+                                     }++-- | Produce an 'LMatch' using defaults for all but the information contained+-- in the given a 'SimpleConMatch'.+makeLMatch :: SimpleConMatch -> LMatch GhcPs (LHsExpr GhcPs)+makeLMatch SimpleConMatch{..}+  = L noSrcSpanA $ Match { m_ext = NoExtField+                         , m_ctxt = CaseAlt+                         , m_pats = L noSrcSpanA [L noSrcSpanA _conPat]+                         , m_grhss = GRHSs emptyComments+                                           -- TODO: check whether ga_sep default choice is really not printing anything.+                                           (NE.singleton $ L noSrcSpanA $ GRHS (EpAnn noSrcSpanA+                                                                                      (GrhsAnn{ ga_vbar = Nothing+                                                                                              , ga_sep = Right $ EpUniTok d1 _arrow })+                                                                                      emptyComments) []+                                                         $ L noSrcSpanA $ HsHole $ HoleVar $ L noAnnSrcSpanDP1 $ unnamedHoleRdrName)+                                           (EmptyLocalBinds NoExtField)+                         }++-- | TODO: We could could make these values customizable via HLS plugin+-- settings.+--+-- Other things that we could store here are:+--+--    - the maximum number of alternatives on one line+--    - whether or not to put the @;@ for the last alternative+data Default = Default {+  -- | Max number of underscores to show for the constructor of an alternative.+  -- Beyond this, the record syntax with empty braces is used.+  maxUnderscores :: Int+  -- | Indentation used when there's no existing alternatives to refer to.+  -- Such indentation is with respect to the current layout context.+, indentation    :: Int+}++def :: Default+def = Default { maxUnderscores = 3+              , indentation = 2 }++-- | Predicate telling if two located annotations are (actually, start) on the+-- same line.+startSameLine :: LocatedAn ann e -> LocatedAn ann e -> Bool+startSameLine = (==) `on` getStartLine+  where+    -- | Get the starting line of an 'HasSrcSpan'.+    getStartLine :: HasSrcSpan a => a -> Int+    getStartLine = srcSpanStartLine . realSrcSpan . getLoc+++-- | Given an @EpAnn (AnnList a)@ return the starting column of+-- its opening brace, if any, otherwise 'Nothing'.+getOpeningBraceCol :: EpAnn (AnnList a) -> Maybe Int+getOpeningBraceCol (EpAnn _ (AnnList _ (ListBraces (EpTok col) _) _ _ _) _) = Just $ getStartCol $ getHasLoc col+getOpeningBraceCol _ = Nothing++-- | Get the starting column of an 'HasSrcSpan'.+getStartCol :: HasSrcSpan a => a -> Int+getStartCol = srcSpanStartCol . realSrcSpan . getLoc++-- | Set the DeltaPos for the given annotation.+setDP :: Int -> Int -> LocatedAn t a -> LocatedAn t a+setDP deltaLine deltaColumn lann = setEntryDP lann $ deltaPos deltaLine deltaColumn++-- | Set the deltaColumn for the given annotation.+setDPCol :: Int -> LocatedAn t a -> LocatedAn t a+setDPCol deltaColumn lann = setEntryDP lann+                          $ (\d -> deltaPos (getDeltaLine d) deltaColumn)+                          $ getEntryDP lann++-- | Set the deltaLine for the given annotation.+setDPLine :: Int -> LocatedAn t a -> LocatedAn t a+setDPLine deltaLine lann = setEntryDP lann+                          $ (\d -> deltaPos deltaLine (deltaColumn d))+                          $ getEntryDP lann++-- | Useful helper.+putOnNewLine :: LocatedAn t a -> LocatedAn t a+putOnNewLine = setDPLine 1++-- | Add semicolon, unless one is already present.+addSemiCol :: LocatedAn AnnListItem a -> LocatedAn AnnListItem a+addSemiCol (L l@(EpAnn _ ls _) e)+  | none isSemiCol (lann_trailing ls)+  = L (addTrailingAnnToA (AddSemiAnn (EpTok d0)) emptyComments l) e+  where+    isSemiCol :: TrailingAnn -> Bool+    isSemiCol (AddSemiAnn _) = True+    isSemiCol _              = False+addSemiCol l = l++-- | Version of 'Data.List.Extra.chunksOf' (**not** to be confused with+-- 'Data.List.Split.chunksOf') for a 'NonEmpty' lists.+chunksOf1 :: Int -> NonEmpty a -> NonEmpty (NonEmpty a)+chunksOf1 n xs+  | n >= 1+  , (b:before, after) <- NE.splitAt n xs+    = (b :| before) :| case after of+                         [] -> []+                         _  -> map NE.fromList $ chunksOf n after+  | otherwise = error "chunksOf1: the `Int` argument should be ≥ 1"++-- | Maps a function @f@ over the first element of a 'NonEmpty' list.+mapFirst :: (a -> a) -> NonEmpty a -> NonEmpty a+mapFirst f (a :| as) = f a :| as++-- | Maps a function @f@ over the last element of a 'NonEmpty' list.+mapLast :: (a -> a) -> NonEmpty a -> NonEmpty a+mapLast f (a :| [])     = f a :| []+mapLast f (a :| b : cs) = a :| NE.toList (mapLast f $ b :| cs)++-- | Convenient negation of 'any'.+none :: Foldable t => (a -> Bool) -> t a -> Bool+none p xs = not $ any p xs
+ plugins/hls-case-split-plugin/test/Main.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}++module Main+  ( main+  ) where++import           Control.Lens               (Prism', prism', (^.), (^..), (^?))+import           Data.Text                  (Text)+import qualified Ide.Plugin.CaseSplit       as CS+import qualified Language.LSP.Protocol.Lens as L+import           System.FilePath+import           Test.Hls                   hiding (waitForDiagnosticsFrom)+import qualified Test.Hls.FileSystem        as FS++main :: IO ()+main = defaultTestRunner tests++caseSplitPlugin :: PluginTestDescriptor CS.Log+caseSplitPlugin = mkPluginTestDescriptor CS.descriptor "case split"++tests :: TestTree+tests = testGroup+  "case split"+  [ codeActionTests+  ]++codeActionTests :: TestTree+codeActionTests = testGroup+  "code actions" $ let title = CS.caseSplitPluginCodeActionTitle in+  [ goldenWithClass "No patterns, no braces" "TNoPatternsNoBraces" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "Some patterns, no braces" "TSomePatternsNoBraces" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "Some patterns, with braces" "TSomePatternsWithBraces" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "No patterns, with braces" "TNoPatternsWithBraces" $+      Prelude.flip inspectCodeAction [title]++  -- Comments preserved+  , goldenWithClass "No patterns, no braces, comment after `of`" "TNoPatternsNoBracesWithComment" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "Some patterns, no braces, comment after `of`" "TSomePatternsNoBracesWithComment" $+      Prelude.flip inspectCodeAction [title]++  -- Windows support+  , expectFailBecause "https://github.com/haskell/haskell-language-server/issues/5059"+    $ goldenWithClass "Like TNoPatternsNoBraces, but lacks line terminator at EOF" "TNoPatternsNoBracesWindows" $+      Prelude.flip inspectCodeAction [title]++  -- Patterns with irregular indentation+  , goldenWithClass "Jagged patterns, no braces" "TJaggedNoBraces" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "Jagged patterns, with braces" "TJaggedWithBraces" $+      Prelude.flip inspectCodeAction [title]++  -- Patterns on one line+  , goldenWithClass "Some patterns on one line, no braces" "TSomePatternsOnOneLineNoBraces" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "Some patterns on one line, with braces" "TSomePatternsOnOneLineWithBraces" $+      Prelude.flip inspectCodeAction [title]++  -- Records+  , goldenWithClass "Records' field names are ignored" "TRecordsFieldNamesIgnored" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "Too many fields are collapsed" "TManyFields" $+      Prelude.flip inspectCodeAction [title]++  -- GADTs+  , goldenWithClass "GADT - simple" "TGADTsimple" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "GADT - advanced" "TGADTadvanced" $+      Prelude.flip inspectCodeAction [title]++  -- LambdaCase+  , goldenWithClass "LambdaCase, no patterns, no braces" "TLambdaCaseNoPatternsNoBraces" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "LambdaCase, no patterns, with braces" "TLambdaCaseNoPatternsWithBraces" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "LambdaCase, some patterns, no braces" "TLambdaCaseSomePatternsNoBraces" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "LambdaCase, some patterns, with braces" "TLambdaCaseSomePatternsWithBraces" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "LambdaCase in `do`, no patterns, no braces" "TLambdaCaseInDoNoPatternsNoBraces" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "LambdaCase in `do`, no patterns, with braces" "TLambdaCaseInDoNoPatternsWithBraces" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "LambdaCase in `do`, some patterns, no braces" "TLambdaCaseInDoSomePatternsNoBraces" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "LambdaCase in `do`, some patterns, with braces" "TLambdaCaseInDoSomePatternsWithBraces" $+      Prelude.flip inspectCodeAction [title]++  -- Inside where+  , expectNoCodeActionAvailable "Inside `where`, without signature" "TInsideWhereWithoutSignature"+  , goldenWithClass "Inside `where`" "TInsideWhere" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "Inside nested `where`" "TInsideNestedWhere" $+      Prelude.flip inspectCodeAction [title]++  -- Overlapping diagnostics+  , goldenWithClass "Expression is `_`" "TExpressionIsUnderscore" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithRange "Overlapping pattern matches" "TOverlappingExistingPatterns" $+      Range (Position 15 4) (Position 15 5)++  -- Inside let+  , goldenWithClass "Inside `let`'s declarations" "TInsideLetDeclarations" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "Inside `let`'s expression" "TInsideLetExpression" $+      Prelude.flip inspectCodeAction [title]++  -- Inside do+  , goldenWithClass "Inside `let`'s declarations inside `do`" "TInsideLetDeclarationsInsideDo" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "Inside `let`'s expression inside `do`" "TInsideLetExpressionInsideDo" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "Inside `do`" "TInsideDo" $+      Prelude.flip inspectCodeAction [title]++  -- Nested case expressions+  , goldenWithClass "Complete `case` nested in incomplete `case`" "TCompleteCaseInsideIncompleteCase" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithRange "Incomplete `case` nested in complete `case`" "TIncompleteCaseInsideCompleteCase" $+      Range (Position 15 16) (Position 15 17)+  , goldenWithRange "Incomplete `case` nested in incomplete `case`" "TIncompleteCaseInsideIncompleteCase" $+      Range (Position 15 30) (Position 15 31)++  -- Pattern synonyms and COMPLETE pragma+  , goldenWithClass "Pattern synonyms not declared `COMPLETE` are ignored" "TPatternSynonyms" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "If some pattern synonyms are declared `COMPLETE`, actual constructs are ignored" "TPatternSynonymsWithCompletePragma" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "In presence of `COMPLETE` constructors, only add them" "TOrdinaryCtorsWithCompletePragma" $+      Prelude.flip inspectCodeAction [title]+  , goldenWithClass "In presence of `COMPLETE` constructors and patterns, only add them" "TPatternSynAndSomeCtorsAreComplete" $+      Prelude.flip inspectCodeAction [title]++  -- Extreme cursor positions (here we're considering the cursor as being+  -- 0-chars wide and sitting between characters, i.e. a `Range c c`, which in+  -- line with the LSP's specs).+  , expectCodeActionsAvailable "Cursor right before the space before the `c` of `case`" "TNoPatternsNoBraces"+      (Range (Position 12 7) (Position 12 7))+      []++  , expectCodeActionsAvailable "Cursor right before `c` of `case`" "TNoPatternsNoBraces"+      (Range (Position 12 8) (Position 12 8))+      [ CS.caseSplitPluginCodeActionTitle+      ]++  , expectCodeActionsAvailable "Cursor right after `f` of `of`" "TNoPatternsNoBraces"+      (Range (Position 12 17) (Position 12 17))+      [ CS.caseSplitPluginCodeActionTitle+      ]++  , expectCodeActionsAvailable "Selection from right after the `f` of `of` to start of next line" "TNoPatternsNoBraces"+      (Range (Position 12 17) (Position 13 0))+      []++  -- Support UnicodeSyntax+  , goldenWithClass "Use → instead of -> when UnicodeSyntax is On" "TUnicodeArrow" $+      Prelude.flip inspectCodeAction [title]++  -- Some more corner cases+  , expectNoCodeActionAvailable "No action on `Int`" "TInt"+  , expectNoCodeActionAvailable "Cannot see through condition of a single catch-all pattern" "TWithCond"+  , goldenWithClass "Ignore catch-all pattern in presence of non-catch-all pattern" "TWithCondAndPat" $+      Prelude.flip inspectCodeAction [title]+  ]++waitForDiagnosticsFrom :: TextDocumentIdentifier -> Session [Diagnostic]+waitForDiagnosticsFrom doc = do+    diagsNot <- skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)+    let diags = diagsNot ^. L.params . L.diagnostics+    if doc ^. L.uri /= diagsNot ^. L.params . L.uri+       || ((not .) . any) ((\case Just (InR "GHC-62161") -> True+                                  _ -> False) . (^. L.code)) diags+       then waitForDiagnosticsFrom doc+       else return diags++_CACodeAction :: Prism' (Command |? CodeAction) CodeAction+_CACodeAction = prism' InR $ \case+  InR action -> Just action+  _          -> Nothing++expectCodeActionsAvailable :: TestName -> FilePath -> Range -> [Text] -> TestTree+expectCodeActionsAvailable title path range actionTitles =+  testCase title $ do+    runSessionWithServerInTmpDir def caseSplitPlugin (mkFs $ FS.directProject (path <.> "hs")) $ do+      doc <- openDoc (path <.> "hs") "haskell"+      _ <- waitForDiagnosticsFrom doc+      caResults <- getCodeActions doc range+      liftIO $ map (^? _CACodeAction . L.title) caResults+        @?= expectedActions+    where+      expectedActions = Just <$> actionTitles++expectNoCodeActionAvailable :: TestName -> FilePath -> TestTree+expectNoCodeActionAvailable title path = expectCodeActionsAvailable title path anywhere []+  where+    anywhere = Range (Position 0 0) (Position 999 999)++goldenWithRange :: TestName -> FilePath -> Range -> TestTree+goldenWithRange title path range =+  goldenWithHaskellDocInTmpDir def caseSplitPlugin title (mkFs $ FS.directProject (path <.> "hs")) path "expected" "hs" $ \doc -> do+    _ <- waitForDiagnosticsFrom doc+    [action] <- concatMap (^.. _CACodeAction) <$> getCodeActions doc range+    executeCodeAction action++goldenWithClass :: TestName -> FilePath -> ([Command |? CodeAction] -> IO CodeAction) -> TestTree+goldenWithClass title path findAction =+  goldenWithHaskellDocInTmpDir def caseSplitPlugin title (mkFs $ FS.directProject (path <.> "hs")) path "expected" "hs" $ \doc -> do+    _ <- waitForDiagnosticsFrom doc+    actions <- getAllCodeActions doc+    action <- liftIO $ findAction actions+    executeCodeAction action++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-case-split-plugin" </> "test" </> "testdata"++mkFs :: [FS.FileTree] -> FS.VirtualFileTree+mkFs = FS.mkVirtualFileTree testDataDir
+ plugins/hls-case-split-plugin/test/testdata/TCompleteCaseInsideIncompleteCase.expected.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE OrPatterns #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+          A -> 3+          a@(B; C _) -> case a of+                 B -> 3+                 C _ -> 4+          D _ _ -> _+          E -> _+          F -> _
+ plugins/hls-case-split-plugin/test/testdata/TCompleteCaseInsideIncompleteCase.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE OrPatterns #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+          A -> 3+          a@(B; C _) -> case a of+                 B -> 3+                 C _ -> 4
+ plugins/hls-case-split-plugin/test/testdata/TExpressionIsUnderscore.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: Int+foo = case      _     :: X of+  A -> _+  B -> _+  C _ -> _+  D _ _ -> _+  E -> _+  F -> _
+ plugins/hls-case-split-plugin/test/testdata/TExpressionIsUnderscore.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: Int+foo = case      _     :: X of
+ plugins/hls-case-split-plugin/test/testdata/TGADTadvanced.expected.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE GADTs #-}+module T where++data Expr a where+    LitInt :: Int -> Expr Int+    LitBool :: Bool -> Expr Bool+    Add :: Expr Int -> Expr Int -> Expr Int+    Not :: Expr Bool -> Expr Bool+    If :: Expr Bool -> Expr a -> Expr a -> Expr a++prettyExpr :: Expr Bool -> String+prettyExpr expr = case expr of+  LitBool _ -> _+  Not _ -> _+  If _ _ _ -> _
+ plugins/hls-case-split-plugin/test/testdata/TGADTadvanced.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE GADTs #-}+module T where++data Expr a where+    LitInt :: Int -> Expr Int+    LitBool :: Bool -> Expr Bool+    Add :: Expr Int -> Expr Int -> Expr Int+    Not :: Expr Bool -> Expr Bool+    If :: Expr Bool -> Expr a -> Expr a -> Expr a++prettyExpr :: Expr Bool -> String+prettyExpr expr = case expr of
+ plugins/hls-case-split-plugin/test/testdata/TGADTsimple.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE GADTs #-}+module T where++data Expr a where+    LitInt :: Int -> Expr Int+    LitBool :: Bool -> Expr Bool+    Add :: Expr Int -> Expr Int -> Expr Int+    Not :: Expr Bool -> Expr Bool+    If :: Expr Bool -> Expr a -> Expr a -> Expr a++prettyExpr :: Expr a -> String+prettyExpr expr = case expr of+  LitInt _ -> _+  LitBool _ -> _+  Add _ _ -> _+  Not _ -> _+  If _ _ _ -> _
+ plugins/hls-case-split-plugin/test/testdata/TGADTsimple.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE GADTs #-}+module T where++data Expr a where+    LitInt :: Int -> Expr Int+    LitBool :: Bool -> Expr Bool+    Add :: Expr Int -> Expr Int -> Expr Int+    Not :: Expr Bool -> Expr Bool+    If :: Expr Bool -> Expr a -> Expr a -> Expr a++prettyExpr :: Expr a -> String+prettyExpr expr = case expr of
+ plugins/hls-case-split-plugin/test/testdata/TIncompleteCaseInsideCompleteCase.expected.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+          A -> 3+          a -> case a of+            B -> 4+            C _ -> 5+            D _ _ -> _+            E -> _+            F -> _
+ plugins/hls-case-split-plugin/test/testdata/TIncompleteCaseInsideCompleteCase.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+          A -> 3+          a -> case a of+            B -> 4+            C _ -> 5
+ plugins/hls-case-split-plugin/test/testdata/TIncompleteCaseInsideIncompleteCase.expected.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE OrPatterns #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+          A -> 3+          a@(B; C _) -> case a of+                          B -> 3+                          C _ -> _
+ plugins/hls-case-split-plugin/test/testdata/TIncompleteCaseInsideIncompleteCase.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE OrPatterns #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+          A -> 3+          a@(B; C _) -> case a of+                          B -> 3
+ plugins/hls-case-split-plugin/test/testdata/TInsideDo.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> IO ()+foo x = do case x of+             A -> _+             B -> _+             C _ -> _+             D _ _ -> _+             E -> _+             F -> _
+ plugins/hls-case-split-plugin/test/testdata/TInsideDo.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> IO ()+foo x = do case x of
+ plugins/hls-case-split-plugin/test/testdata/TInsideLetDeclarations.expected.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> a+foo x = let r = case x of+              A -> _+              B -> _+              C _ -> _+              D _ _ -> _+              E -> _+              F -> _+      in r
+ plugins/hls-case-split-plugin/test/testdata/TInsideLetDeclarations.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> a+foo x = let r = case x of+      in r
+ plugins/hls-case-split-plugin/test/testdata/TInsideLetDeclarationsInsideDo.expected.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> IO ()+foo x = do+         let r = case x of+               A -> _+               B -> _+               C _ -> _+               D _ _ -> _+               E -> _+               F -> _+          in r
+ plugins/hls-case-split-plugin/test/testdata/TInsideLetDeclarationsInsideDo.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> IO ()+foo x = do+         let r = case x of+          in r
+ plugins/hls-case-split-plugin/test/testdata/TInsideLetExpression.expected.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> a+foo x = let  r = x+   in       case r of+          A -> _+          B -> _+          C _ -> _+          D _ _ -> _+          E -> _+          F -> _
+ plugins/hls-case-split-plugin/test/testdata/TInsideLetExpression.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> a+foo x = let  r = x+   in       case r of
+ plugins/hls-case-split-plugin/test/testdata/TInsideLetExpressionInsideDo.expected.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> IO ()+foo x = do+         let r = x+          in case r of+           A -> _+           B -> _+           C _ -> _+           D _ _ -> _+           E -> _+           F -> _
+ plugins/hls-case-split-plugin/test/testdata/TInsideLetExpressionInsideDo.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> IO ()+foo x = do+         let r = x+          in case r of
+ plugins/hls-case-split-plugin/test/testdata/TInsideNestedWhere.expected.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> a+foo x = bar x+  where+    bar :: X -> a+    bar = baz+      where+        baz :: X -> a+        baz x' = case x' of+          A -> _+          B -> _+          C _ -> _+          D _ _ -> _+          E -> _+          F -> _
+ plugins/hls-case-split-plugin/test/testdata/TInsideNestedWhere.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> a+foo x = bar x+  where+    bar :: X -> a+    bar = baz+      where+        baz :: X -> a+        baz x' = case x' of
+ plugins/hls-case-split-plugin/test/testdata/TInsideWhere.expected.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> a+foo x = bar x+  where+    bar :: X -> a+    bar x' = case x' of+      A -> _+      B -> _+      C _ -> _+      D _ _ -> _+      E -> _+      F -> _
+ plugins/hls-case-split-plugin/test/testdata/TInsideWhere.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> a+foo x = bar x+  where+    bar :: X -> a+    bar x' = case x' of
+ plugins/hls-case-split-plugin/test/testdata/TInsideWhereWithoutSignature.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> a+foo x = bar x+  where+    bar x' = case x' of
+ plugins/hls-case-split-plugin/test/testdata/TInt.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++foo :: Int -> Int+foo x = do case x of+              1 -> 1+              2 -> 2+              i | i < 4 || i > 5 -> 3
+ plugins/hls-case-split-plugin/test/testdata/TJaggedNoBraces.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+          A -> 3;+                B -> 4;+              C _ -> 5+          D _ _ -> _+          E -> _+          F -> _
+ plugins/hls-case-split-plugin/test/testdata/TJaggedNoBraces.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+          A -> 3;+                B -> 4;+              C _ -> 5
+ plugins/hls-case-split-plugin/test/testdata/TJaggedWithBraces.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of {+          A -> 3;+                B -> 4;+              C _ -> 5;+          D _ _ -> _;+          E -> _;+          F -> _ }
+ plugins/hls-case-split-plugin/test/testdata/TJaggedWithBraces.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of {+          A -> 3;+                B -> 4;+              C _ -> 5 }
+ plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoNoPatternsNoBraces.expected.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE LambdaCase #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = do  (  \   case+              A -> _+              B -> _+              C _ -> _+              D _ _ -> _+              E -> _+              F -> _) x
+ plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoNoPatternsNoBraces.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE LambdaCase #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = do  (  \   case) x
+ plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoNoPatternsWithBraces.expected.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE LambdaCase #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = do (\  case {+                      A -> _;+                      B -> _;+                      C _ -> _;+                      D _ _ -> _;+                      E -> _;+                      F -> _}) x
+ plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoNoPatternsWithBraces.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE LambdaCase #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = do (\  case {}) x
+ plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoSomePatternsNoBraces.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE LambdaCase #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = do (\case A -> 1+                  B -> 2+                  C _ -> _+                  D _ _ -> _+                  E -> _+                  F -> _) x
+ plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoSomePatternsNoBraces.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE LambdaCase #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = do (\case A -> 1+                  B -> 2) x
+ plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoSomePatternsWithBraces.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE LambdaCase #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = do (\case { A -> 1;+                    B -> 2;+                    C _ -> _;+                    D _ _ -> _;+                    E -> _;+                    F -> _ }) x
+ plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoSomePatternsWithBraces.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE LambdaCase #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = do (\case { A -> 1;+                    B -> 2 }) x
+ plugins/hls-case-split-plugin/test/testdata/TLambdaCaseNoPatternsNoBraces.expected.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE LambdaCase #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Maybe Int+foo x = pure x >>= \case+  A -> _+  B -> _+  C _ -> _+  D _ _ -> _+  E -> _+  F -> _
+ plugins/hls-case-split-plugin/test/testdata/TLambdaCaseNoPatternsNoBraces.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE LambdaCase #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Maybe Int+foo x = pure x >>= \case
+ plugins/hls-case-split-plugin/test/testdata/TLambdaCaseNoPatternsWithBraces.expected.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE LambdaCase #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Maybe Int+foo x = pure x >>= \case {+                           A -> _;+                           B -> _;+                           C _ -> _;+                           D _ _ -> _;+                           E -> _;+                           F -> _}
+ plugins/hls-case-split-plugin/test/testdata/TLambdaCaseNoPatternsWithBraces.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE LambdaCase #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Maybe Int+foo x = pure x >>= \case {}
+ plugins/hls-case-split-plugin/test/testdata/TLambdaCaseSomePatternsNoBraces.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE LambdaCase #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Maybe Int+foo x = pure x >>= \case A -> Just 1+                         B -> Just 2+                         C _ -> _+                         D _ _ -> _+                         E -> _+                         F -> _
+ plugins/hls-case-split-plugin/test/testdata/TLambdaCaseSomePatternsNoBraces.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE LambdaCase #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Maybe Int+foo x = pure x >>= \case A -> Just 1+                         B -> Just 2
+ plugins/hls-case-split-plugin/test/testdata/TLambdaCaseSomePatternsWithBraces.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE LambdaCase #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Maybe Int+foo x = pure x >>= \case { A -> Just 1;+                           B -> Just 2;+                           C _ -> _;+                           D _ _ -> _;+                           E -> _;+                           F -> _ }
+ plugins/hls-case-split-plugin/test/testdata/TLambdaCaseSomePatternsWithBraces.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE LambdaCase #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Maybe Int+foo x = pure x >>= \case { A -> Just 1;+                           B -> Just 2 }
+ plugins/hls-case-split-plugin/test/testdata/TManyFields.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B Int+       | C Int Int+       | D Int Int Int+       | E Int Int Int Int+       | F Int Int Int Int Int++foo :: X -> Int+foo x = case x of+          A {} -> 1+          B _ -> 2+          C _ _ -> _+          D _ _ _ -> _+          E {} -> _+          F {} -> _
+ plugins/hls-case-split-plugin/test/testdata/TManyFields.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B Int+       | C Int Int+       | D Int Int Int+       | E Int Int Int Int+       | F Int Int Int Int Int++foo :: X -> Int+foo x = case x of+          A {} -> 1+          B _ -> 2
+ plugins/hls-case-split-plugin/test/testdata/TNoPatternsNoBraces.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+  A -> _+  B -> _+  C _ -> _+  D _ _ -> _+  E -> _+  F -> _
+ plugins/hls-case-split-plugin/test/testdata/TNoPatternsNoBraces.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of
+ plugins/hls-case-split-plugin/test/testdata/TNoPatternsNoBracesWindows.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F+-- XXX It is crucial that this file ends without a line terminator!+foo :: X -> Int+foo x = case x of+  A -> _+  B -> _+  C _ -> _+  D _ _ -> _+  E -> _+  F -> _
+ plugins/hls-case-split-plugin/test/testdata/TNoPatternsNoBracesWindows.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F+-- XXX It is crucial that this file ends without a line terminator!+foo :: X -> Int+foo x = case x of
+ plugins/hls-case-split-plugin/test/testdata/TNoPatternsNoBracesWithComment.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of -- comment+  A -> _+  B -> _+  C _ -> _+  D _ _ -> _+  E -> _+  F -> _
+ plugins/hls-case-split-plugin/test/testdata/TNoPatternsNoBracesWithComment.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of -- comment
+ plugins/hls-case-split-plugin/test/testdata/TNoPatternsWithBraces.expected.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+        {+          A -> _;+          B -> _;+          C _ -> _;+          D _ _ -> _;+          E -> _;+          F -> _}
+ plugins/hls-case-split-plugin/test/testdata/TNoPatternsWithBraces.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+        {}
+ plugins/hls-case-split-plugin/test/testdata/TOrdinaryCtorsWithCompletePragma.expected.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F+{-# COMPLETE D, B, C #-}++foo :: X -> Int+foo x = case x of+  D _ _ -> _+  B -> _+  C _ -> _
+ plugins/hls-case-split-plugin/test/testdata/TOrdinaryCtorsWithCompletePragma.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F+{-# COMPLETE D, B, C #-}++foo :: X -> Int+foo x = case x of
+ plugins/hls-case-split-plugin/test/testdata/TOverlappingExistingPatterns.expected.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE OrPatterns #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+  (A; B) -> _+  B -> _+  C _ -> _+  D _ _ -> _+  E -> _+  F -> _
+ plugins/hls-case-split-plugin/test/testdata/TOverlappingExistingPatterns.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE OrPatterns #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+  (A; B) -> _+  B -> _
+ plugins/hls-case-split-plugin/test/testdata/TPatternSynAndSomeCtorsAreComplete.expected.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE PatternSynonyms #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++pattern Foo :: X+pattern Foo = E+{-# COMPLETE D, Foo, C #-}++foo :: X -> Int+foo x = case x of+  D _ _ -> _+  Foo -> _+  C _ -> _
+ plugins/hls-case-split-plugin/test/testdata/TPatternSynAndSomeCtorsAreComplete.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+{-# LANGUAGE PatternSynonyms #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++pattern Foo :: X+pattern Foo = E+{-# COMPLETE D, Foo, C #-}++foo :: X -> Int+foo x = case x of
+ plugins/hls-case-split-plugin/test/testdata/TPatternSynonyms.expected.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE EmptyCase #-}+module Pat where++data Bar = Bar | Baz++pattern Foo :: Bar+pattern Foo = Baz++x :: Bar -> p+x y = case y :: Bar of+  Bar -> _+  Baz -> _
+ plugins/hls-case-split-plugin/test/testdata/TPatternSynonyms.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE EmptyCase #-}+module Pat where++data Bar = Bar | Baz++pattern Foo :: Bar+pattern Foo = Baz++x :: Bar -> p+x y = case y :: Bar of
+ plugins/hls-case-split-plugin/test/testdata/TPatternSynonymsWithCompletePragma.expected.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE EmptyCase #-}+module Pat where++data Bar = Bar | Baz++pattern Foo :: Bar+pattern Foo = Baz+{-# COMPLETE Foo #-}++x :: Bar -> p+x y = case y :: Bar of+  Foo -> _
+ plugins/hls-case-split-plugin/test/testdata/TPatternSynonymsWithCompletePragma.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE EmptyCase #-}+module Pat where++data Bar = Bar | Baz++pattern Foo :: Bar+pattern Foo = Baz+{-# COMPLETE Foo #-}++x :: Bar -> p+x y = case y :: Bar of
+ plugins/hls-case-split-plugin/test/testdata/TRecordsFieldNamesIgnored.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C { foo :: Int }+       | D { bar :: Int, baz :: Int }+       | E+       | F++f :: X -> Int+f x = case x of+  A -> _+  B -> _+  C _ -> _+  D _ _ -> _+  E -> _+  F -> _
+ plugins/hls-case-split-plugin/test/testdata/TRecordsFieldNamesIgnored.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C { foo :: Int }+       | D { bar :: Int, baz :: Int }+       | E+       | F++f :: X -> Int+f x = case x of
+ plugins/hls-case-split-plugin/test/testdata/TSomePatternsNoBraces.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+          A -> 3+          B -> 4+          C _ -> _+          D _ _ -> _+          E -> _+          F -> _
+ plugins/hls-case-split-plugin/test/testdata/TSomePatternsNoBraces.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+          A -> 3+          B -> 4
+ plugins/hls-case-split-plugin/test/testdata/TSomePatternsNoBracesWithComment.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of -- comment 1+  A -> 1 -- comment 2+  B -> 2 -- comment 3+  C _ -> _+  D _ _ -> _+  E -> _+  F -> _
+ plugins/hls-case-split-plugin/test/testdata/TSomePatternsNoBracesWithComment.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of -- comment 1+  A -> 1 -- comment 2+  B -> 2 -- comment 3
+ plugins/hls-case-split-plugin/test/testdata/TSomePatternsOnOneLineNoBraces.expected.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F+       | G+       | H++foo :: X -> Int+foo x = case x of+        A -> 3+        B -> 4; C _ -> 5+        D _ _ -> _; E -> _+        F -> _; G -> _+        H -> _
+ plugins/hls-case-split-plugin/test/testdata/TSomePatternsOnOneLineNoBraces.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F+       | G+       | H++foo :: X -> Int+foo x = case x of+        A -> 3+        B -> 4; C _ -> 5
+ plugins/hls-case-split-plugin/test/testdata/TSomePatternsOnOneLineWithBraces.expected.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+      {    A -> 3   ; B -> 4;+           C _ -> _; D _ _ -> _;+           E -> _; F -> _ }
+ plugins/hls-case-split-plugin/test/testdata/TSomePatternsOnOneLineWithBraces.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+      {    A -> 3   ; B -> 4 }
+ plugins/hls-case-split-plugin/test/testdata/TSomePatternsWithBraces.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+      {       A -> 3;+              B -> _;+              C _ -> _;+              D _ _ -> _;+              E -> _;+              F -> _        }
+ plugins/hls-case-split-plugin/test/testdata/TSomePatternsWithBraces.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+      {       A -> 3        }
+ plugins/hls-case-split-plugin/test/testdata/TUnicodeArrow.expected.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of+  A → _+  B → _+  C _ → _+  D _ _ → _+  E → _+  F → _
+ plugins/hls-case-split-plugin/test/testdata/TUnicodeArrow.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F++foo :: X -> Int+foo x = case x of
+ plugins/hls-case-split-plugin/test/testdata/TWithCond.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F+       deriving Eq++foo :: X -> Int+foo x = case x of+  y | y == A -> 1
+ plugins/hls-case-split-plugin/test/testdata/TWithCondAndPat.expected.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F+       deriving Eq++foo :: X -> Int+foo x = case x of+  y | y == A -> 1+  B -> 2+  A -> _+  C _ -> _+  D _ _ -> _+  E -> _+  F -> _
+ plugins/hls-case-split-plugin/test/testdata/TWithCondAndPat.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE EmptyCase #-}+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}+module T where++data X = A+       | B+       | C Int+       | D Int Int+       | E+       | F+       deriving Eq++foo :: X -> Int+foo x = case x of+  y | y == A -> 1+  B -> 2
plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs view
@@ -92,11 +92,9 @@     nfp <- getNormalizedFilePathE uri     decls <- getDecls plId ideState nfp -    activeDiagnosticsInRange (shakeExtras ideState) nfp _range >>= \case-        Nothing -> pure (InL [])-        Just fileDiags -> do-            actions <- lift $ mapM (generateAction recorder plId uri decls) fileDiags-            pure (InL (catMaybes actions))+    fileDiags <- activeDiagnosticsInRange (shakeExtras ideState) nfp _range+    actions <- lift $ mapM (generateAction recorder plId uri decls) fileDiags+    pure $ InL $ catMaybes actions  getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m [LHsDecl GhcPs] getDecls (PluginId changeTypeSignatureId) state =
plugins/hls-class-plugin/src/Ide/Plugin/Class.hs view
@@ -10,7 +10,7 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId "Provides code actions and lenses for working with typeclasses")     { pluginCommands = commands plId-    , pluginRules = getInstanceBindTypeSigsRule recorder >> getInstanceBindLensRule recorder+    , pluginRules = getClassInstancesRule recorder >> getInstanceBindLensRule recorder     , pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeAction recorder)         <> mkPluginHandler SMethod_TextDocumentCodeLens codeLens         <> mkResolveHandler SMethod_CodeLensResolve codeLensResolve
plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs view
@@ -10,44 +10,36 @@     codeAction, ) where -import           Control.Arrow                        ((>>>))-import           Control.Lens                         hiding (List, use)-import           Control.Monad.Error.Class            (MonadError (throwError))+import           Control.Arrow                    ((>>>))+import           Control.Lens                     hiding (List, use) import           Control.Monad.Extra-import           Control.Monad.IO.Class               (liftIO)-import           Control.Monad.Trans.Class            (lift)-import           Control.Monad.Trans.Except           (ExceptT)+import           Control.Monad.IO.Class           (liftIO)+import           Control.Monad.Trans.Class        (lift)+import           Control.Monad.Trans.Except       (ExceptT) import           Control.Monad.Trans.Maybe-import           Data.Aeson                           hiding (Null)+import           Data.Aeson                       hiding (Null) import           Data.List-import           Data.List.Extra                      (nubOrdOn)-import qualified Data.Map.Strict                      as Map-import           Data.Maybe                           (isNothing, listToMaybe,-                                                       mapMaybe)-import qualified Data.Set                             as Set-import qualified Data.Text                            as T+import           Data.List.Extra                  (nubOrdOn)+import           Data.Maybe                       (listToMaybe, mapMaybe)+import qualified Data.Text                        as T import           Development.IDE-import           Development.IDE.Core.FileStore       (getVersionedTextDoc)+import           Development.IDE.Core.FileStore   (getVersionedTextDoc) import           Development.IDE.Core.PluginUtils-import           Development.IDE.Core.PositionMapping (fromCurrentRange) import           Development.IDE.GHC.Compat-import           Development.IDE.GHC.Compat.Error     (TcRnMessage (..),-                                                       _TcRnMessage,-                                                       msgEnvelopeErrorL,-                                                       stripTcRnMessageContext)+import           Development.IDE.GHC.Compat.Error (TcRnMessage (..),+                                                   _TcRnMessage,+                                                   msgEnvelopeErrorL,+                                                   stripTcRnMessageContext) import           Development.IDE.GHC.Compat.Util-import           Development.IDE.Spans.AtPoint        (pointCommand)-import           GHC.Iface.Ext.Types                  (ContextInfo (..),-                                                       HieAST (..), Identifier,-                                                       IdentifierDetails (..)) import           Ide.Plugin.Class.ExactPrint import           Ide.Plugin.Class.Types import           Ide.Plugin.Class.Utils import qualified Ide.Plugin.Config import           Ide.Plugin.Error+import qualified Ide.Plugin.RangeMap              as RangeMap import           Ide.PluginUtils import           Ide.Types-import qualified Language.LSP.Protocol.Lens           as L+import qualified Language.LSP.Protocol.Lens       as L import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types @@ -94,9 +86,7 @@     verTxtDocId <- liftIO $ runAction "classplugin.codeAction.getVersionedTextDoc" state $ getVersionedTextDoc docId     nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri)     activeDiagnosticsInRange (shakeExtras state) nfp caRange-        >>= \case-        Nothing -> pure $ InL []-        Just fileDiags -> do+        >>= \fileDiags -> do             actions <- join <$> mapM (mkActions nfp verTxtDocId) (methodDiags fileDiags)             pure $ InL actions     where@@ -109,31 +99,28 @@             -> (FileDiagnostic, ClassMinimalDef)             -> ExceptT PluginError (HandlerM Ide.Plugin.Config.Config) [Command |? CodeAction]         mkActions docPath verTxtDocId (diag, classMinDef) = do-            (HAR {hieAst = ast}, pmap) <- runActionE "classplugin.findClassIdentifier.GetHieAst" state-                $ useWithStaleE GetHieAst docPath-            instancePosition <- handleMaybe (PluginInvalidUserState "fromCurrentRange") $-                              fromCurrentRange pmap range ^? _Just . L.start-                              & fmap (L.character -~ 1)-            ident <- findClassIdentifier ast instancePosition-            cls <- findClassFromIdentifier docPath ident-            InstanceBindTypeSigsResult sigs <- runActionE "classplugin.codeAction.GetInstanceBindTypeSigs" state-                $ useE GetInstanceBindTypeSigs docPath-            (tmrTypechecked -> gblEnv ) <- runActionE "classplugin.codeAction.TypeCheck" state $ useE TypeCheck docPath+            ClassInstancesResult instMap <- runActionE "classplugin.codeAction.GetClassInstances" state+                $ useE GetClassInstances docPath+            inst <- handleMaybe (PluginInvalidUserState "no instance at diagnostic range")+                $ listToMaybe (RangeMap.filterByRange range instMap)+            (tmrTypechecked -> gblEnv) <- runActionE "classplugin.codeAction.TypeCheck" state $ useE TypeCheck docPath             (hscEnv -> hsc) <- runActionE "classplugin.codeAction.GhcSession" state $ useE GhcSession docPath-            logWith recorder Debug (LogImplementedMethods (hsc_dflags hsc) cls classMinDef)+            logWith recorder Debug (LogImplementedMethods (hsc_dflags hsc) (instClass inst) classMinDef)             pure                 $ concatMap mkAction                 $ nubOrdOn snd                 $ filter ((/=) mempty . snd)-                $ mkMethodGroups hsc gblEnv range sigs classMinDef+                $ mkMethodGroups hsc gblEnv inst classMinDef             where                 range = diag ^. fdLspDiagnosticL . L.range -                mkMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> ClassMinimalDef -> [MethodGroup]-                mkMethodGroups hsc gblEnv range sigs classMinDef = minimalDef <> [allClassMethods]+                mkMethodGroups :: HscEnv -> TcGblEnv -> InstanceInfo -> ClassMinimalDef -> [MethodGroup]+                mkMethodGroups hsc gblEnv inst classMinDef = minimalDef <> [allClassMethods]                     where-                        minimalDef = minDefToMethodGroups hsc gblEnv range sigs classMinDef-                        allClassMethods = ("all missing methods", makeMethodDefinitions hsc gblEnv range sigs)+                        methods    = instMethods inst+                        minimalDef = minDefToMethodGroups hsc gblEnv methods classMinDef+                        allClassMethods =+                            ("all missing methods", map (makeMethodDefinition hsc gblEnv) methods)                  mkAction :: MethodGroup -> [Command |? CodeAction]                 mkAction (name, methods)@@ -164,36 +151,6 @@                         (Just cmd)                         Nothing -        findClassIdentifier hf instancePosition =-            handleMaybe (PluginInternalError "No Identifier found")-                $ listToMaybe-                $ mapMaybe listToMaybe-                $ pointCommand hf instancePosition-                    ( (Map.keys . Map.filterWithKey isClassNodeIdentifier . getNodeIds)-                        <=< nodeChildren-                    )--        findClassFromIdentifier docPath (Right name) = do-            (hscEnv -> hscenv, _) <- runActionE "classplugin.findClassFromIdentifier.GhcSessionDeps" state-                $ useWithStaleE GhcSessionDeps docPath-            (tmrTypechecked -> thisMod, _) <- runActionE "classplugin.findClassFromIdentifier.TypeCheck" state-                $ useWithStaleE TypeCheck docPath-            handleMaybeM (PluginInternalError "initTcWithGbl failed")-                . liftIO-                . fmap snd-                . initTcWithGbl hscenv thisMod ghostSpan $ do-                    tcthing <- tcLookup name-                    case tcthing of-                        AGlobal (AConLike (RealDataCon con))-                            | Just cls <- tyConClass_maybe (dataConOrigTyCon con) -> pure cls-                        _ -> fail "Ide.Plugin.Class.findClassFromIdentifier"-        findClassFromIdentifier _ (Left _) = throwError (PluginInternalError "Ide.Plugin.Class.findClassIdentifier")---- see https://hackage.haskell.org/package/ghc-9.8.1/docs/src/GHC.Types.Name.Occurrence.html#mkClassDataConOcc-isClassNodeIdentifier :: Identifier -> IdentifierDetails a -> Bool-isClassNodeIdentifier (Right i) ident  | 'C':':':_ <- unpackFS $ occNameFS $ occName i = (isNothing . identType) ident && Use `Set.member` identInfo ident-isClassNodeIdentifier _ _ = False- isClassMethodWarning :: StructuredMessage -> Maybe ClassMinimalDef isClassMethodWarning message = case message ^? _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage of     Nothing          -> Nothing@@ -209,36 +166,29 @@ type MethodDefinition = (MethodName, MethodSignature) type MethodGroup = (T.Text, [MethodDefinition]) -makeMethodDefinition :: HscEnv -> TcGblEnv -> InstanceBindTypeSig -> MethodDefinition-makeMethodDefinition hsc gblEnv sig = (name, signature)+makeMethodDefinition :: HscEnv -> TcGblEnv -> (Name, Type) -> MethodDefinition+makeMethodDefinition hsc gblEnv (name, ty) = (nameTxt, signature)     where-        name = T.drop (T.length bindingPrefix) (printOutputable  (bindName sig))-        signature = prettyBindingNameString (printOutputable (bindName sig)) <> " :: " <> T.pack (showDoc hsc gblEnv (bindType sig))--makeMethodDefinitions :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> [MethodDefinition]-makeMethodDefinitions hsc gblEnv range sigs =-    [ makeMethodDefinition hsc gblEnv sig-    | sig <- sigs-    , inRange range (getSrcSpan $ bindName sig)-    ]--signatureToName :: InstanceBindTypeSig -> T.Text-signatureToName sig = T.drop (T.length bindingPrefix) (printOutputable (bindName sig))+        -- nameTxt is bare (no parens); ExactPrint.makeMethodDecl applies+        -- toMethodName to wrap operators when emitting the placeholder.+        nameTxt   = printOutputable name+        signature = toMethodName nameTxt <> " :: " <> T.pack (showDoc hsc gblEnv ty) --- Return [groupName text, [(methodName text, signature text)]]-minDefToMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> ClassMinimalDef -> [MethodGroup]-minDefToMethodGroups hsc gblEnv range sigs minDef = makeMethodGroup <$> go minDef+minDefToMethodGroups :: HscEnv -> TcGblEnv -> [(Name, Type)] -> ClassMinimalDef -> [MethodGroup]+minDefToMethodGroups hsc gblEnv methods minDef = makeMethodGroup <$> go minDef     where         makeMethodGroup methodDefinitions =             let name = mconcat $ intersperse "," $ (\x -> "'" <> x <> "'") . fst <$> methodDefinitions             in  (name, methodDefinitions) +        matchMethod n =+            map (makeMethodDefinition hsc gblEnv)+                $ filter ((== n) . fst) methods #if __GLASGOW_HASKELL__ >= 913-        go (Var lmn)  = pure $ makeMethodDefinitions hsc gblEnv range $ filter ((==) (printOutputable (unLoc lmn)) . signatureToName) sigs+        go (Var lmn)  = pure $ matchMethod (unLoc lmn) #else-        go (Var mn)   = pure $ makeMethodDefinitions hsc gblEnv range $ filter ((==) (printOutputable mn) . signatureToName) sigs+        go (Var mn)   = pure $ matchMethod mn #endif         go (Or ms)    = concatMap (go . unLoc) ms         go (And ms)   = foldr (liftA2 (<>) . go . unLoc) [[]] ms         go (Parens m) = go (unLoc m)-
plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs view
@@ -50,7 +50,7 @@     (hscEnv -> hsc, _) <- runActionE "classplugin.codeAction.GhcSession" state $ useWithStaleE GhcSession nfp     (range, name, typ) <- handleMaybe PluginStaleResolve                     $ IntMap.lookup uniqueID lensDetails-    let title = prettyBindingNameString (printOutputable name) <> " :: " <> T.pack (showDoc hsc gblEnv typ)+    let title = toMethodName (printOutputable name) <> " :: " <> T.pack (showDoc hsc gblEnv typ)     edit <- handleMaybe (PluginInvalidUserState "toCurrentRange") $ makeEdit range title pm     let command = mkLspCommand plId typeLensCommandId title (Just [toJSON $ InstanceBindLensCommand uri edit])     pure $ cl & L.command ?~ command
plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs view
@@ -8,6 +8,9 @@ import           Data.Either.Extra                       (eitherToMaybe) import qualified Data.Text                               as T import           Development.IDE.GHC.Compat+#if !MIN_VERSION_ghc(9,11,0)+import           GHC.Data.Bag                            (bagToList)+#endif import           GHC.Parser.Annotation import           Ide.Plugin.Class.Types import           Ide.Plugin.Class.Utils@@ -48,7 +51,7 @@     pure (name, sig')  #if MIN_VERSION_ghc_exactprint(1,10,0)-addMethodDecls :: ParsedSource -> [(LHsDecl GhcPs, LHsDecl GhcPs)] -> Range -> Bool -> Located (HsModule GhcPs)+addMethodDecls :: ParsedSource -> [(LHsDecl GhcPs, LHsDecl GhcPs)] -> Range -> Bool -> ParsedSource #else addMethodDecls :: ParsedSource -> [(LHsDecl GhcPs, LHsDecl GhcPs)] -> Range -> Bool -> TransformT Identity (Located (HsModule GhcPs)) #endif@@ -63,18 +66,39 @@         allDecls <- hsDecls ps #endif         case break (inRange range . getLoc) allDecls of+#if MIN_VERSION_ghc(9,10,0)+            -- With new enough GHC, `hsDecls` followed by+            -- `replaceDecls` is idempotent, see+            -- https://github.com/alanz/ghc-exactprint/blob/e2224c5e3d335e5a2c50a44749367337e278a8c0/src/Language/Haskell/GHC/ExactPrint/Transform.hs#L817+            (_, []) -> ps+#else+            (before, []) -> replaceDecls ps before+#endif             (before, L l inst : after) ->                 let+                    indent = case inst of+                                InstD _ (ClsInstD{..}) | fstBind:_ <-+#if !MIN_VERSION_ghc(9,11,0)+                                                                      bagToList $+#endif+                                                                      cid_binds cid_inst,+                                                         (RealSrcSpan indent _) <- getLoc fstBind+                                  -> srcSpanStartCol indent+                                _ -> defaultIndent + 1+#if MIN_VERSION_ghc(9,11,0) || !MIN_VERSION_ghc(9,9,0)+                           - 1+#endif+#if MIN_VERSION_ghc(9,9,0)                     instSpan = realSrcSpan $ getLoc l-#if MIN_VERSION_ghc(9,11,0)-                    instCol = srcSpanStartCol instSpan - 1-#else                     instCol = srcSpanStartCol instSpan+#if MIN_VERSION_ghc(9,11,0)+                            - 1 #endif-#if MIN_VERSION_ghc(9,9,0)                     instRow = srcSpanEndLine instSpan-                    methodEpAnn = noAnnSrcSpanDP $ deltaPos 1 (instCol + defaultIndent)-                    -- Put each TyCl method/type signature on separate line, indented by 2 spaces relative to instance decl+                    methodEpAnn = noAnnSrcSpanDP $ deltaPos 1 indent+                    -- Put each TyCl method/type signature on separate line,+                    -- indented relative to instance decl as much as existing+                    -- methods, or by 2 spaces otherwise                     newLine (L _ e) = L methodEpAnn e                      -- Set DeltaPos for following declarations so they don't move undesirably@@ -85,14 +109,12 @@                             in setEntryDP followingDecl delta) #else                     newLine (L l e) =-                        let dp = deltaPos 1 (instCol + defaultIndent - 1)+                        let dp = deltaPos 1 indent                         in L (noAnnSrcSpanDP (getLoc l) dp <> l) e                      resetFollowing = id #endif                 in replaceDecls ps (before ++ L l (addWhere inst):(map newLine inserting ++ resetFollowing after))-            (before, []) ->-                replaceDecls ps before      -- Add `where` keyword for `instance X where` if `where` is missing.     --@@ -107,10 +129,10 @@     addWhere instd@(InstD xInstD (ClsInstD ext decl@ClsInstDecl{..})) =         case cid_ext of #if MIN_VERSION_ghc(9,11,0)-            (warnings, anns, key)-                | EpTok _ <- acid_where anns -> instd-                | otherwise ->-                    InstD xInstD (ClsInstD ext decl {+            (warnings, anns, key) -> case acid_where anns of+               EpTok _ -> instd+               NoEpTok ->+                  InstD xInstD (ClsInstD ext decl {                     cid_ext = ( warnings                               , anns { acid_where = EpTok d1 }                               , key
plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs view
@@ -8,14 +8,13 @@ module Ide.Plugin.Class.Types where  import           Control.DeepSeq                  (rwhnf)-import           Control.Monad.Extra              (mapMaybeM, whenMaybe)+import           Control.Monad.Extra              (mapMaybeM) import           Control.Monad.IO.Class           (liftIO)-import           Control.Monad.Trans.Maybe        (MaybeT (MaybeT, runMaybeT))+import           Control.Monad.Trans.Maybe        (runMaybeT) import           Data.Aeson import qualified Data.IntMap                      as IntMap-import           Data.List.Extra                  (firstJust)-import           Data.Maybe                       (catMaybes, mapMaybe,-                                                   maybeToList)+import           Data.Maybe                       (fromMaybe, listToMaybe,+                                                   mapMaybe, maybeToList) import qualified Data.Text                        as T import           Data.Unique                      (hashUnique, newUnique) import           Development.IDE@@ -26,6 +25,7 @@ import           Development.IDE.Graph.Classes import           GHC.Generics import           Ide.Plugin.Class.Utils+import qualified Ide.Plugin.RangeMap              as RangeMap import           Ide.Types import           Language.LSP.Protocol.Types      (TextEdit,                                                    VersionedTextDocumentIdentifier)@@ -49,27 +49,33 @@     }     deriving (Show, Eq, Generic, ToJSON, FromJSON) --- |The InstanceBindTypeSigs Rule collects the instance bindings type--- signatures (both name and type). It is used by both the code actions and the--- code lenses-data GetInstanceBindTypeSigs = GetInstanceBindTypeSigs+-- | Indexes the instances declared in a module by their source span, giving+-- each instance's class and the full instantiated type of every class method.+-- Both the placeholder code action (to enumerate missing methods) and the+-- code lens (to display inferred signatures) consume this rule.+data GetClassInstances = GetClassInstances     deriving (Generic, Show, Eq, Ord, Hashable, NFData) -data InstanceBindTypeSig = InstanceBindTypeSig-    { bindName :: Name-    , bindType :: Type+data InstanceInfo = InstanceInfo+    { instSpan    :: SrcSpan+      -- ^ Source span of the instance declaration.+    , instClass   :: Class+    , instMethods :: [(Name, Type)]+      -- ^ Each class method paired with its type instantiated for this+      -- instance, including any instance context (e.g. @Eq a@ for+      -- @instance Eq a => C [a]@).     } -newtype InstanceBindTypeSigsResult =-    InstanceBindTypeSigsResult [InstanceBindTypeSig]+newtype ClassInstancesResult =+    ClassInstancesResult (RangeMap.RangeMap InstanceInfo) -instance Show InstanceBindTypeSigsResult where-    show _ = "<InstanceBindTypeSigs>"+instance Show ClassInstancesResult where+    show _ = "<ClassInstances>" -instance NFData InstanceBindTypeSigsResult where+instance NFData ClassInstancesResult where     rnf = rwhnf -type instance RuleResult GetInstanceBindTypeSigs = InstanceBindTypeSigsResult+type instance RuleResult GetClassInstances = ClassInstancesResult  -- |The necessary data to execute our code lens data InstanceBindLensCommand = InstanceBindLensCommand@@ -80,11 +86,10 @@     , commandEdit :: TextEdit }     deriving (Generic, FromJSON, ToJSON) --- | The InstanceBindLens rule is specifically for code lenses. It  relies on--- the InstanceBindTypeSigs rule, filters out irrelevant matches and signatures--- that can't be matched to a source span. It provides all the signatures linked--- to a unique ID to aid in resolving. It also provides a list of enabled--- extensions.+-- | The InstanceBindLens rule is specifically for code lenses. It correlates+-- user-written instance method bindings (those without an explicit signature)+-- to the instance's 'InstanceInfo', and emits range/name/type triples with+-- unique IDs for resolve. data GetInstanceBindLens = GetInstanceBindLens     deriving (Generic, Show, Eq, Ord, Hashable, NFData) @@ -123,11 +128,14 @@         <+> pretty (showSDoc dflags $ ppr methods)     LogShake log -> pretty log +-- | A user-written instance binding without an explicit signature. The 'Name'+-- is the renamer-level method name (e.g. @(==)@), used to look up the+-- instance-level type in 'instMethods'. data BindInfo = BindInfo-    { bindSpan     :: SrcSpan+    { bindSpan    :: SrcSpan       -- ^ SrcSpan of the whole binding-    , bindNameSpan :: SrcSpan-      -- ^ SrcSpan of the binding name+    , bindFunName :: Name+      -- ^ The renamed method name of the binding.     }  getInstanceBindLensRule :: Recorder (WithPriority Log) -> Rules ()@@ -138,35 +146,34 @@ #else         tmr@(tmrRenamed ->  (hs_tyclds -> tycls, _, _, _)) <- useMT TypeCheck nfp #endif-        (InstanceBindTypeSigsResult allBinds) <- useMT GetInstanceBindTypeSigs nfp+        ClassInstancesResult instMap <- useMT GetClassInstances nfp -        let -- declared instance methods without signatures-            bindInfos = [ bind-                        | instds <- map group_instds tycls -- class instance decls-                        , instd <- instds-                        , inst <- maybeToList $ getClsInstD (unLoc instd)-                        , bind <- getBindSpanWithoutSig inst-                        ]-            targetSigs = matchBind bindInfos allBinds-        rangeIntNameType <- liftIO $ mapMaybeM getRangeWithSig targetSigs+        let -- Correlate renamed ClsInstDecls with their InstanceInfo by source+            -- span (the only link between the renamed tree and tcg_insts), then+            -- collect user-written bindings that lack an explicit signature.+            entries =+                [ (bind, ty)+                | instds <- map group_instds tycls+                , instd <- instds+                , inst <- maybeToList $ getClsInstD (unLoc instd)+                , info <- maybeToList $ do+                    instdRange <- srcSpanToRange (getLocA instd)+                    listToMaybe (RangeMap.elementsInRange instdRange instMap)+                , bind <- getBindSpanWithoutSig inst+                , ty <- maybeToList (lookup (bindFunName bind) (instMethods info))+                ]+        rangeIntNameType <- liftIO $ mapMaybeM tagEntry entries         let lensRange = (\(range, int, _, _) -> (range, int)) <$> rangeIntNameType-            lensDetails = IntMap.fromList $ (\(range, int, name, typ) -> (int, (range, name, typ))) <$> rangeIntNameType+            lensDetails = IntMap.fromList $+                (\(range, int, name, typ) -> (int, (range, name, typ))) <$> rangeIntNameType             lensEnabledExtensions = getExtensions $ tmrParsed tmr         pure $ InstanceBindLensResult $ InstanceBindLens{..}     where-        -- Match Binds with their signatures-        -- We try to give every `InstanceBindTypeSig` a `SrcSpan`,-        -- hence we can display signatures for `InstanceBindTypeSig` with span later.-        matchBind :: [BindInfo] -> [InstanceBindTypeSig] -> [Maybe (InstanceBindTypeSig, SrcSpan)]-        matchBind existedBinds allBindWithSigs =-            [firstJust (go bindSig) existedBinds | bindSig <- allBindWithSigs]-            where-                go :: InstanceBindTypeSig -> BindInfo -> Maybe (InstanceBindTypeSig,  SrcSpan)-                go bindSig bind = do-                    range <- (srcSpanToRange . bindNameSpan) bind-                    if inRange range (getSrcSpan $ bindName bindSig)-                    then Just (bindSig, bindSpan bind)-                    else Nothing+        tagEntry (bind, ty) = case srcSpanToRange (bindSpan bind) of+            Nothing -> pure Nothing+            Just r  -> do+                uniqueID <- hashUnique <$> newUnique+                pure $ Just (r, uniqueID, bindFunName bind, ty)          getClsInstD (ClsInstD _ d) = Just d         getClsInstD _              = Nothing@@ -183,52 +190,54 @@                                 cid_binds                 go (L l bind) = case bind of                     FunBind{..}-                        -- `Generated` tagged for Template Haskell,-                        -- here we filter out nonsense generated bindings-                        -- that are nonsense for displaying code lenses.-                        ---                        -- See https://github.com/haskell/haskell-language-server/issues/3319-                        | not $ isGenerated (groupOrigin fun_matches)-                            -> Just $ L l fun_id-                    _       -> Nothing+                      -- `Generated` tagged for Template Haskell,+                      -- here we filter out nonsense generated bindings+                      -- that are nonsense for displaying code lenses.+                      --+                      -- See https://github.com/haskell/haskell-language-server/issues/3319+                      | not $ isGenerated (groupOrigin fun_matches)+                      -> Just $ L l fun_id+                    _ -> Nothing                 -- Existed signatures' name-                sigNames = concat $ mapMaybe (\(L _ r) -> getSigName r) cid_sigs-                toBindInfo (L l (L l' _)) = BindInfo-                    (locA l) -- bindSpan-                    (locA l') -- bindNameSpan-            in toBindInfo <$> filter (\(L _ name) -> unLoc name `notElem` sigNames) bindNames--        -- Get bind definition range with its rendered signature text-        getRangeWithSig :: Maybe (InstanceBindTypeSig, SrcSpan) -> IO (Maybe (Range, Int, Name, Type))-        getRangeWithSig (Just (bind, span)) = runMaybeT $ do-            range <- MaybeT . pure $ srcSpanToRange span-            uniqueID <- liftIO $ hashUnique <$> newUnique-            pure (range, uniqueID, bindName bind, bindType bind)-        getRangeWithSig Nothing = pure Nothing-+                existingSigNames = concat $ mapMaybe (\(L _ r) -> getSigName r) cid_sigs+                toBindInfo (L l (L _ n)) = BindInfo (locA l) n+            in toBindInfo <$> filter (\(L _ name) -> unLoc name `notElem` existingSigNames) bindNames -getInstanceBindTypeSigsRule :: Recorder (WithPriority Log) -> Rules ()-getInstanceBindTypeSigsRule recorder = do-    defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetInstanceBindTypeSigs nfp -> runMaybeT $ do-        (tmrTypechecked -> gblEnv ) <- useMT TypeCheck nfp+getClassInstancesRule :: Recorder (WithPriority Log) -> Rules ()+getClassInstancesRule recorder = do+    defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetClassInstances nfp -> runMaybeT $ do+        (tmrTypechecked -> gblEnv) <- useMT TypeCheck nfp         (hscEnv -> hsc) <- useMT GhcSession nfp-        let binds = collectHsBindsBinders $ tcg_binds gblEnv-        (_, maybe [] catMaybes -> instanceBinds) <- liftIO $+        (_, mInfos) <- liftIO $             initTcWithGbl hsc gblEnv ghostSpan #if MIN_VERSION_ghc(9,7,0)               $ liftZonkM #endif-              $ traverse bindToSig binds-        pure $ InstanceBindTypeSigsResult instanceBinds+              $ mkInfos gblEnv+        pure $ ClassInstancesResult $ RangeMap.fromList'+            $ mapMaybe (\i -> (,i) <$> srcSpanToRange (instSpan i)) (fromMaybe [] mInfos)     where-        bindToSig id = do-            let name = idName id-            whenMaybe (isBindingName name) $ do-                env <- tcInitTidyEnv+        mkInfos gblEnv = do+            env <- tcInitTidyEnv+            pure $ map (mkInfo env) (tcg_insts gblEnv)++        mkInfo env inst = do+            -- forall tvs. theta => cls tys+            let (_tvs, theta, cls, tys) = instanceSig inst+                -- Canonicalise internal GHC type-variable names (e.g. a_1 -> a).+                tidy ty = #if MIN_VERSION_ghc(9,11,0)-                let ty =+                    tidyOpenType env ty #else-                let (_, ty) =+                    snd (tidyOpenType env ty) #endif-                              tidyOpenType env (idType id)-                pure $ InstanceBindTypeSig name ty+                -- `instantiateMethod` substitutes the instance head types into+                -- the method's type and drops the leading class predicate, but+                -- not the instance's own constraints (`theta`). Re-prepend them+                -- so we get every method's full instantiated type.+                mkMeth m = (idName m, tidy (mkInvisFunTys theta (instantiateMethod cls m tys)))+            InstanceInfo+              { instSpan    = getSrcSpan (is_dfun inst)+              , instClass   = cls+              , instMethods = map mkMeth (classMethods cls)+              }
plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs view
@@ -5,39 +5,23 @@ import           Control.Monad.IO.Class           (MonadIO, liftIO) import           Control.Monad.Trans.Except import           Data.Char                        (isAlpha)-import           Data.List                        (isPrefixOf)-import           Data.String                      (IsString) import qualified Data.Text                        as T import           Development.IDE import           Development.IDE.Core.PluginUtils import           Development.IDE.GHC.Compat-import           Development.IDE.GHC.Compat.Util+import           Development.IDE.GHC.Compat.Util  (fsLit) import           Development.IDE.Spans.Pragmas    (getNextPragmaInfo,                                                    insertNewPragma) import           Ide.Plugin.Error import           Ide.PluginUtils import           Language.LSP.Protocol.Types --- | All instance bindings are started with `$c`-bindingPrefix :: IsString s => s-bindingPrefix = "$c"--isBindingName :: Name -> Bool-isBindingName name = isPrefixOf bindingPrefix $ occNameString $ nameOccName name---- | Check if some `HasSrcSpan` value in the given range+-- | Check if some `HasSrcSpan` value is in the given range inRange :: Range -> SrcSpan -> Bool inRange range s = maybe False (subRange range) (srcSpanToRange s)  ghostSpan :: RealSrcSpan ghostSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "<haskell-language-sever>") 1 1---- | "$cname" ==> "name"-prettyBindingNameString :: T.Text -> T.Text-prettyBindingNameString name-    | T.isPrefixOf bindingPrefix name =-        toMethodName $ T.drop (T.length bindingPrefix) name-    | otherwise = name  showDoc :: HscEnv -> TcGblEnv -> Type -> String showDoc hsc gblEnv ty = showSDocForUser' hsc (mkPrintUnqualifiedDefault hsc (rdrEnv gblEnv)) (pprSigmaType ty)
plugins/hls-class-plugin/test/Main.hs view
@@ -66,12 +66,16 @@       getActionByTitle "Add placeholders for 'g','h'"   , goldenWithClass "Creates a placeholder when all top-level decls are indented" "T7" "" $       getActionByTitle "Add placeholders for 'g','h','i'"+  , goldenWithClass "Creates a placeholder when non-missing methods have non-default indentation" "T10" "" $+      getActionByTitle "Add placeholders for 'g'"   , testGroup "with preprocessors"     [ knownBrokenInEnv [GhcVer GHC910]         "See issue https://github.com/haskell/haskell-language-server/issues/4731 for details." $         goldenWithClass "Creates a placeholder for '<>'" "T8" "diamond" $       getActionByTitle "Add placeholders for '<>'"       ]+  , goldenWithClass "Creates a placeholder for type classes with super classes" "T9" "" $+      getActionByTitle "Add placeholders for all missing methods"   , goldenWithClass "Don't insert pragma with GHC2021" "InsertWithGHC2021Enabled" "" $       getActionByTitle "Add placeholders for '==' with signature(s)"   , goldenWithClass "Insert pragma if not exist" "InsertWithoutPragma" "" $@@ -165,7 +169,7 @@         executeCommand $ fromJust $ (List.sort lens !! idx) ^. L.command         void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) -goldenWithClass ::TestName -> FilePath -> FilePath -> ([CodeAction] -> Session CodeAction) -> TestTree+goldenWithClass :: TestName -> FilePath -> FilePath -> ([CodeAction] -> Session CodeAction) -> TestTree goldenWithClass title path desc findAction =   goldenWithHaskellDoc def classPlugin title testDataDir path (desc <.> "expected") "hs" $ \doc -> do     _ <- waitForDiagnosticsFrom doc
+ plugins/hls-class-plugin/test/testdata/T10.expected.hs view
@@ -0,0 +1,16 @@+module T7 where++    data X = X++    class Test a where+      f :: a -> a+      g :: a++    instance Test X where+       f X = X+       g = _+++++    whiteSpaceBeforeAndIndentationOfThisShouldBePreserved = ()
+ plugins/hls-class-plugin/test/testdata/T10.hs view
@@ -0,0 +1,15 @@+module T7 where++    data X = X++    class Test a where+      f :: a -> a+      g :: a++    instance Test X where+       f X = X+++++    whiteSpaceBeforeAndIndentationOfThisShouldBePreserved = ()
+ plugins/hls-class-plugin/test/testdata/T9.expected.hs view
@@ -0,0 +1,17 @@+module T9 where++class A a where+  a :: a++instance A Int where+  a = 1++class (A a) => B a where+  {-# MINIMAL b1 #-}+  b1 :: a+  b2 :: a+  b2 = b1++instance B Int where+  b1 = _+  b2 = _
+ plugins/hls-class-plugin/test/testdata/T9.hs view
@@ -0,0 +1,15 @@+module T9 where++class A a where+  a :: a++instance A Int where+  a = 1++class (A a) => B a where+  {-# MINIMAL b1 #-}+  b1 :: a+  b2 :: a+  b2 = b1++instance B Int where
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs view
@@ -1,108 +1,245 @@-{-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns      #-} {-# OPTIONS_GHC -Wwarn #-}  -- | Expression execution-module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, propSetup, testCheck, asStatements,myExecStmt) where+module Ide.Plugin.Eval.Code (+    Statement+  , evalExprRanges+  , resultRange+  , propSetup+  , evalExprCheck+  , asStatements+  , execStmtCaptureResult+  ) where  import           Control.Lens                ((^.))+import           Control.Monad.Catch         (MonadMask, bracket) import           Control.Monad.IO.Class import           Data.Algorithm.Diff         (Diff, PolyDiff (..), getDiff)+import           Data.List                   (dropWhileEnd) import qualified Data.List.NonEmpty          as NE+import           Data.Maybe                  (listToMaybe) import           Data.String                 (IsString) import qualified Data.Text                   as T import           Development.IDE.GHC.Compat import           GHC                         (ExecOptions, ExecResult (..),                                               execStmt)-import           Ide.Plugin.Eval.Types       (Language (Plain), Loc,-                                              Located (..),-                                              Section (sectionLanguage),-                                              Test (..), Txt, locate, locate0)+import           Ide.Logger                  (Recorder, WithPriority, logWith)+import qualified Ide.Logger                  as Log++import           Ide.Plugin.Eval.Types       (EvalExpr (..), Language (Plain),+                                              Loc, Located (..), Log (..),+                                              Section (sectionLanguage), Txt,+                                              locate, locate0)+import           Ide.Plugin.Eval.Util        (gStrictTry) import qualified Language.LSP.Protocol.Lens  as L import           Language.LSP.Protocol.Types (Position (Position),                                               Range (Range)) import           System.IO.Extra             (newTempFile, readFile') --- | Return the ranges of the expression and result parts of the given test-testRanges :: Test -> (Range, Range)-testRanges tst =-    let startLine = testRange tst ^. L.start . L.line-        (fromIntegral -> exprLines, fromIntegral -> resultLines) = testLengths tst+-- | Return the ranges of the expression and result parts of the given 'EvalExpr'.+evalExprRanges :: EvalExpr -> (Range, Range)+evalExprRanges tst =+    let startLine = evalExprRange tst ^. L.start . L.line+        (fromIntegral -> exprLines, fromIntegral -> resultLines) = evalExprLengths tst         resLine = startLine + exprLines      in ( Range             (Position startLine 0)-            --(Position (startLine + exprLines + resultLines) 0),             (Position resLine 0)         , Range (Position resLine 0) (Position (resLine + resultLines) 0)         ) -{- |The document range where a test is defined- testRange :: Loc Test -> Range- testRange = fst . testRanges--}---- |The document range where the result of the test is defined-resultRange :: Test -> Range-resultRange = snd . testRanges+-- | The document range where the result of the 'EvalExpr' is defined.+resultRange :: EvalExpr -> Range+resultRange = snd . evalExprRanges --- TODO: handle BLANKLINE-{-->>> showDiffs $  getDiff ["abc","def","ghi","end"] ["abc","def","Z","ZZ","end"]+{- |+>>> showDiffs $ getDiff ["abc" :: String,"def","ghi","end"] ["abc","def","Z","ZZ","end"] ["abc","def","WAS ghi","NOW Z","NOW ZZ","end"] -} showDiffs :: (Semigroup a, IsString a) => [Diff a] -> [a] showDiffs = map showDiff  showDiff :: (Semigroup a, IsString a) => Diff a -> a-showDiff (First w)  = "WAS " <> w+showDiff (First  w) = "WAS " <> w showDiff (Second w) = "NOW " <> w showDiff (Both w _) = w -testCheck :: Bool -> (Section, Test) -> [T.Text] -> [T.Text]-testCheck diff (section, test) out-    | not diff || null (testOutput test) || sectionLanguage section == Plain = out-    | otherwise = showDiffs $ getDiff (map T.pack $ testOutput test) out+-- | Compare the expected output recorded in the 'EvalExpr' with the actual+-- output @out@, returning the result as one 'T.Text' per line. When diffing is+-- enabled and there is a recorded output, return a line-by-line diff (see+-- 'showDiffs'); otherwise return @out@ unchanged.+--+-- @out@ is normalised to one element per line first: a multi-line result+-- arrives here as a single element with embedded newlines, whereas the recorded+-- output is already split per line, and 'getDiff' compares element-wise. Without+-- this, identical multi-line results would be reported as entirely changed.+evalExprCheck :: Bool -> (Section, EvalExpr) -> [T.Text] -> [T.Text]+evalExprCheck diff (section, evalExpr) out+    |  not diff+    || null (evalExprOutput evalExpr)+    || sectionLanguage section == Plain =+        outLines+    | otherwise =+        showDiffs $+          getDiff (map T.pack $ evalExprOutput evalExpr) outLines+  where+    outLines = concatMap T.lines out -testLengths :: Test -> (Int, Int)-testLengths (Example e r _)  = (NE.length e, length r)-testLengths (Property _ r _) = (1, length r)+-- | The number of (expression lines, result lines) an 'EvalExpr' occupies.+evalExprLengths :: EvalExpr -> (Int, Int)+evalExprLengths (Example e r _)  = (NE.length e, length r)+evalExprLengths (Property _ r _) = (1, length r) --- |A one-line Haskell statement+-- | A one-line Haskell statement type Statement = Loc String -asStatements :: Test -> [Statement]-asStatements lt = locate $ Located (fromIntegral $ testRange lt ^. L.start . L.line) (asStmts lt)+-- | The Haskell statements to feed to GHCi for an 'EvalExpr', each tagged with+-- its source line so evaluation errors can be located.+asStatements :: EvalExpr -> [Statement]+asStatements lt =+  locate $ Located (fromIntegral $ evalExprRange lt ^. L.start . L.line) (asStmts lt) -asStmts :: Test -> [Txt]+-- | The raw statement lines of an 'EvalExpr'. A 'Property' is wrapped so its+-- result is evaluated through 'propEvaluation' (see 'propSetup').+asStmts :: EvalExpr -> [Txt] asStmts (Example e _ _) = NE.toList e asStmts (Property t _ _) =     ["prop11 = " ++ t, "(propEvaluation prop11 :: IO String)"] +-- | A wrapper of 'InteractiveEval.execStmt', capturing the execution result+execStmtCaptureResult ::+     Recorder (WithPriority Log)+  -> String+  -> ExecOptions+  -> Ghc (Either String (Maybe String))+execStmtCaptureResult recorder stmt opts = do+    (result, (output, execResultE)) <-+      withCaptureResult recorder $+        withCaptureStdHandles opts $+           gStrictTry (execStmt stmt opts)+    case execResultE of+      Left exc ->+        pure $ Left exc+      Right (ExecComplete (Left err) _) ->+        pure $ Left $ show err+      Right (ExecComplete (Right _) _) -> do+        pure $ Right $ toMaybe (combine output result)+      Right ExecBreak{} ->+        pure $ Right $ Just "breakpoints are not supported"+  where+    toMaybe :: String -> Maybe String+    toMaybe x | null x    = Nothing+              | otherwise = Just x +    -- Join the captured stdout/stderr output with the result value. GHC+    -- diagnostics (e.g. warnings) written to stderr end with a trailing blank+    -- line; drop trailing newlines so output and result are separated by a+    -- single newline rather than a spurious blank line (which would otherwise+    -- surface unexpectedly in the rendered result).+    combine :: String -> String -> String+    combine output result+        | null trimmed = result+        | null result = trimmed+        | otherwise    = trimmed <> "\n" <> result+      where+        trimmed = dropWhileEnd (== '\n') output --- | A wrapper of 'InteractiveEval.execStmt', capturing the execution result-myExecStmt :: String -> ExecOptions -> Ghc (Either String (Maybe String))-myExecStmt stmt opts = do-    (temp, purge) <- liftIO newTempFile-    evalPrint <- head <$> runDecls ("evalPrint x = P.writeFile " <> show temp <> " (P.show x)")-    modifySession $ \hsc -> hsc {hsc_IC = setInteractivePrintName (hsc_IC hsc) evalPrint}-    result <- execStmt stmt opts >>= \case-              ExecComplete (Left err) _ -> pure $ Left $ show err-              ExecComplete (Right _) _ -> liftIO $ Right . (\x -> if null x then Nothing else Just x) <$> readFile' temp-              ExecBreak{} -> pure $ Right $ Just "breakpoints are not supported"-    liftIO purge-    pure result+-- 'System.IO.Extra.withTempFile' is specialized to 'IO'.+withTempFile :: (MonadIO m, MonadMask m) => (FilePath -> m b) -> m (String, b)+withTempFile k = do+    bracket+      (liftIO newTempFile)+      (\(_, purgeTempFile) -> liftIO purgeTempFile)+      (\(tempFile, _) -> do+        r <- k tempFile+        o <- liftIO $ readFile' tempFile+        pure (o, r)) -{- |GHC declarations required to execute test properties+-- | Capture the value the statement evaluates to (printed by GHCi via the+-- interactive print function) by writing it to a temporary file.+withCaptureResult :: Recorder (WithPriority Log) -> Ghc a -> Ghc (String, a)+withCaptureResult recorder action = withTempFile $ \resultTemp -> do+    mEvalPrint <-+      listToMaybe <$>+        runDecls+          ("evalPrint x = P.writeFile " <> show resultTemp <> " (P.show x)")+    case mEvalPrint of+      Nothing ->+        logWith recorder Log.Warning $ LogEvalFailedSettingInteractivePrintFunction+      Just evalPrint ->+        modifySession $+          \hsc -> hsc {hsc_IC = setInteractivePrintName (hsc_IC hsc) evalPrint}+    action +-- | Capture output written to @stdout@ and @stderr@ as a side effect of+-- evaluating the statement.+--+-- We redirect the handles from *within* the interpreted program, because the+-- statement writes to the interpreted standard handles, which are not the host+-- handles that 'System.IO.Silently' would redirect -- HLS has already+-- redirected the latter to protect the LSP channel (see+-- 'Development.IDE.Main').+--+-- NB: This redirection is process global, so output written concurrently to+-- @stdout@/@stderr@ from another thread may be captured here, or eval output+-- may leak. base provides no per-thread standard handles, so this is+-- unavoidable with this approach.+withCaptureStdHandles ::+     ExecOptions+  -> Ghc a+  -> Ghc (String, a)+withCaptureStdHandles opts action = withTempFile $ \outputTemp -> do+    bracket+      (execStmt (captureSetup outputTemp) opts)+      -- Restore the handles no matter how the statement terminated.+      (\_ -> execStmt captureTeardown opts)+      (\_ -> action)++-- Open a temporary file and redirect the interpreted @stdout@/@stderr@ to+-- it, saving the original handles in interactive bindings so 'captureTeardown'+-- can restore them. Bound to a tuple (rather than evaluated as a bare+-- expression) so GHCi does not pass it to the interactive print function.+captureSetup :: FilePath -> String+-- Squeeze into one line (executed by GHCi).+captureSetup outputTemp = unwords+    [ "(__hls_captureHandle, __hls_savedStdout, __hls_savedStderr) <- do {"+    , "  __hls_h <- System.IO.openFile", show outputTemp, "System.IO.WriteMode;"+    , "  System.IO.hSetBuffering __hls_h System.IO.LineBuffering;"+    , "  __hls_o <- GHC.IO.Handle.hDuplicate System.IO.stdout;"+    , "  __hls_e <- GHC.IO.Handle.hDuplicate System.IO.stderr;"+    , "  GHC.IO.Handle.hDuplicateTo __hls_h System.IO.stdout;"+    , "  GHC.IO.Handle.hDuplicateTo __hls_h System.IO.stderr;"+    , "  P.return (__hls_h, __hls_o, __hls_e);"+    , "  }"+    ]++-- Flush, restore the original handles and close the temporary file so the+-- host can read back the captured output.+captureTeardown :: String+-- Squeeze into one line (executed by GHCi).+captureTeardown = unwords+    [ "__hls_restored <- do {"+    , "  System.IO.hFlush System.IO.stdout;"+    , "  System.IO.hFlush System.IO.stderr;"+    , "  GHC.IO.Handle.hDuplicateTo __hls_savedStdout System.IO.stdout;"+    , "  GHC.IO.Handle.hDuplicateTo __hls_savedStderr System.IO.stderr;"+    , "  System.IO.hClose __hls_savedStdout;"+    , "  System.IO.hClose __hls_savedStderr;"+    , "  System.IO.hClose __hls_captureHandle;"+    , "  }"+    ]++{- | GHC declarations required to evaluate property 'EvalExprs'+ Example:  prop> \(l::[Bool]) -> reverse (reverse l) == l +++ OK, passed 100 tests.  prop> \(l::[Bool]) -> reverse l == l-*** Failed! Falsified (after 6 tests and 2 shrinks):+*** Failed! Falsified (after 4 tests and 1 shrink): [True,False] -} propSetup :: [Loc [Char]]
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs view
@@ -30,41 +30,12 @@ import           GHC.Driver.Env import           GHC.Driver.Session              (getDynFlags) -{- $setup->>> import GHC->>> import GHC.Paths->>> run act = runGhc (Just libdir) (getInteractiveDynFlags >>= act)->>> libdir-"/Users/titto/.ghcup/ghc/8.8.4/lib/ghc-8.8.4"--}--{- | True if specified package is present in DynFlags---- >>> hasPackageTst pkg = run $ \df -> return (hasPackage df pkg)->>> hasPackageTst pkg = run $ \_ -> addPackages [pkg] >>= return . either Left (\df -> Right (hasPackage df pkg))-->>> hasPackageTst "base"-Right True-->>> hasPackageTst "ghc"-Right True-->>> hasPackageTst "extra"-Left "<command line>: cannot satisfy -package extra\n    (use -v for more information)"-->>> hasPackageTst "QuickCheck"-Left "<command line>: cannot satisfy -package QuickCheck\n    (use -v for more information)"--} hasPackage :: DynFlags -> String -> Bool hasPackage df = hasPackage_ (packageFlags df)  hasPackage_ :: [PackageFlag] -> [Char] -> Bool hasPackage_ pkgFlags name = any (name `isPrefixOf`) (pkgNames_ pkgFlags) -{- |->>> run (return . pkgNames)-[]--} pkgNames :: DynFlags -> [String] pkgNames = pkgNames_ . packageFlags @@ -77,27 +48,6 @@             _                                 -> Nothing         ) -{- | Expose a list of packages.->>> addPackagesTest pkgs = run (\_ -> (packageFlags <$>) <$> addPackages pkgs)-->>> addPackagesTest []-Right []-->>> addPackagesTest ["base","base","array"]-Right [-package base{package base True ([])},-package array{package array True ([])}]-->>> addPackagesTest ["Cabal"]-Right [-package Cabal{package Cabal True ([])}]-->>> addPackagesTest ["QuickCheck"]-Left "<command line>: cannot satisfy -package QuickCheck\n    (use -v for more information)"-->>> addPackagesTest ["base","notThere"]-Left "<command line>: cannot satisfy -package notThere\n    (use -v for more information)"--prop> \(x::Int) -> x + x == 2 * x-+++ OK, passed 100 tests.--} addPackages :: [String] -> Ghc (Either String DynFlags) addPackages pkgNames = gStrictTry $     modifyFlags $ \df ->@@ -111,37 +61,15 @@     _ <- setSessionDynFlags (f df)     getSessionDynFlags --- modifyFlags f = do---         modifyDynFlags f---         getSessionDynFlags--{- | Add import to evaluation context-->>> run $ \_ -> addImport "import Data.Maybe"-Could not find module ‘Data.Maybe’-Use -v (or `:set -v` in ghci) to see a list of the files searched for.-->>> run $ \df -> addPackages ["base"] >> addImport "import Data.Maybe"-[import Data.Maybe]-->>> run $ \df -> addPackages ["base"] >> addImport "import qualified Data.Maybe as M"-[import qualified Data.Maybe as M]--}+-- | Add import to evaluation context addImport :: GhcMonad m => String -> m [InteractiveImport] addImport i = do     ctx <- getContext-    -- dbgO "CONTEXT" ctx     idecl <- parseImportDecl i     setContext $ IIDecl idecl : ctx-    -- ctx' <- getContext-    -- dbg "CONTEXT'" ctx'     getContext -{- | Add extension to interactive evaluation session->>> import GHC.LanguageExtensions.Type(Extension(..))->>> run $ \_ -> addExtension DeriveGeneric-()--}+-- | Add extension to interactive evaluation session addExtension :: GhcMonad m => Extension -> m () addExtension ext =     modifySession $ \hsc -> hsc{hsc_IC = setExtension (hsc_IC hsc) ext}@@ -151,7 +79,7 @@  deriving instance Read Extension --- Partial display of DynFlags contents, for testing purposes+-- | Partial display of DynFlags contents, for testing purposes showDynFlags :: DynFlags -> String showDynFlags df =     T.unpack . printOutputable . vcat . map (\(n, d) -> text (n ++ ": ") <+> d) $@@ -159,12 +87,8 @@         , ("extensionFlags", ppr . EnumSet.toList . extensionFlags $ df)         , ("importPaths", vList $ importPaths df)         , ("generalFlags", pprHsString . fromString . show . EnumSet.toList . generalFlags $ df)-        , -- , ("includePaths", text . show $ includePaths df)-          -- ("packageEnv", ppr $ packageEnv df)-          ("pkgNames", vcat . map text $ pkgNames df)+        , ("pkgNames", vcat . map text $ pkgNames df)         , ("packageFlags", vcat . map ppr $ packageFlags df)-        -- ,("pkgDatabase",(map) (ppr . installedPackageId) . pkgDatabase $ df)-        -- ("pkgDatabase", text . show <$> pkgDatabase $ df)         ]  vList :: [String] -> SDoc
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs view
@@ -7,11 +7,10 @@ {-# LANGUAGE ViewPatterns              #-} {-# OPTIONS_GHC -Wno-type-defaults #-} -{- |-A plugin inspired by the REPLoid feature of <https://github.com/jyp/dante Dante>, <https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810775744 Haddock>'s Examples and Properties and <https://hackage.haskell.org/package/doctest Doctest>.--For a full example see the "Ide.Plugin.Eval.Tutorial" module.--}+-- | A plugin inspired by the REPLoid feature of+-- [Dante](https://github.com/jyp/dante),+-- [Haddock examples and properties](https://haskell-haddock.readthedocs.io/latest/markup.html#examples),+-- and [Doctest](https://hackage.haskell.org/package/doctest). module Ide.Plugin.Eval.Handlers (     codeAction,     codeLens,@@ -82,6 +81,7 @@ import qualified Development.IDE.GHC.Compat.Core              as SrcLoc (unLoc) import           Development.IDE.Types.HscEnvEq               (HscEnvEq (hscEnv)) import qualified GHC.LanguageExtensions.Type                  as LangExt (Extension (..))+import           Development.IDE.Session.Ghc                  (disableOptimisation)  import           Data.List.Extra                              (unsnoc) import           Development.IDE.Core.PluginUtils@@ -100,11 +100,11 @@                                                                handleMaybeM) import           Ide.Plugin.Eval.Code                         (Statement,                                                                asStatements,-                                                               myExecStmt,+                                                               execStmtCaptureResult,                                                                propSetup,                                                                resultRange,-                                                               testCheck,-                                                               testRanges)+                                                               evalExprCheck,+                                                               evalExprRanges) import           Ide.Plugin.Eval.Config                       (EvalConfig (..),                                                                getEvalConfig) import           Ide.Plugin.Eval.GHC                          (addImport,@@ -135,8 +135,8 @@     pure         $ InL             [ InL command-            | (testRange, command) <- rangeCommands-            , _range `isSubrangeOf` testRange+            | (evalExprRange, command) <- rangeCommands+            , _range `isSubrangeOf` evalExprRange             ]  {- | Code Lens provider@@ -151,6 +151,9 @@             | (range, command) <- rangeCommands             ] +-- | Find every eval-expr in the document and pair its source range with the+-- 'Command' that evaluates it. Shared by the code action and code lens+-- providers. mkRangeCommands :: Recorder (WithPriority Log) -> IdeState -> PluginId -> TextDocumentIdentifier -> ExceptT PluginError (HandlerM Config) [(Range, Command)] mkRangeCommands recorder st plId textDocument =     let dbg = logWith recorder Debug@@ -166,14 +169,14 @@                     runActionE "eval.GetParsedModuleWithComments" st $ useWithStaleE GetEvalComments nfp                 dbg $ LogCodeLensComments comments -                -- Extract tests from source code+                -- Extract 'EvalExpr's from source code                 let Sections{..} = commentsToSections isLHS comments-                    tests = testsBySection nonSetupSections+                    evalExprs = evalExprsBySection nonSetupSections                     cmd = mkLspCommand plId evalCommandName "Evaluate=..." (Just [])                 let rangeCommands =-                        [ (testRange, cmd')-                        | (section, ident, test) <- tests-                        , let (testRange, resultRange) = testRanges test+                        [ (evalExprRange, cmd')+                        | (section, ident, evalExpr) <- evalExprs+                        , let (evalExprRange, resultRange) = evalExprRanges evalExpr                               args = EvalParams (setupSections ++ [section]) textDocument ident                               cmd' =                                 (cmd :: Command)@@ -185,9 +188,9 @@                                     }                         ] -                perf "tests" $-                    dbg $ LogTests-                            (length tests)+                perf "evalExprs" $+                    dbg $ LogEvalExprs+                            (length evalExprs)                             (length nonSetupSections)                             (length setupSections)                             (length rangeCommands)@@ -210,7 +213,7 @@         perf = timed (\lbl duration -> dbg $ LogExecutionTime lbl duration)         cmd :: ExceptT PluginError (HandlerM Config) WorkspaceEdit         cmd = do-            let tests = map (\(a,_,b) -> (a,b)) $ testsBySection sections+            let evalExprs = map (\(a,_,b) -> (a,b)) $ evalExprsBySection sections              let TextDocumentIdentifier{_uri} = module_             fp <- uriToFilePathE _uri@@ -227,7 +230,7 @@                 unqueueForEvaluation st nfp                 return [toKey IsEvaluating nfp]                 )-              (initialiseSessionForEval (needsQuickCheck tests) st nfp)+              (initialiseSessionForEval (needsQuickCheck evalExprs) st nfp)              evalCfg <- liftIO $ runAction "eval: config" st $ getEvalConfig plId @@ -236,7 +239,7 @@                 perf "edits" $                     liftIO $                         evalGhcEnv final_hscEnv $ do-                            runTests recorder evalCfg fp tests+                            runEvalExprs recorder evalCfg fp evalExprs              let workspaceEditsMap = Map.singleton _uri (addFinalReturn mdlText edits)             let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing Nothing@@ -301,6 +304,7 @@                    . flip xopt_unset  LangExt.MonomorphismRestriction                    . flip gopt_set    Opt_ImplicitImportQualified                    . flip gopt_unset  Opt_DiagnosticsShowCaret+                   . disableOptimisation                    . setBackend ghciBackend                    $ (ms_hspp_opts ms) {                         useColor = Never@@ -310,6 +314,9 @@             getSession   return env2 +-- | Convert the typechecker's import specs into the interface representation,+-- so the reconstructed iface for the current module records what it imports+-- (needed when re-adding the rdr env, see 'initialiseSessionForEval'). #if MIN_VERSION_ghc(9,13,0) mkIfaceImports :: [ImportUserSpec] -> [IfaceImport] mkIfaceImports = map go@@ -326,12 +333,15 @@     go (ImpUserSpec decl (ImpUserEverythingBut ns)) = IfaceImport decl (ImpIfaceEverythingBut ns) #endif +-- | Prepend an edit adding a trailing newline when the module does not end in+-- one, so the appended results land on their own line. addFinalReturn :: Text -> [TextEdit] -> [TextEdit] addFinalReturn mdlText edits     | not (null edits) && not (T.null mdlText) && T.last mdlText /= '\n' =         finalReturn mdlText : edits     | otherwise = edits +-- | An empty edit at the very end of the module that inserts a newline. finalReturn :: Text -> TextEdit finalReturn txt =     let ls = T.lines txt@@ -340,6 +350,7 @@         p = Position l c      in TextEdit (Range p p) "\n" +-- | The current (possibly unsaved) contents of the module as seen by the IDE. moduleText :: IdeState -> Uri -> ExceptT PluginError (HandlerM config) Text moduleText state uri = do     contents <-@@ -350,67 +361,96 @@                         toNormalizedUri uri     pure $ Rope.toText contents -testsBySection :: [Section] -> [(Section, EvalId, Test)]-testsBySection sections =-    [(section, ident, test)+-- | Flatten sections into their individual 'EvalExpr's, tagging each with the index+-- ('EvalId') of its containing section.+evalExprsBySection :: [Section] -> [(Section, EvalId, EvalExpr)]+evalExprsBySection sections =+    [(section, ident, evalExpr)     | (ident, section) <- zip [0..] sections-    , test <- sectionTests section+    , evalExpr <- sectionEvalExprs section     ]  type TEnv = String -- |GHC declarations required for expression evaluation evalSetup :: Ghc () evalSetup = do-    preludeAsP <- parseImportDecl "import qualified Prelude as P"-    context <- getContext-    setContext (IIDecl preludeAsP : context)+    preludeAsP  <- parseImportDecl "import qualified Prelude as P"+    -- 'myExecStmt' redirects the interpreted @stdout@ and @stderr@ to a temporary+    -- file in order to capture output produced as a side effect of evaluating a+    -- statement. The setup and teardown statements it injects need these modules+    -- in scope.+    systemIO    <- parseImportDecl "import qualified System.IO"+    ghcIOHandle <- parseImportDecl "import qualified GHC.IO.Handle"+    context     <- getContext+    setContext (IIDecl preludeAsP : IIDecl systemIO : IIDecl ghcIOHandle : context) -runTests :: Recorder (WithPriority Log) -> EvalConfig -> TEnv -> [(Section, Test)] -> Ghc [TextEdit]-runTests recorder EvalConfig{..} e tests = do+-- | Evaluate every 'EvalExpr' and produce the 'TextEdit's that write the results+-- back into the document, prefixing/padding each result line as the section's+-- format requires.+runEvalExprs ::+     Recorder (WithPriority Log)+  -> EvalConfig+  -> TEnv+  -> [(Section, EvalExpr)]+  -> Ghc [TextEdit]+runEvalExprs recorder EvalConfig{..} e evalExprs = do     df <- getInteractiveDynFlags     evalSetup-    when (hasQuickCheck df && needsQuickCheck tests) $ void $ evals recorder True e df propSetup+    when (hasQuickCheck df && needsQuickCheck evalExprs) $+      void $ evals recorder True e df propSetup -    mapM (processTest e df) tests+    mapM (processEvalExpr e df) evalExprs   where-    processTest :: TEnv -> DynFlags -> (Section, Test) -> Ghc TextEdit-    processTest fp df (section, test) = do+    processEvalExpr :: TEnv -> DynFlags -> (Section, EvalExpr) -> Ghc TextEdit+    processEvalExpr fp df (section, evalExpr) = do         let dbg = logWith recorder Debug-        let pad = pad_ $ (if isLiterate fp then ("> " `T.append`) else id) $ padPrefix (sectionFormat section)-        rs <- runTest e df test-        dbg $ LogRunTestResults rs+            pre =+              (if isLiterate fp then ("> " `T.append`) else id) $+                padPrefix (sectionFormat section)+            pad = T.append pre+        rs <- runEvalExpr e df evalExpr+        dbg $ LogRunEvalExprResults rs -        let checkedResult = testCheck eval_cfg_diff (section, test) rs-        let resultLines = concatMap T.lines checkedResult+        let resultLines = evalExprCheck eval_cfg_diff (section, evalExpr) rs -        let edit = asEdit (sectionFormat section) test (map pad resultLines)-        dbg $ LogRunTestEdits edit+        let edit = asEdit (sectionFormat section) evalExpr (map pad resultLines)+        dbg $ LogRunEvalExprEdits edit         return edit -    -- runTest :: String -> DynFlags -> Loc Test -> Ghc [Text]-    runTest _ df test-        | not (hasQuickCheck df) && isProperty test =+    runEvalExpr :: String -> DynFlags -> EvalExpr -> Ghc [Text]+    runEvalExpr e df evalExpr+        | not (hasQuickCheck df) && isProperty evalExpr =             return $                 singleLine-                    "Add QuickCheck to your cabal dependencies to run this test."-    runTest e df test = evals recorder (eval_cfg_exception && not (isProperty test)) e df (asStatements test)+                    "Add QuickCheck to your cabal dependencies to run this property."+        | otherwise =+            evals+              recorder+              (eval_cfg_exception && not (isProperty evalExpr))+              e+              df+              (asStatements evalExpr) -asEdit :: Format -> Test -> [Text] -> TextEdit-asEdit (MultiLine commRange) test resultLines-    -- A test in a block comment, ending with @-\}@ without newline in-between.-    | testRange test ^. L.end . L.line == commRange ^. L.end . L.line+-- | Build the edit that replaces the old result of an 'EvalExpr' with+-- @resultLines@. For an 'EvalExpr' that sits on the closing @-}@ line of a+-- block comment, the result is inserted before @-}@ on fresh lines; otherwise+-- it simply overwrites the existing result range.+asEdit :: Format -> EvalExpr -> [Text] -> TextEdit+asEdit (MultiLine commRange) evalExpr resultLines+    -- An 'EvalExpr' in a block comment, ending with @-\}@ without newline in-between.+    | evalExprRange evalExpr ^. L.end . L.line == commRange ^. L.end . L.line     =     TextEdit         (Range-            (testRange test ^. L.end)-            (resultRange test ^. L.end)+            (evalExprRange evalExpr ^. L.end)+            (resultRange evalExpr ^. L.end)         )         ("\n" <> T.unlines (resultLines <> ["-}"]))-asEdit _ test resultLines =-    TextEdit (resultRange test) (T.unlines resultLines)+asEdit _ evalExpr resultLines =+    TextEdit (resultRange evalExpr) (T.unlines resultLines)  {- |-The result of evaluating a test line can be:+The result of evaluating an eval-expr line can be: * a value * nothing * a (possibly multiline) error message@@ -418,13 +458,16 @@ A value is returned for a correct expression.  Either a pure value:->>> 'h' :"askell"+>>> 'h' : "askell" "haskell" -Or an 'IO a' (output on stdout/stderr is ignored):->>> print "OK" >> return "ABC"-"ABC"+Or an 'IO a' (output on stdout/stderr is captured):+>>> putStrLn "Hello," >> pure "World!"+Hello,+"World!" +Note the quotes around @World!@, which are a result of using 'show'.+ Nothing is returned for a correct directive:  >>>:set -XFlexibleInstances@@ -447,11 +490,15 @@ Some flags have not been recognized: -XNonExistent  >>> cls C-Variable not in scope: cls :: t0 -> t-Data constructor not in scope: C+Illegal term-level use of the class `C'+  defined at <interactive>:1:2+In the first argument of `cls', namely `C'+In the expression: cls C+In an equation for `it_a1kSJ': it_a1kSJ = cls C+Variable not in scope: cls :: t0_a1kU9[tau:1] -> t1_a1kUb[tau:1]  >>> "A-lexical error in string/character literal at end of input+lexical error at end of input  Exceptions are shown as if printed, but it can be configured to include prefix like in GHCi or doctest. This allows it to be used as a hack to simulate print until we@@ -467,7 +514,8 @@ Or for a value that does not have a Show instance and can therefore not be displayed: >>> data V = V >>> V-No instance for (Show V) arising from a use of ‘evalPrint’+No instance for `Show V' arising from a use of `evalPrint'+In a stmt of an interactive GHCi command: evalPrint it_a1l4V -} evals :: Recorder (WithPriority Log) -> Bool -> TEnv -> DynFlags -> [Statement] -> Ghc [Text] evals recorder mark_exception fp df stmts = do@@ -476,7 +524,7 @@         Left err -> errorLines err         Right rs -> concat . catMaybes $ rs   where-    dbg = logWith recorder Debug+    dbg  = logWith recorder Debug     eval :: Statement -> Ghc (Maybe [Text])     eval (Located l stmt)         | -- GHCi flags@@ -542,13 +590,13 @@     unhelpfulReason = UnhelpfulInteractive     exec stmt l =         let opts = execOptions{execSourceFile = fp, execLineNumber = l}-         in myExecStmt stmt opts+         in execStmtCaptureResult recorder stmt opts -needsQuickCheck :: [(Section, Test)] -> Bool+needsQuickCheck :: [(Section, EvalExpr)] -> Bool needsQuickCheck = any (isProperty . snd)  hasQuickCheck :: DynFlags -> Bool-hasQuickCheck df = hasPackage df "QuickCheck"+hasQuickCheck df = any (hasPackage df) ["QuickCheck", "QckChck"]  singleLine :: String -> [Text] singleLine s = [T.pack s]@@ -577,14 +625,7 @@ >>> map (pad_ (T.pack "--")) (map T.pack ["2+2",""]) ["--2+2","--<BLANKLINE>"] -}-pad_ :: Text -> Text -> Text-pad_ prefix = (prefix `T.append`) . convertBlank -convertBlank :: Text -> Text-convertBlank x-    | T.null x = "<BLANKLINE>"-    | otherwise = x- padPrefix :: IsString p => Format -> p padPrefix SingleLine = "-- " padPrefix _          = ""@@ -605,6 +646,9 @@     , ("type", doTypeCmd)     ] +-- | Dispatch a GHCi-like command (e.g. @:type@, @:kind@, @:info@) to its+-- handler, matching by exact name or unique prefix. Throws if no command+-- matches. evalGhciLikeCmd :: Text -> Text -> Ghc (Maybe [Text]) evalGhciLikeCmd cmd arg = do     df <- getSessionDynFlags@@ -617,6 +661,8 @@                 <$> hndler df arg         _ -> E.throw $ GhciLikeCmdNotImplemented cmd arg +-- | Implement @:info@ / @:info!@: show the definition, fixity and instances of+-- each named thing. The 'Bool' is the @!@ variant, including all instances. doInfoCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text) doInfoCmd allInfo dflags s = do     sdocs <- mapM infoThing (T.words s)@@ -662,6 +708,8 @@                 = ppr fixity <+> pprInfixName (GHC.getName thing)             | otherwise = empty +-- | Implement @:kind@ / @:kind!@: show a type's kind. The 'Bool' is the @!@+-- variant, additionally normalising and showing the type itself. doKindCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text) doKindCmd False df arg = do     let input = T.strip arg@@ -675,6 +723,8 @@         tyDoc = "=" <+> pprSigmaType ty     pure $ Just $ T.pack (showSDoc df $ kindDoc $$ tyDoc) +-- | Implement @:type@: show the type of an expression. Accepts a leading+-- @+d@ to request the defaulted type (see 'parseExprMode'). doTypeCmd :: DynFlags -> Text -> Ghc (Maybe Text) doTypeCmd dflags arg = do     let (emod, expr) = parseExprMode arg@@ -691,6 +741,8 @@                                 $$ nest 2 ("::" <+> pprSigmaType ty)                 else expr <> " :: " <> rawType <> "\n" +-- | Split a @:type@ argument into its mode and expression: a leading @+d@+-- selects defaulting ('TM_Default'), anything else the plain type ('TM_Inst'). parseExprMode :: Text -> (TcRnExprMode, T.Text) parseExprMode rawArg = case T.break isSpace rawArg of     ("+d", rest) -> (TM_Default, T.strip rest)
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs view
@@ -90,16 +90,16 @@ newtype ExampleLine = ExampleLine {getExampleLine :: String}     deriving (Show) -data TestComment+data EvalExprComment     = AProp-        { testCommentRange :: Range-        , lineProp         :: PropLine-        , propResults      :: [String]+        { evalExprCommentRange :: Range+        , lineProp             :: PropLine+        , propResults          :: [String]         }     | AnExample-        { testCommentRange :: Range-        , lineExamples     :: NonEmpty ExampleLine-        , exampleResults   :: [String]+        { evalExprCommentRange :: Range+        , lineExamples         :: NonEmpty ExampleLine+        , exampleResults       :: [String]         }     deriving (Show) @@ -174,19 +174,19 @@                 -- block comment body.                 $ Map.toList blockComments         lineSections =-            lineSectionSeeds <&> uncurry (testsToSection Line)+            lineSectionSeeds <&> uncurry (evalExprsToSection Line)         multilineSections =             Map.mapWithKey-                (uncurry . testsToSection . Block)+                (uncurry . evalExprsToSection . Block)                 blockSeed         setupSections =             -- Setups doesn't need Dummy position             map-                ( \(style, tests) ->-                    testsToSection+                ( \(style, evalExprs) ->+                    evalExprsToSection                         style                         (Named "setup")-                        tests+                        evalExprs                 )                 $ DL.toList $                     F.fold $@@ -214,12 +214,12 @@  type SectionRange = Range -testsToSection ::+evalExprsToSection ::     CommentStyle ->     CommentFlavour ->-    [TestComment] ->+    [EvalExprComment] ->     Section-testsToSection style flav tests =+evalExprsToSection style flav evalExprs =     let sectionName             | Named name <- flav = name             | otherwise = ""@@ -227,25 +227,25 @@             HaddockNext -> Haddock             HaddockPrev -> Haddock             _           -> Plain-        sectionTests = map fromTestComment tests+        sectionEvalExprs = map fromEvalExprComment evalExprs         sectionFormat =             case style of                 Line      -> SingleLine                 Block ran -> MultiLine ran      in Section {..} -fromTestComment :: TestComment -> Test-fromTestComment AProp {..} =-    Property-        { testline = getPropLine lineProp-        , testOutput = propResults-        , testRange = testCommentRange+fromEvalExprComment :: EvalExprComment -> EvalExpr+fromEvalExprComment AProp {..} =+    Property {+          evalExprLine   = getPropLine lineProp+        , evalExprOutput = propResults+        , evalExprRange  = evalExprCommentRange         }-fromTestComment AnExample {..} =-    Example-        { testLines = getExampleLine <$> lineExamples-        , testOutput = exampleResults-        , testRange = testCommentRange+fromEvalExprComment AnExample {..} =+    Example {+          evalExprLines  = getExampleLine <$> lineExamples+        , evalExprOutput = exampleResults+        , evalExprRange  = evalExprCommentRange         }  -- * Block comment parser@@ -256,11 +256,11 @@ -}  -- >>> parseE (blockCommentBP True dummyPos) "{- |\n  >>> 5+5\n  11\n  -}"--- (HaddockNext,[AnExample {testCommentRange = Position {_line = 1, _character = 0}, lineExamples = ExampleLine {getExampleLine = " 5+5"} :| [], exampleResults = ["  11"]}])+-- (HaddockNext,[AnExample {evalExprCommentRange = Position {_line = 1, _character = 0}, lineExamples = ExampleLine {getExampleLine = " 5+5"} :| [], exampleResults = ["  11"]}])  blockCommentBP ::     -- | True if Literate Haskell-    BlockCommentParser (CommentFlavour, [TestComment])+    BlockCommentParser (CommentFlavour, [EvalExprComment]) blockCommentBP = do     skipCount 2 anySingle -- "{-"     void $ optional $ char ' '@@ -281,10 +281,10 @@     BlockEnv {..} <- ask     skipManyTill (normalLineP isLhs $ Block blockRange) $         False <$ try (optional (chunk "-}") *> eof)-            <|> True <$ lookAhead (try $ testSymbol isLhs $ Block blockRange)+            <|> True <$ lookAhead (try $ evalExprSymbol isLhs $ Block blockRange) -testSymbol :: Bool -> CommentStyle -> LineParser ()-testSymbol isLHS style =+evalExprSymbol :: Bool -> CommentStyle -> LineParser ()+evalExprSymbol isLHS style =     -- FIXME: To comply with existing Extended Eval Plugin Behaviour;     -- it must skip one space after a comment!     -- This prevents Eval Plugin from working on@@ -297,7 +297,7 @@  blockExamples     , blockProp ::-        BlockCommentParser TestComment+        BlockCommentParser EvalExprComment blockExamples = do     BlockEnv {..} <- ask     (ran, examples) <- withRange $ NE.some $ exampleLineStrP isLhs $ Block blockRange@@ -340,10 +340,10 @@  -- * Line Group Parser -{- |-Result: a tuple of ordinary line tests and setting sections.+{- | Result: a tuple of ordinary line evaluation expressions and setting+sections. -TODO: Haddock comment can adjacent to vanilla comment:+TODO: Haddock comment can be adjacent to a vanilla comment:      @         -- Vanilla comment@@ -351,12 +351,12 @@         -- | This parses as Haddock comment as GHC     @ -This behaviour is not yet handled correctly in Eval Plugin;+This behaviour is not yet handled correctly in the Eval Plugin; but for future extension for this, we use a tuple here instead of 'Either'. -} lineGroupP ::     LineGroupParser-        (Maybe (CommentFlavour, [TestComment]), [TestComment])+        (Maybe (CommentFlavour, [EvalExprComment]), [EvalExprComment]) lineGroupP = do     (_, flav) <- lookAhead $ parseLine (commentFlavourP <* takeRest)     case flav of@@ -386,7 +386,7 @@     void $ optional $ char ' '  lineCommentSectionsP ::-    LineGroupParser [TestComment]+    LineGroupParser [EvalExprComment] lineCommentSectionsP = do     skipMany normalLineCommentP     many $@@ -411,7 +411,7 @@             parseLine $                 fst <$ commentFlavourP <*> nonEmptyNormalLineP False Line -exampleLinesGP :: LineGroupParser TestComment+exampleLinesGP :: LineGroupParser EvalExprComment exampleLinesGP =     lexemeLine $         uncurry AnExample . first convexHullRange . NE.unzip@@ -485,7 +485,7 @@     LineParser (String, Position) normalLineP isLHS style = do     notFollowedBy-        (try $ testSymbol isLHS style)+        (try $ evalExprSymbol isLHS style)     when (isLHS && is _Block style) $         void $ count' 0 2 $ char ' '     consume style@@ -499,10 +499,10 @@ getPosition :: (Ord v, TraversableStream s) => ParsecT v s m Position getPosition = sourcePosToPosition <$> getSourcePos --- | Parses example test line.+-- | Parses example line. exampleLineStrP ::-    -- | True if Literate Haskell     Bool ->+    -- ^ True if Literate Haskell     CommentStyle ->     LineParser (ExampleLine, Position) exampleLineStrP isLHS style =@@ -522,10 +522,10 @@ propSymbol :: LineParser () propSymbol = chunk "prop>" *> P.notFollowedBy (char '>') --- | Parses prop test line.+-- | Parses property line. propLineStrP ::-    -- | True if Literate HAskell     Bool ->+    -- ^ True if Literate Haskell     CommentStyle ->     LineParser (PropLine, Position) propLineStrP isLHS style =
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs view
@@ -12,14 +12,14 @@     ( Log(..),       locate,       locate0,-      Test (..),+      EvalExpr (..),       isProperty,       Format (..),       Language (..),       Section (..),       Sections (..),-      hasTests,-      hasPropertyTest,+      hasEvalExprs,+      hasPropertyEvalExpr,       splitSections,       Loc,       Located (..),@@ -61,9 +61,9 @@     | LogCodeLensFp FilePath     | LogCodeLensComments Comments     | LogExecutionTime T.Text Extra.Seconds-    | LogTests !Int !Int !Int !Int-    | LogRunTestResults [T.Text]-    | LogRunTestEdits TextEdit+    | LogEvalExprs !Int !Int !Int !Int+    | LogRunEvalExprResults [T.Text]+    | LogRunEvalExprEdits TextEdit     | LogEvalFlags [String]     | LogEvalPreSetDynFlags Core.DynFlags     | LogEvalParsedFlags@@ -75,6 +75,7 @@     | LogEvalStmtResult (Maybe [T.Text])     | LogEvalImport String     | LogEvalDeclaration String+    | LogEvalFailedSettingInteractivePrintFunction  instance Pretty Log where     pretty = \case@@ -82,9 +83,10 @@         LogCodeLensFp fp -> "fp" <+> pretty fp         LogCodeLensComments comments -> "comments" <+> viaShow comments         LogExecutionTime lbl duration -> pretty lbl <> ":" <+> pretty (Extra.showDuration duration)-        LogTests nTests nNonSetupSections nSetupSections nLenses -> "Tests" <+> fillSep-            [ pretty nTests-            , "tests in"+        LogEvalExprs nEvalExprs nNonSetupSections nSetupSections nLenses ->+          "EvalExprs" <+> fillSep [+              pretty nEvalExprs+            , "expressions to evaluate in"             , pretty nNonSetupSections             , "sections"             , pretty nSetupSections@@ -92,8 +94,8 @@             , pretty nLenses             , "lenses."             ]-        LogRunTestResults results ->  "TEST RESULTS" <+> viaShow results-        LogRunTestEdits edits -> "TEST EDIT" <+> viaShow edits+        LogRunEvalExprResults results ->  "EVAL EXPR RESULTS" <+> viaShow results+        LogRunEvalExprEdits edits -> "EVAL EXPR EDIT" <+> viaShow edits         LogEvalFlags flags -> "{:SET" <+> pretty flags         LogEvalPreSetDynFlags dynFlags -> "pre set" <+> pretty (showDynFlags dynFlags)         LogEvalParsedFlags eans -> "parsed flags" <+> viaShow (eans@@ -103,6 +105,9 @@         LogEvalStmtResult result -> "STMT}" <+> pretty result         LogEvalImport stmt -> "{IMPORT" <+> pretty stmt         LogEvalDeclaration stmt -> "{DECL" <+> pretty stmt+        LogEvalFailedSettingInteractivePrintFunction -> pretty $+               "Return value will not be captured: "+            ++ "Failed setting the interactive print function."  -- | A thing with a location attached. data Located l a = Located {location :: l, located :: a}@@ -134,26 +139,34 @@     deriving (Show, Eq, Generic)  data Section = Section-    { sectionName     :: Txt-    , sectionTests    :: [Test]-    , sectionLanguage :: Language-    , sectionFormat   :: Format+    { sectionName      :: Txt+    , sectionEvalExprs :: [EvalExpr]+    , sectionLanguage  :: Language+    , sectionFormat    :: Format     }     deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData) -hasTests :: Section -> Bool-hasTests = not . null . sectionTests+hasEvalExprs :: Section -> Bool+hasEvalExprs = not . null . sectionEvalExprs -hasPropertyTest :: Section -> Bool-hasPropertyTest = any isProperty . sectionTests+hasPropertyEvalExpr :: Section -> Bool+hasPropertyEvalExpr = any isProperty . sectionEvalExprs  -- |Split setup and normal sections splitSections :: [Section] -> ([Section], [Section]) splitSections = partition ((== "setup") . sectionName) -data Test-    = Example {testLines :: NonEmpty Txt, testOutput :: [Txt], testRange :: Range}-    | Property {testline :: Txt, testOutput :: [Txt], testRange :: Range}+data EvalExpr =+      Example {+          evalExprLines  :: NonEmpty Txt+        , evalExprOutput :: [Txt]+        , evalExprRange  :: Range+        }+    | Property {+          evalExprLine   :: Txt+        , evalExprOutput :: [Txt]+        , evalExprRange  :: Range+        }     deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData)  data IsEvaluating = IsEvaluating@@ -210,14 +223,14 @@ instance Monoid Comments where     mempty = Comments mempty mempty -isProperty :: Test -> Bool+isProperty :: EvalExpr -> Bool isProperty Property {} = True isProperty _           = False  data Format     = SingleLine     | -- | @Range@ is that of surrounding entire block comment, not section.-      -- Used for detecting no-newline test commands.+      -- Used for detecting no-newline eval-expr commands.       MultiLine Range     deriving (Eq, Show, Ord, Generic, FromJSON, ToJSON, NFData) @@ -237,10 +250,10 @@  type EvalId = Int --- | Specify the test section to execute+-- | Specify the eval-expr sections to execute data EvalParams = EvalParams     { sections :: [Section]     , module_  :: !TextDocumentIdentifier-    , evalId   :: !EvalId -- ^ unique group id; for test uses+    , evalId   :: !EvalId -- ^ unique group id; for eval-expr uses     }     deriving (Eq, Show, Generic, FromJSON, ToJSON)
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs view
@@ -48,19 +48,26 @@ isLiterate :: FilePath -> Bool isLiterate x = takeExtension x `elem` [".lhs", ".lhs-boot"] -response' :: ExceptT PluginError (HandlerM c) WorkspaceEdit -> ExceptT PluginError (HandlerM c) (Value |? Null)+response' ::+     ExceptT PluginError (HandlerM c) WorkspaceEdit+  -> ExceptT PluginError (HandlerM c) (Value |? Null) response' act = do     res <-  ExceptT (runExceptT act              `catchAny` \e -> do                 res <- showErr e                 pure . Left  . PluginInternalError $ fromString res)-    _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing res) (\_ -> pure ())+    _ <-+      lift $+        pluginSendRequest+          SMethod_WorkspaceApplyEdit+          (ApplyWorkspaceEditParams Nothing res)+          (\_ -> pure ())     pure $ InR Null  gStrictTry :: (MonadIO m, MonadCatch m) => m b -> m (Either String b)-gStrictTry op =+gStrictTry action =     catch-        (op >>= fmap Right . gevaluate)+        (action >>= fmap Right . gevaluate)         (fmap Left . showErr)  gevaluate :: MonadIO m => a -> m a
plugins/hls-eval-plugin/test/Main.hs view
@@ -20,7 +20,7 @@ import qualified Ide.Plugin.Config          as Plugin import qualified Ide.Plugin.Eval            as Eval import           Ide.Plugin.Eval.Types      (EvalParams (..), Section (..),-                                             testOutput)+                                             evalExprOutput) import           Language.LSP.Protocol.Lens (command, range, title) import           System.FilePath            ((<.>), (</>)) import           Test.Hls@@ -128,7 +128,8 @@       evalInFile "T8.hs" "-- >>> :t id" "-- id :: a -> a"       evalInFile "T8.hs" "-- >>> :set -fprint-explicit-foralls\n-- >>> :t id" "-- id :: forall a. a -> a"   , goldenWithEval "The default language extensions for the eval plugin are the same as those for ghci" "TSameDefaultLanguageExtensionsAsGhci" "hs"-  , goldenWithEval "IO expressions are supported, stdout/stderr output is ignored" "TIO" "hs"+  , goldenWithEval "Support IO expressions, capture and show stdout/stderr output" "TIO" "hs"+  , goldenWithEval "Support IO expressions, close handles on errors" "TIOError" "hs"   , goldenWithEvalAndFs "Property checking" cabalProjectFS "TProperty" "hs"   , knownBrokenInWindowsBeforeGHC912 "The output has path separators in it, which on Windows look different. Just skip it there" $       goldenWithEvalAndFs' "Property checking with exception" cabalProjectFS "TPropertyError" "hs" $@@ -144,7 +145,7 @@   , goldenWithEval "Test on last line insert results correctly" "TLastLine" "hs"   , testGroup "with preprocessors"     [ knownBrokenInEnv [HostOS Windows]-        "CPP eval on Windows and/or GHC <= 8.6 fails for some reasons" $+        "CPP eval on Windows fails for some reasons" $         goldenWithEval "CPP support" "TCPP" "hs"     , goldenWithEval "Literate Haskell Bird Style" "TLHS" "lhs"     ]@@ -152,6 +153,7 @@   , goldenWithEval "Variable 'it' works" "TIt" "hs"   , testGroup "configuration"     [ goldenWithEval' "Give 'WAS' by default" "TDiff" "hs" "expected.default"+    , goldenWithEval "Refreshing an identical multi-line result is a no-op" "TDiffMultiline" "hs"     , goldenWithEvalConfig' "Give the result only if diff is off" "TDiff" "hs" "expected.no-diff" diffOffConfig     , goldenWithEvalConfig' "Evaluates to exception (not marked)" "TException" "hs" "expected.nomark" (exceptionConfig False)     , goldenWithEvalConfig' "Evaluates to exception (with mark)" "TException" "hs" "expected.marked" (exceptionConfig True)@@ -211,8 +213,9 @@         changeDoc doc []         _ <- waitForTypecheck doc         Right keys <- getLastBuildKeys-        let ifaceKeys = filter ("GetModIface" `T.isPrefixOf`) keys+        let ifaceKeys = filter (\k -> any (`T.isPrefixOf` k) ["GetModIface", "GetModArtefacts"]) keys         liftIO $ ifaceKeys @?= []+    , goldenWithEval "Works with OPTIONS_GHC -O1" "TGHCOptionO1" "hs"   ]   where     knownBrokenInWindowsBeforeGHC912 msg =@@ -289,8 +292,8 @@   CodeLens { _command = Just command } <- [codeLens]   Command { _arguments = Just args } <- [command]   Success EvalParams { sections = sections } <- fromJSON @EvalParams <$> args-  Section { sectionTests = sectionTests } <- sections-  testOutput =<< sectionTests+  Section { sectionEvalExprs = sectionEvalExprs } <- sections+  evalExprOutput =<< sectionEvalExprs  testDataDir :: FilePath testDataDir = "plugins" </> "hls-eval-plugin" </> "test" </> "testdata"
+ plugins/hls-eval-plugin/test/dist-newstyle/build/x86_64-linux/ghc-9.10.3/info-util-0.1.0.0/build/autogen/PackageInfo_info_util.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE NoRebindableSyntax #-}+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}++{-|+Module      : PackageInfo_info_util+Description : Contents of some of the package's Cabal file's fields.++WARNING: This module was generated by Cabal. Any modifications will be+overwritten if the module is regenerated.++This module exports values that record information from some of the fields of+the package's Cabal package description file (Cabal file).++For further information about the fields in a Cabal file, see the Cabal User+Guide.+-}++module PackageInfo_info_util (+    name,+    version,+    synopsis,+    copyright,+    homepage,+  ) where++import Data.Version (Version(..))+import Prelude++-- |The content of the @name@ field of the package's Cabal file, but with any+-- hyphen characters replaced by underscore characters.+name :: String+name = "info_util"+-- |The content of the @version@ field of the package's Cabal file.+version :: Version+version = Version [0,1,0,0] []++-- |The content of the @synopsis@ field of the package's Cabal file.+synopsis :: String+synopsis = ""+-- |The content of the @copyright@ field of the package's Cabal file.+copyright :: String+copyright = "2017 Author name here"+-- |The content of the @homepage@ field of the package's Cabal file.+homepage :: String+homepage = ""
+ plugins/hls-eval-plugin/test/dist-newstyle/build/x86_64-linux/ghc-9.10.3/info-util-0.1.0.0/build/autogen/Paths_info_util.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoRebindableSyntax #-}+#if __GLASGOW_HASKELL__ >= 810+{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}+#endif+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}++{-|+Module      : Paths_info_util+Description : Data file location, and package version and installation+              directories.++WARNING: This module was generated by Cabal. Any modifications will be+overwritten if the module is regenerated.++This module exports a function to locate data files, and values that record+the version of the package and some directories which the package has been+configured to be installed into.++For further information about Cabal's options for its configuration step, and+their default values, see the Cabal User Guide.+-}++module Paths_info_util (+    version,+    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,+    getDataFileName, getSysconfDir+  ) where+++import qualified Control.Exception as Exception+import Data.Version (Version(..))+import System.Environment (getEnv)+import Prelude+++#if defined(VERSION_base)++#if MIN_VERSION_base(4,0,0)+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#else+catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a+#endif++#else+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#endif+catchIO = Exception.catch++-- |The package version.+version :: Version+version = Version [0,1,0,0] []++-- |If the argument is a filename, the result is the name of a corresponding+-- file on the system on which the program is running, if the file were listed+-- in the @data-files@ field of the package's Cabal package description file.+-- No check is performed that the given filename is listed in that field.+getDataFileName :: FilePath -> IO FilePath+getDataFileName name = do+  dir <- getDataDir+  return (dir `joinFileName` name)++-- |The location of the directory specified by Cabal's @--bindir@ option (where+-- executables that the user might invoke are installed). This can be overridden+-- at runtime using the environment variable info_util_bindir.+getBinDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--libdir@ option (where+-- object libraries are installed). This can be overridden at runtime using the+-- environment variable info_util_libdir.+getLibDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--dynlibdir@ option+-- (where dynamic libraries are installed). This can be overridden at runtime+-- using the environment variable info_util_dynlibdir.+getDynLibDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--datadir@ option (where+-- architecture-independent data files are installed). This can be overridden at+-- runtime using the environment variable info_util_datadir.+getDataDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--libexedir@ option+-- (where executables that are not expected to be invoked directly by the user+-- are installed). This can be overridden at runtime using the environment+-- variable info_util_libexedir.+getLibexecDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--sysconfdir@ option+-- (where configuration files are installed). This can be overridden at runtime+-- using the environment variable info_util_sysconfdir.+getSysconfDir :: IO FilePath+++++bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath+bindir     = "/home/hugin/.cabal/bin"+libdir     = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.10.3-415c/info-util-0.1.0.0-inplace"+dynlibdir  = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.10.3-415c"+datadir    = "/home/hugin/.cabal/share/x86_64-linux-ghc-9.10.3-415c/info-util-0.1.0.0"+libexecdir = "/home/hugin/.cabal/libexec/x86_64-linux-ghc-9.10.3-415c/info-util-0.1.0.0"+sysconfdir = "/home/hugin/.cabal/etc"++getBinDir     = catchIO (getEnv "info_util_bindir")     (\_ -> return bindir)+getLibDir     = catchIO (getEnv "info_util_libdir")     (\_ -> return libdir)+getDynLibDir  = catchIO (getEnv "info_util_dynlibdir")  (\_ -> return dynlibdir)+getDataDir    = catchIO (getEnv "info_util_datadir")    (\_ -> return datadir)+getLibexecDir = catchIO (getEnv "info_util_libexecdir") (\_ -> return libexecdir)+getSysconfDir = catchIO (getEnv "info_util_sysconfdir") (\_ -> return sysconfdir)++++joinFileName :: String -> String -> FilePath+joinFileName ""  fname = fname+joinFileName "." fname = fname+joinFileName dir ""    = dir+joinFileName dir@(c:cs) fname+  | isPathSeparator (lastChar c cs) = dir ++ fname+  | otherwise                       = dir ++ pathSeparator : fname+ where+  -- We do not use Data.List.NonEmpty.last, as that would limit the module to+  -- base >= 4.9.0.0 (GHC >= 8.0.1).+  lastChar x [] = x+  lastChar _ (x:xs) = lastChar x xs++pathSeparator :: Char+pathSeparator = '/'++isPathSeparator :: Char -> Bool+isPathSeparator c = c == '/'
+ plugins/hls-eval-plugin/test/dist-newstyle/build/x86_64-linux/ghc-9.10.3/test-0.1.0.0/build/autogen/PackageInfo_test.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE NoRebindableSyntax #-}+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}++{-|+Module      : PackageInfo_test+Description : Contents of some of the package's Cabal file's fields.++WARNING: This module was generated by Cabal. Any modifications will be+overwritten if the module is regenerated.++This module exports values that record information from some of the fields of+the package's Cabal package description file (Cabal file).++For further information about the fields in a Cabal file, see the Cabal User+Guide.+-}++module PackageInfo_test (+    name,+    version,+    synopsis,+    copyright,+    homepage,+  ) where++import Data.Version (Version(..))+import Prelude++-- |The content of the @name@ field of the package's Cabal file, but with any+-- hyphen characters replaced by underscore characters.+name :: String+name = "test"+-- |The content of the @version@ field of the package's Cabal file.+version :: Version+version = Version [0,1,0,0] []++-- |The content of the @synopsis@ field of the package's Cabal file.+synopsis :: String+synopsis = ""+-- |The content of the @copyright@ field of the package's Cabal file.+copyright :: String+copyright = "2017 Author name here"+-- |The content of the @homepage@ field of the package's Cabal file.+homepage :: String+homepage = ""
+ plugins/hls-eval-plugin/test/dist-newstyle/build/x86_64-linux/ghc-9.10.3/test-0.1.0.0/build/autogen/Paths_test.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoRebindableSyntax #-}+#if __GLASGOW_HASKELL__ >= 810+{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}+#endif+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}++{-|+Module      : Paths_test+Description : Data file location, and package version and installation+              directories.++WARNING: This module was generated by Cabal. Any modifications will be+overwritten if the module is regenerated.++This module exports a function to locate data files, and values that record+the version of the package and some directories which the package has been+configured to be installed into.++For further information about Cabal's options for its configuration step, and+their default values, see the Cabal User Guide.+-}++module Paths_test (+    version,+    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,+    getDataFileName, getSysconfDir+  ) where+++import qualified Control.Exception as Exception+import Data.Version (Version(..))+import System.Environment (getEnv)+import Prelude+++#if defined(VERSION_base)++#if MIN_VERSION_base(4,0,0)+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#else+catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a+#endif++#else+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#endif+catchIO = Exception.catch++-- |The package version.+version :: Version+version = Version [0,1,0,0] []++-- |If the argument is a filename, the result is the name of a corresponding+-- file on the system on which the program is running, if the file were listed+-- in the @data-files@ field of the package's Cabal package description file.+-- No check is performed that the given filename is listed in that field.+getDataFileName :: FilePath -> IO FilePath+getDataFileName name = do+  dir <- getDataDir+  return (dir `joinFileName` name)++-- |The location of the directory specified by Cabal's @--bindir@ option (where+-- executables that the user might invoke are installed). This can be overridden+-- at runtime using the environment variable test_bindir.+getBinDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--libdir@ option (where+-- object libraries are installed). This can be overridden at runtime using the+-- environment variable test_libdir.+getLibDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--dynlibdir@ option+-- (where dynamic libraries are installed). This can be overridden at runtime+-- using the environment variable test_dynlibdir.+getDynLibDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--datadir@ option (where+-- architecture-independent data files are installed). This can be overridden at+-- runtime using the environment variable test_datadir.+getDataDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--libexedir@ option+-- (where executables that are not expected to be invoked directly by the user+-- are installed). This can be overridden at runtime using the environment+-- variable test_libexedir.+getLibexecDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--sysconfdir@ option+-- (where configuration files are installed). This can be overridden at runtime+-- using the environment variable test_sysconfdir.+getSysconfDir :: IO FilePath+++++bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath+bindir     = "/home/hugin/.cabal/bin"+libdir     = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.10.3-415c/test-0.1.0.0-inplace"+dynlibdir  = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.10.3-415c"+datadir    = "/home/hugin/.cabal/share/x86_64-linux-ghc-9.10.3-415c/test-0.1.0.0"+libexecdir = "/home/hugin/.cabal/libexec/x86_64-linux-ghc-9.10.3-415c/test-0.1.0.0"+sysconfdir = "/home/hugin/.cabal/etc"++getBinDir     = catchIO (getEnv "test_bindir")     (\_ -> return bindir)+getLibDir     = catchIO (getEnv "test_libdir")     (\_ -> return libdir)+getDynLibDir  = catchIO (getEnv "test_dynlibdir")  (\_ -> return dynlibdir)+getDataDir    = catchIO (getEnv "test_datadir")    (\_ -> return datadir)+getLibexecDir = catchIO (getEnv "test_libexecdir") (\_ -> return libexecdir)+getSysconfDir = catchIO (getEnv "test_sysconfdir") (\_ -> return sysconfdir)++++joinFileName :: String -> String -> FilePath+joinFileName ""  fname = fname+joinFileName "." fname = fname+joinFileName dir ""    = dir+joinFileName dir@(c:cs) fname+  | isPathSeparator (lastChar c cs) = dir ++ fname+  | otherwise                       = dir ++ pathSeparator : fname+ where+  -- We do not use Data.List.NonEmpty.last, as that would limit the module to+  -- base >= 4.9.0.0 (GHC >= 8.0.1).+  lastChar x [] = x+  lastChar _ (x:xs) = lastChar x xs++pathSeparator :: Char+pathSeparator = '/'++isPathSeparator :: Char -> Bool+isPathSeparator c = c == '/'
+ plugins/hls-eval-plugin/test/dist-newstyle/build/x86_64-linux/ghc-9.12.2/info-util-0.1.0.0/build/autogen/PackageInfo_info_util.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE NoRebindableSyntax #-}+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}++{-|+Module      : PackageInfo_info_util+Description : Contents of some of the package's Cabal file's fields.++WARNING: This module was generated by Cabal. Any modifications will be+overwritten if the module is regenerated.++This module exports values that record information from some of the fields of+the package's Cabal package description file (Cabal file).++For further information about the fields in a Cabal file, see the Cabal User+Guide.+-}++module PackageInfo_info_util (+    name,+    version,+    synopsis,+    copyright,+    homepage,+  ) where++import Data.Version (Version(..))+import Prelude++-- |The content of the @name@ field of the package's Cabal file, but with any+-- hyphen characters replaced by underscore characters.+name :: String+name = "info_util"+-- |The content of the @version@ field of the package's Cabal file.+version :: Version+version = Version [0,1,0,0] []++-- |The content of the @synopsis@ field of the package's Cabal file.+synopsis :: String+synopsis = ""+-- |The content of the @copyright@ field of the package's Cabal file.+copyright :: String+copyright = "2017 Author name here"+-- |The content of the @homepage@ field of the package's Cabal file.+homepage :: String+homepage = ""
+ plugins/hls-eval-plugin/test/dist-newstyle/build/x86_64-linux/ghc-9.12.2/info-util-0.1.0.0/build/autogen/Paths_info_util.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoRebindableSyntax #-}+#if __GLASGOW_HASKELL__ >= 810+{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}+#endif+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}++{-|+Module      : Paths_info_util+Description : Data file location, and package version and installation+              directories.++WARNING: This module was generated by Cabal. Any modifications will be+overwritten if the module is regenerated.++This module exports a function to locate data files, and values that record+the version of the package and some directories which the package has been+configured to be installed into.++For further information about Cabal's options for its configuration step, and+their default values, see the Cabal User Guide.+-}++module Paths_info_util (+    version,+    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,+    getDataFileName, getSysconfDir+  ) where+++import qualified Control.Exception as Exception+import Data.Version (Version(..))+import System.Environment (getEnv)+import Prelude+++#if defined(VERSION_base)++#if MIN_VERSION_base(4,0,0)+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#else+catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a+#endif++#else+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#endif+catchIO = Exception.catch++-- |The package version.+version :: Version+version = Version [0,1,0,0] []++-- |If the argument is a filename, the result is the name of a corresponding+-- file on the system on which the program is running, if the file were listed+-- in the @data-files@ field of the package's Cabal package description file.+-- No check is performed that the given filename is listed in that field.+getDataFileName :: FilePath -> IO FilePath+getDataFileName name = do+  dir <- getDataDir+  return (dir `joinFileName` name)++-- |The location of the directory specified by Cabal's @--bindir@ option (where+-- executables that the user might invoke are installed). This can be overridden+-- at runtime using the environment variable info_util_bindir.+getBinDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--libdir@ option (where+-- object libraries are installed). This can be overridden at runtime using the+-- environment variable info_util_libdir.+getLibDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--dynlibdir@ option+-- (where dynamic libraries are installed). This can be overridden at runtime+-- using the environment variable info_util_dynlibdir.+getDynLibDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--datadir@ option (where+-- architecture-independent data files are installed). This can be overridden at+-- runtime using the environment variable info_util_datadir.+getDataDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--libexedir@ option+-- (where executables that are not expected to be invoked directly by the user+-- are installed). This can be overridden at runtime using the environment+-- variable info_util_libexedir.+getLibexecDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--sysconfdir@ option+-- (where configuration files are installed). This can be overridden at runtime+-- using the environment variable info_util_sysconfdir.+getSysconfDir :: IO FilePath+++++bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath+bindir     = "/home/hugin/.cabal/bin"+libdir     = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.12.2-5327/info-util-0.1.0.0-inplace"+dynlibdir  = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.12.2-5327"+datadir    = "/home/hugin/.cabal/share/x86_64-linux-ghc-9.12.2-5327/info-util-0.1.0.0"+libexecdir = "/home/hugin/.cabal/libexec/x86_64-linux-ghc-9.12.2-5327/info-util-0.1.0.0"+sysconfdir = "/home/hugin/.cabal/etc"++getBinDir     = catchIO (getEnv "info_util_bindir")     (\_ -> return bindir)+getLibDir     = catchIO (getEnv "info_util_libdir")     (\_ -> return libdir)+getDynLibDir  = catchIO (getEnv "info_util_dynlibdir")  (\_ -> return dynlibdir)+getDataDir    = catchIO (getEnv "info_util_datadir")    (\_ -> return datadir)+getLibexecDir = catchIO (getEnv "info_util_libexecdir") (\_ -> return libexecdir)+getSysconfDir = catchIO (getEnv "info_util_sysconfdir") (\_ -> return sysconfdir)++++joinFileName :: String -> String -> FilePath+joinFileName ""  fname = fname+joinFileName "." fname = fname+joinFileName dir ""    = dir+joinFileName dir@(c:cs) fname+  | isPathSeparator (lastChar c cs) = dir ++ fname+  | otherwise                       = dir ++ pathSeparator : fname+ where+  -- We do not use Data.List.NonEmpty.last, as that would limit the module to+  -- base >= 4.9.0.0 (GHC >= 8.0.1).+  lastChar x [] = x+  lastChar _ (x:xs) = lastChar x xs++pathSeparator :: Char+pathSeparator = '/'++isPathSeparator :: Char -> Bool+isPathSeparator c = c == '/'
+ plugins/hls-eval-plugin/test/dist-newstyle/build/x86_64-linux/ghc-9.12.2/test-0.1.0.0/build/autogen/PackageInfo_test.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE NoRebindableSyntax #-}+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}++{-|+Module      : PackageInfo_test+Description : Contents of some of the package's Cabal file's fields.++WARNING: This module was generated by Cabal. Any modifications will be+overwritten if the module is regenerated.++This module exports values that record information from some of the fields of+the package's Cabal package description file (Cabal file).++For further information about the fields in a Cabal file, see the Cabal User+Guide.+-}++module PackageInfo_test (+    name,+    version,+    synopsis,+    copyright,+    homepage,+  ) where++import Data.Version (Version(..))+import Prelude++-- |The content of the @name@ field of the package's Cabal file, but with any+-- hyphen characters replaced by underscore characters.+name :: String+name = "test"+-- |The content of the @version@ field of the package's Cabal file.+version :: Version+version = Version [0,1,0,0] []++-- |The content of the @synopsis@ field of the package's Cabal file.+synopsis :: String+synopsis = ""+-- |The content of the @copyright@ field of the package's Cabal file.+copyright :: String+copyright = "2017 Author name here"+-- |The content of the @homepage@ field of the package's Cabal file.+homepage :: String+homepage = ""
+ plugins/hls-eval-plugin/test/dist-newstyle/build/x86_64-linux/ghc-9.12.2/test-0.1.0.0/build/autogen/Paths_test.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoRebindableSyntax #-}+#if __GLASGOW_HASKELL__ >= 810+{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}+#endif+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}++{-|+Module      : Paths_test+Description : Data file location, and package version and installation+              directories.++WARNING: This module was generated by Cabal. Any modifications will be+overwritten if the module is regenerated.++This module exports a function to locate data files, and values that record+the version of the package and some directories which the package has been+configured to be installed into.++For further information about Cabal's options for its configuration step, and+their default values, see the Cabal User Guide.+-}++module Paths_test (+    version,+    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,+    getDataFileName, getSysconfDir+  ) where+++import qualified Control.Exception as Exception+import Data.Version (Version(..))+import System.Environment (getEnv)+import Prelude+++#if defined(VERSION_base)++#if MIN_VERSION_base(4,0,0)+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#else+catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a+#endif++#else+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#endif+catchIO = Exception.catch++-- |The package version.+version :: Version+version = Version [0,1,0,0] []++-- |If the argument is a filename, the result is the name of a corresponding+-- file on the system on which the program is running, if the file were listed+-- in the @data-files@ field of the package's Cabal package description file.+-- No check is performed that the given filename is listed in that field.+getDataFileName :: FilePath -> IO FilePath+getDataFileName name = do+  dir <- getDataDir+  return (dir `joinFileName` name)++-- |The location of the directory specified by Cabal's @--bindir@ option (where+-- executables that the user might invoke are installed). This can be overridden+-- at runtime using the environment variable test_bindir.+getBinDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--libdir@ option (where+-- object libraries are installed). This can be overridden at runtime using the+-- environment variable test_libdir.+getLibDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--dynlibdir@ option+-- (where dynamic libraries are installed). This can be overridden at runtime+-- using the environment variable test_dynlibdir.+getDynLibDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--datadir@ option (where+-- architecture-independent data files are installed). This can be overridden at+-- runtime using the environment variable test_datadir.+getDataDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--libexedir@ option+-- (where executables that are not expected to be invoked directly by the user+-- are installed). This can be overridden at runtime using the environment+-- variable test_libexedir.+getLibexecDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--sysconfdir@ option+-- (where configuration files are installed). This can be overridden at runtime+-- using the environment variable test_sysconfdir.+getSysconfDir :: IO FilePath+++++bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath+bindir     = "/home/hugin/.cabal/bin"+libdir     = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.12.2-5327/test-0.1.0.0-inplace"+dynlibdir  = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.12.2-5327"+datadir    = "/home/hugin/.cabal/share/x86_64-linux-ghc-9.12.2-5327/test-0.1.0.0"+libexecdir = "/home/hugin/.cabal/libexec/x86_64-linux-ghc-9.12.2-5327/test-0.1.0.0"+sysconfdir = "/home/hugin/.cabal/etc"++getBinDir     = catchIO (getEnv "test_bindir")     (\_ -> return bindir)+getLibDir     = catchIO (getEnv "test_libdir")     (\_ -> return libdir)+getDynLibDir  = catchIO (getEnv "test_dynlibdir")  (\_ -> return dynlibdir)+getDataDir    = catchIO (getEnv "test_datadir")    (\_ -> return datadir)+getLibexecDir = catchIO (getEnv "test_libexecdir") (\_ -> return libexecdir)+getSysconfDir = catchIO (getEnv "test_sysconfdir") (\_ -> return sysconfdir)++++joinFileName :: String -> String -> FilePath+joinFileName ""  fname = fname+joinFileName "." fname = fname+joinFileName dir ""    = dir+joinFileName dir@(c:cs) fname+  | isPathSeparator (lastChar c cs) = dir ++ fname+  | otherwise                       = dir ++ pathSeparator : fname+ where+  -- We do not use Data.List.NonEmpty.last, as that would limit the module to+  -- base >= 4.9.0.0 (GHC >= 8.0.1).+  lastChar x [] = x+  lastChar _ (x:xs) = lastChar x xs++pathSeparator :: Char+pathSeparator = '/'++isPathSeparator :: Char -> Bool+isPathSeparator c = c == '/'
+ plugins/hls-eval-plugin/test/dist-newstyle/build/x86_64-linux/ghc-9.14.1/info-util-0.1.0.0/build/autogen/PackageInfo_info_util.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE NoRebindableSyntax #-}+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}++{-|+Module      : PackageInfo_info_util+Description : Contents of some of the package's Cabal file's fields.++WARNING: This module was generated by Cabal. Any modifications will be+overwritten if the module is regenerated.++This module exports values that record information from some of the fields of+the package's Cabal package description file (Cabal file).++For further information about the fields in a Cabal file, see the Cabal User+Guide.+-}++module PackageInfo_info_util (+    name,+    version,+    synopsis,+    copyright,+    homepage,+  ) where++import Data.Version (Version(..))+import Prelude++-- |The content of the @name@ field of the package's Cabal file, but with any+-- hyphen characters replaced by underscore characters.+name :: String+name = "info_util"+-- |The content of the @version@ field of the package's Cabal file.+version :: Version+version = Version [0,1,0,0] []++-- |The content of the @synopsis@ field of the package's Cabal file.+synopsis :: String+synopsis = ""+-- |The content of the @copyright@ field of the package's Cabal file.+copyright :: String+copyright = "2017 Author name here"+-- |The content of the @homepage@ field of the package's Cabal file.+homepage :: String+homepage = ""
+ plugins/hls-eval-plugin/test/dist-newstyle/build/x86_64-linux/ghc-9.14.1/info-util-0.1.0.0/build/autogen/Paths_info_util.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoRebindableSyntax #-}+#if __GLASGOW_HASKELL__ >= 810+{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}+#endif+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}++{-|+Module      : Paths_info_util+Description : Data file location, and package version and installation+              directories.++WARNING: This module was generated by Cabal. Any modifications will be+overwritten if the module is regenerated.++This module exports a function to locate data files, and values that record+the version of the package and some directories which the package has been+configured to be installed into.++For further information about Cabal's options for its configuration step, and+their default values, see the Cabal User Guide.+-}++module Paths_info_util (+    version,+    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,+    getDataFileName, getSysconfDir+  ) where+++import qualified Control.Exception as Exception+import Data.Version (Version(..))+import System.Environment (getEnv)+import Prelude+++#if defined(VERSION_base)++#if MIN_VERSION_base(4,0,0)+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#else+catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a+#endif++#else+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#endif+catchIO = Exception.catch++-- |The package version.+version :: Version+version = Version [0,1,0,0] []++-- |If the argument is a filename, the result is the name of a corresponding+-- file on the system on which the program is running, if the file were listed+-- in the @data-files@ field of the package's Cabal package description file.+-- No check is performed that the given filename is listed in that field.+getDataFileName :: FilePath -> IO FilePath+getDataFileName name = do+  dir <- getDataDir+  return (dir `joinFileName` name)++-- |The location of the directory specified by Cabal's @--bindir@ option (where+-- executables that the user might invoke are installed). This can be overridden+-- at runtime using the environment variable info_util_bindir.+getBinDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--libdir@ option (where+-- object libraries are installed). This can be overridden at runtime using the+-- environment variable info_util_libdir.+getLibDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--dynlibdir@ option+-- (where dynamic libraries are installed). This can be overridden at runtime+-- using the environment variable info_util_dynlibdir.+getDynLibDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--datadir@ option (where+-- architecture-independent data files are installed). This can be overridden at+-- runtime using the environment variable info_util_datadir.+getDataDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--libexedir@ option+-- (where executables that are not expected to be invoked directly by the user+-- are installed). This can be overridden at runtime using the environment+-- variable info_util_libexedir.+getLibexecDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--sysconfdir@ option+-- (where configuration files are installed). This can be overridden at runtime+-- using the environment variable info_util_sysconfdir.+getSysconfDir :: IO FilePath+++++bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath+bindir     = "/home/hugin/.cabal/bin"+libdir     = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.14.1-ade7/info-util-0.1.0.0-inplace"+dynlibdir  = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.14.1-ade7"+datadir    = "/home/hugin/.cabal/share/x86_64-linux-ghc-9.14.1-ade7/info-util-0.1.0.0"+libexecdir = "/home/hugin/.cabal/libexec/x86_64-linux-ghc-9.14.1-ade7/info-util-0.1.0.0"+sysconfdir = "/home/hugin/.cabal/etc"++getBinDir     = catchIO (getEnv "info_util_bindir")     (\_ -> return bindir)+getLibDir     = catchIO (getEnv "info_util_libdir")     (\_ -> return libdir)+getDynLibDir  = catchIO (getEnv "info_util_dynlibdir")  (\_ -> return dynlibdir)+getDataDir    = catchIO (getEnv "info_util_datadir")    (\_ -> return datadir)+getLibexecDir = catchIO (getEnv "info_util_libexecdir") (\_ -> return libexecdir)+getSysconfDir = catchIO (getEnv "info_util_sysconfdir") (\_ -> return sysconfdir)++++joinFileName :: String -> String -> FilePath+joinFileName ""  fname = fname+joinFileName "." fname = fname+joinFileName dir ""    = dir+joinFileName dir@(c:cs) fname+  | isPathSeparator (lastChar c cs) = dir ++ fname+  | otherwise                       = dir ++ pathSeparator : fname+ where+  -- We do not use Data.List.NonEmpty.last, as that would limit the module to+  -- base >= 4.9.0.0 (GHC >= 8.0.1).+  lastChar x [] = x+  lastChar _ (x:xs) = lastChar x xs++pathSeparator :: Char+pathSeparator = '/'++isPathSeparator :: Char -> Bool+isPathSeparator c = c == '/'
+ plugins/hls-eval-plugin/test/dist-newstyle/build/x86_64-linux/ghc-9.14.1/test-0.1.0.0/build/autogen/PackageInfo_test.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE NoRebindableSyntax #-}+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}++{-|+Module      : PackageInfo_test+Description : Contents of some of the package's Cabal file's fields.++WARNING: This module was generated by Cabal. Any modifications will be+overwritten if the module is regenerated.++This module exports values that record information from some of the fields of+the package's Cabal package description file (Cabal file).++For further information about the fields in a Cabal file, see the Cabal User+Guide.+-}++module PackageInfo_test (+    name,+    version,+    synopsis,+    copyright,+    homepage,+  ) where++import Data.Version (Version(..))+import Prelude++-- |The content of the @name@ field of the package's Cabal file, but with any+-- hyphen characters replaced by underscore characters.+name :: String+name = "test"+-- |The content of the @version@ field of the package's Cabal file.+version :: Version+version = Version [0,1,0,0] []++-- |The content of the @synopsis@ field of the package's Cabal file.+synopsis :: String+synopsis = ""+-- |The content of the @copyright@ field of the package's Cabal file.+copyright :: String+copyright = "2017 Author name here"+-- |The content of the @homepage@ field of the package's Cabal file.+homepage :: String+homepage = ""
+ plugins/hls-eval-plugin/test/dist-newstyle/build/x86_64-linux/ghc-9.14.1/test-0.1.0.0/build/autogen/Paths_test.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoRebindableSyntax #-}+#if __GLASGOW_HASKELL__ >= 810+{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}+#endif+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}++{-|+Module      : Paths_test+Description : Data file location, and package version and installation+              directories.++WARNING: This module was generated by Cabal. Any modifications will be+overwritten if the module is regenerated.++This module exports a function to locate data files, and values that record+the version of the package and some directories which the package has been+configured to be installed into.++For further information about Cabal's options for its configuration step, and+their default values, see the Cabal User Guide.+-}++module Paths_test (+    version,+    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,+    getDataFileName, getSysconfDir+  ) where+++import qualified Control.Exception as Exception+import Data.Version (Version(..))+import System.Environment (getEnv)+import Prelude+++#if defined(VERSION_base)++#if MIN_VERSION_base(4,0,0)+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#else+catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a+#endif++#else+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#endif+catchIO = Exception.catch++-- |The package version.+version :: Version+version = Version [0,1,0,0] []++-- |If the argument is a filename, the result is the name of a corresponding+-- file on the system on which the program is running, if the file were listed+-- in the @data-files@ field of the package's Cabal package description file.+-- No check is performed that the given filename is listed in that field.+getDataFileName :: FilePath -> IO FilePath+getDataFileName name = do+  dir <- getDataDir+  return (dir `joinFileName` name)++-- |The location of the directory specified by Cabal's @--bindir@ option (where+-- executables that the user might invoke are installed). This can be overridden+-- at runtime using the environment variable test_bindir.+getBinDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--libdir@ option (where+-- object libraries are installed). This can be overridden at runtime using the+-- environment variable test_libdir.+getLibDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--dynlibdir@ option+-- (where dynamic libraries are installed). This can be overridden at runtime+-- using the environment variable test_dynlibdir.+getDynLibDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--datadir@ option (where+-- architecture-independent data files are installed). This can be overridden at+-- runtime using the environment variable test_datadir.+getDataDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--libexedir@ option+-- (where executables that are not expected to be invoked directly by the user+-- are installed). This can be overridden at runtime using the environment+-- variable test_libexedir.+getLibexecDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--sysconfdir@ option+-- (where configuration files are installed). This can be overridden at runtime+-- using the environment variable test_sysconfdir.+getSysconfDir :: IO FilePath+++++bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath+bindir     = "/home/hugin/.cabal/bin"+libdir     = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.14.1-ade7/test-0.1.0.0-inplace"+dynlibdir  = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.14.1-ade7"+datadir    = "/home/hugin/.cabal/share/x86_64-linux-ghc-9.14.1-ade7/test-0.1.0.0"+libexecdir = "/home/hugin/.cabal/libexec/x86_64-linux-ghc-9.14.1-ade7/test-0.1.0.0"+sysconfdir = "/home/hugin/.cabal/etc"++getBinDir     = catchIO (getEnv "test_bindir")     (\_ -> return bindir)+getLibDir     = catchIO (getEnv "test_libdir")     (\_ -> return libdir)+getDynLibDir  = catchIO (getEnv "test_dynlibdir")  (\_ -> return dynlibdir)+getDataDir    = catchIO (getEnv "test_datadir")    (\_ -> return datadir)+getLibexecDir = catchIO (getEnv "test_libexecdir") (\_ -> return libexecdir)+getSysconfDir = catchIO (getEnv "test_sysconfdir") (\_ -> return sysconfdir)++++joinFileName :: String -> String -> FilePath+joinFileName ""  fname = fname+joinFileName "." fname = fname+joinFileName dir ""    = dir+joinFileName dir@(c:cs) fname+  | isPathSeparator (lastChar c cs) = dir ++ fname+  | otherwise                       = dir ++ pathSeparator : fname+ where+  -- We do not use Data.List.NonEmpty.last, as that would limit the module to+  -- base >= 4.9.0.0 (GHC >= 8.0.1).+  lastChar x [] = x+  lastChar _ (x:xs) = lastChar x xs++pathSeparator :: Char+pathSeparator = '/'++isPathSeparator :: Char -> Bool+isPathSeparator c = c == '/'
+ plugins/hls-eval-plugin/test/testdata/TDiffMultiline.expected.hs view
@@ -0,0 +1,6 @@+module TDiffMultiline where++-- |+-- >>> putStrLn "Hello," >> pure "World!"+-- Hello,+-- "World!"
+ plugins/hls-eval-plugin/test/testdata/TDiffMultiline.hs view
@@ -0,0 +1,6 @@+module TDiffMultiline where++-- |+-- >>> putStrLn "Hello," >> pure "World!"+-- Hello,+-- "World!"
+ plugins/hls-eval-plugin/test/testdata/TGHCOptionO1.expected.hs view
@@ -0,0 +1,6 @@+{-# OPTIONS_GHC -O1 #-}++module TGHCOptionO1 where++-- >>> 0.7+-- 0.7
+ plugins/hls-eval-plugin/test/testdata/TGHCOptionO1.hs view
@@ -0,0 +1,5 @@+{-# OPTIONS_GHC -O1 #-}++module TGHCOptionO1 where++-- >>> 0.7
plugins/hls-eval-plugin/test/testdata/TIO.expected.hs view
@@ -1,12 +1,15 @@--- IO expressions are supported, stdout/stderr output is ignored+-- 1. Support IO expressions+--+-- 2. Capture and show stdout module TIO where -import Control.Concurrent (threadDelay)+import           Control.Concurrent (threadDelay) -{--Does not capture stdout, returns value.+{- Capture stdout, returns value.+ Has a delay in order to show progress reporting.  >>> threadDelay 2000000 >> print "ABC" >> return "XYZ"+"ABC" "XYZ" -}
plugins/hls-eval-plugin/test/testdata/TIO.hs view
@@ -1,12 +1,13 @@--- IO expressions are supported, stdout/stderr output is ignored+-- 1. Support IO expressions+--+-- 2. Capture and show stdout module TIO where -import Control.Concurrent (threadDelay)+import           Control.Concurrent (threadDelay) -{--Does not capture stdout, returns value.+{- Capture stdout, returns value.+ Has a delay in order to show progress reporting.  >>> threadDelay 2000000 >> print "ABC" >> return "XYZ"-"XYZ" -}
+ plugins/hls-eval-plugin/test/testdata/TIOError.expected.hs view
@@ -0,0 +1,11 @@+-- 1. Support IO expressions+--+-- 2. Capture and show stderr+module TIOError where++import           Control.Exception++{-+>>> throwIO (TypeError "Doh")+Doh+-}
+ plugins/hls-eval-plugin/test/testdata/TIOError.hs view
@@ -0,0 +1,10 @@+-- 1. Support IO expressions+--+-- 2. Capture and show stderr+module TIOError where++import           Control.Exception++{-+>>> throwIO (TypeError "Doh")+-}
plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs view
@@ -38,8 +38,9 @@                                                        Recorder (..), Rules,                                                        WithPriority (..),                                                        defineNoDiagnostics,-                                                       getDefinition, hsep,-                                                       printName,+                                                       getDefinition, hscEnv,+                                                       hsep, printName,+                                                       printOutputableQualified,                                                        realSrcSpanToRange,                                                        shakeExtras,                                                        srcSpanToLocation,@@ -48,8 +49,7 @@ import           Development.IDE.Core.PositionMapping (PositionMapping,                                                        toCurrentPosition,                                                        toCurrentRange)-import           Development.IDE.Core.RuleTypes       (TcModuleResult (..),-                                                       TypeCheck (..))+import           Development.IDE.Core.RuleTypes import qualified Development.IDE.Core.Shake           as Shake import           Development.IDE.GHC.Compat           (FieldLabel (flSelector),                                                        FieldOcc (FieldOcc),@@ -71,9 +71,12 @@                                                        Var (varName),                                                        XXExprGhcTc (..),                                                        conLikeFieldLabels,-                                                       isGenerated, nameSrcSpan,+                                                       isGenerated, isSymOcc,+                                                       mkPrintUnqualifiedDefault,+                                                       nameOccName, nameSrcSpan,                                                        pprNameUnqualified,-                                                       recDotDot, unLoc)+                                                       recDotDot, tcg_rdr_env,+                                                       unLoc) import           Development.IDE.GHC.Compat.Core      (Extension (NamedFieldPuns),                                                        HsExpr (RecordCon, rcon_flds),                                                        HsRecField, LHsExpr,@@ -95,6 +98,7 @@                                                        insertNewPragma) import           GHC.Generics                         (Generic) import           GHC.Iface.Ext.Types                  (Identifier)+import           GHC.Utils.Outputable                 (NamePprCtx) import           Ide.Logger                           (Priority (..),                                                        cmapWithPrio, logWith,                                                        (<+>))@@ -177,7 +181,7 @@ codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeActionProvider ideState _ (CodeActionParams _ _ docId range _) = do   nfp <- getNormalizedFilePathE (docId ^. L.uri)-  CRR {crCodeActions, crCodeActionResolve, enabledExtensions} <- runActionE "ExplicitFields.CollectRecords" ideState $ useE CollectRecords nfp+  CRR {crCodeActions, crCodeActionResolve, enabledExtensions} <- runActionE "ExplicitFields.CodeAction" ideState $ useE CollectRecords nfp   -- All we need to build a code action is the list of extensions, and a int to   -- allow us to resolve it later.   let recordsWithUid = [ (RecordConversion uid conversionType, record)@@ -207,12 +211,19 @@ codeActionResolveProvider ideState pId ca uri uid = do   nfp <- getNormalizedFilePathE uri   pragma <- getFirstPragma pId ideState nfp-  CRR {crCodeActionResolve, nameMap, enabledExtensions} <- runActionE "ExplicitFields.CollectRecords" ideState $ useE CollectRecords nfp+  (CRR {crCodeActionResolve, nameMap, enabledExtensions}, pprCtx) <- runActionE "ExplicitFields.CodeActionResolve" ideState $ do+    cr <- useE CollectRecords nfp+    typechecked <- useE TypeCheck nfp+    hscEnvEq <- useE GhcSession nfp+    let reader = tcg_rdr_env (tmrTypechecked typechecked)+        pprCtx = mkPrintUnqualifiedDefault (hscEnv hscEnvEq) reader+    pure (cr, pprCtx)+   -- If we are unable to find the unique id in our IntMap of records, it means   -- that this resolve is stale.   record <- handleMaybe PluginStaleResolve $ IntMap.lookup uid crCodeActionResolve   -- We should never fail to render-  rendered <- handleMaybe (PluginInternalError "Failed to render") $ renderRecordInfoAsTextEdit nameMap record+  rendered <- handleMaybe (PluginInternalError "Failed to render") $ renderRecordInfoAsTextEdit nameMap pprCtx record   let shouldInsertNamedFieldPuns (RecordInfoApp _ _) = False       shouldInsertNamedFieldPuns _                   = True       whenMaybe True x  = x@@ -228,9 +239,13 @@ inlayHintDotdotProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdentifier uri, _range = visibleRange} = do   nfp <- getNormalizedFilePathE uri   pragma <- getFirstPragma pId state nfp-  runIdeActionE "ExplicitFields.CollectRecords" (shakeExtras state) $ do+  runIdeActionE "ExplicitFields.InlayHintDotDot" (shakeExtras state) $ do     (crr@CRR {crCodeActions, crCodeActionResolve}, pm) <- useWithStaleFastE CollectRecords nfp-    let -- Get all records with dotdot in current nfp+    (typechecked, _) <- useWithStaleFastE TypeCheck nfp+    (hscEnvEq, _) <- useWithStaleFastE GhcSession nfp+    let reader = tcg_rdr_env (tmrTypechecked typechecked)+        pprCtx = mkPrintUnqualifiedDefault (hscEnv hscEnvEq) reader+        -- Get all records with dotdot in current nfp         records = [ record                   | Just range <- [toCurrentRange pm visibleRange]                   , uid <- RangeMap.elementsInRange range crCodeActions@@ -240,12 +255,12 @@                     | record <- records                     , pos <- maybeToList $ fmap _start $ recordInfoToDotDotRange record ]     defnLocsList <- lift $ sequence locations-    pure $ InL $ mapMaybe (mkInlayHint crr pragma pm) defnLocsList+    pure $ InL $ mapMaybe (mkInlayHint crr pragma pprCtx pm) defnLocsList    where-     mkInlayHint :: CollectRecordsResult -> NextPragmaInfo -> PositionMapping -> (Maybe [(Location, Identifier)], RecordInfo) -> Maybe InlayHint-     mkInlayHint CRR {enabledExtensions, nameMap} pragma pm (defnLocs, record) =+     mkInlayHint :: CollectRecordsResult -> NextPragmaInfo -> NamePprCtx -> PositionMapping -> (Maybe [(Location, Identifier)], RecordInfo) -> Maybe InlayHint+     mkInlayHint CRR {enabledExtensions, nameMap} pragma pprCtx pm (defnLocs, record) =        let range = recordInfoToDotDotRange record-           textEdits = maybeToList (renderRecordInfoAsTextEdit nameMap record)+           textEdits = maybeToList (renderRecordInfoAsTextEdit nameMap pprCtx record)                     <> maybeToList (pragmaEdit enabledExtensions pragma)            names = renderRecordInfoAsDotdotLabelName record        in do@@ -278,32 +293,36 @@ inlayHintPosRecProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint inlayHintPosRecProvider _ state _pId InlayHintParams {_textDocument = TextDocumentIdentifier uri, _range = visibleRange} = do   nfp <- getNormalizedFilePathE uri-  runIdeActionE "ExplicitFields.CollectRecords" (shakeExtras state) $ do+  runIdeActionE "ExplicitFields.InlayHintPosRec" (shakeExtras state) $ do     (CRR {crCodeActions, nameMap, crCodeActionResolve}, pm) <- useWithStaleFastE CollectRecords nfp-    let records = [ record+    (typechecked, _) <- useWithStaleFastE TypeCheck nfp+    (hscEnvEq, _) <- useWithStaleFastE GhcSession nfp+    let reader = tcg_rdr_env (tmrTypechecked typechecked)+        pprCtx = mkPrintUnqualifiedDefault (hscEnv hscEnvEq) reader+        records = [ record                   | Just range <- [toCurrentRange pm visibleRange]                   , uid <- RangeMap.elementsInRange range crCodeActions                   , Just record <- [IntMap.lookup uid crCodeActionResolve] ]-    pure $ InL (concatMap (mkInlayHints nameMap pm) records)+    pure $ InL (concatMap (mkInlayHints nameMap pprCtx pm) records)    where-     mkInlayHints :: UniqFM Name [Name] -> PositionMapping -> RecordInfo -> [InlayHint]-     mkInlayHints nameMap pm record@(RecordInfoApp _ (RecordAppExpr sat _ fla)) =+     mkInlayHints :: UniqFM Name [Name] -> NamePprCtx -> PositionMapping -> RecordInfo -> [InlayHint]+     mkInlayHints nameMap pprCtx pm record@(RecordInfoApp _ (RecordAppExpr sat _ fla)) =        -- Only create inlay hints for fully saturated constructors        case sat of-         Saturated -> let textEdits = renderRecordInfoAsTextEdit nameMap record-                      in mapMaybe (mkInlayHint textEdits pm) fla+         Saturated -> let textEdits = renderRecordInfoAsTextEdit nameMap pprCtx record+                      in mapMaybe (mkInlayHint textEdits pprCtx pm) fla          Unsaturated -> []-     mkInlayHints _ _ _ = []+     mkInlayHints _ _ _ _ = [] -     mkInlayHint :: Maybe TextEdit -> PositionMapping -> (Located FieldLabel, HsExpr GhcTc) -> Maybe InlayHint-     mkInlayHint te pm (label, _) =+     mkInlayHint :: Maybe TextEdit -> NamePprCtx -> PositionMapping -> (Located FieldLabel, HsExpr GhcTc) -> Maybe InlayHint+     mkInlayHint te pprCtx pm (label, _) =        let (name, loc) = ((flSelector . unLoc) &&& (srcSpanToLocation . getLoc)) label            fieldDefLoc = srcSpanToLocation (nameSrcSpan name)        in do          (Location _ recRange) <- loc          currentStart <- toCurrentPosition pm (_start recRange)          pure InlayHint { _position = currentStart-                        , _label = InR $ pure (mkInlayHintLabelPart name fieldDefLoc)+                        , _label = InR $ pure (mkInlayHintLabelPart pprCtx name fieldDefLoc)                         , _kind = Nothing -- neither a type nor a parameter                         , _textEdits = Just (maybeToList te) -- same as CodeAction                         , _tooltip = Just $ InL (mkTitle [] RecordTraditionalSyntaxConversion) -- same as CodeAction@@ -312,7 +331,9 @@                         , _data_ = Nothing                         } -     mkInlayHintLabelPart name loc = InlayHintLabelPart (printFieldName (pprNameUnqualified name) <> "=") Nothing loc Nothing+     mkInlayHintLabelPart pprCtx name loc = InlayHintLabelPart (wrappedIfSymOcc rendered name <> "=") Nothing loc Nothing+       where+         rendered = printFieldName pprCtx (pprNameUnqualified name)  mkTitle :: [Extension] -> RecordConversionType -> Text mkTitle exts = \case@@ -445,10 +466,12 @@   deriving (Generic)  instance Pretty RecordInfo where-  pretty (RecordInfoPat ss p) = pretty (printFieldName ss) <> ":" <+> pretty (printOutputable p)-  pretty (RecordInfoCon ss e) = pretty (printFieldName ss) <> ":" <+> pretty (printOutputable e)-  pretty (RecordInfoApp ss (RecordAppExpr _ _ fla))-    = pretty (printFieldName ss) <> ":" <+> hsep (map (pretty . printOutputable) fla)+  pretty rec = case rec of+    (RecordInfoPat ss p) -> formatSrcSpan ss <+> pretty (printOutputable p)+    (RecordInfoCon ss e) -> formatSrcSpan ss <+> pretty (printOutputable e)+    (RecordInfoApp ss (RecordAppExpr _ _ fla)) -> formatSrcSpan ss <+> hsep (map (pretty . printOutputable) fla)+   where+    formatSrcSpan ss = pretty (stripOccNamePrefix (printOutputable ss)) <> ":"  recordInfoToRange :: RecordInfo -> Range recordInfoToRange (RecordInfoPat ss _) = realSrcSpanToRange ss@@ -460,10 +483,10 @@ recordInfoToDotDotRange (RecordInfoCon _ (RecordCon _ _ flds)) = srcSpanToRange . getLoc =<< rec_dotdot flds recordInfoToDotDotRange _ = Nothing -renderRecordInfoAsTextEdit :: UniqFM Name [Name] -> RecordInfo -> Maybe TextEdit-renderRecordInfoAsTextEdit names (RecordInfoPat ss pat) = TextEdit (realSrcSpanToRange ss) <$> showRecordPat names pat-renderRecordInfoAsTextEdit _ (RecordInfoCon ss expr) = TextEdit (realSrcSpanToRange ss) <$> showRecordCon expr-renderRecordInfoAsTextEdit _ (RecordInfoApp ss appExpr) = TextEdit (realSrcSpanToRange ss) <$> showRecordApp appExpr+renderRecordInfoAsTextEdit :: UniqFM Name [Name] -> NamePprCtx -> RecordInfo -> Maybe TextEdit+renderRecordInfoAsTextEdit names pprCtx (RecordInfoPat ss pat) = TextEdit (realSrcSpanToRange ss) <$> showRecordPat names pprCtx pat+renderRecordInfoAsTextEdit _ pprCtx (RecordInfoCon ss expr) = TextEdit (realSrcSpanToRange ss) <$> showRecordCon pprCtx expr+renderRecordInfoAsTextEdit _ pprCtx (RecordInfoApp ss appExpr) = TextEdit (realSrcSpanToRange ss) <$> showRecordApp pprCtx appExpr  renderRecordInfoAsDotdotLabelName :: RecordInfo -> Maybe [Name] renderRecordInfoAsDotdotLabelName (RecordInfoPat _ pat)  = showRecordPatFlds pat@@ -553,9 +576,8 @@     -- explained above).     puns' = map (mapLoc (\fld -> fld { hfbPun = True })) puns --showRecordPat :: Outputable (Pat GhcTc) => UniqFM Name [Name] -> Pat GhcTc -> Maybe Text-showRecordPat names = fmap printFieldName . mapConPatDetail (\case+showRecordPat :: Outputable (Pat GhcTc) => UniqFM Name [Name] -> NamePprCtx -> Pat GhcTc -> Maybe Text+showRecordPat names pprCtx = fmap (printFieldName pprCtx) . mapConPatDetail (\case   RecCon flds -> Just $ RecCon (preprocessRecordPat names flds)   _           -> Nothing) @@ -576,11 +598,11 @@     getFieldName = getOccName . unLoc . hfbLHS . unLoc showRecordPatFlds _ = Nothing -showRecordCon :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe Text-showRecordCon expr@(RecordCon _ _ flds) =-  Just $ printOutputable $+showRecordCon :: Outputable (HsExpr (GhcPass c)) => NamePprCtx -> HsExpr (GhcPass c) -> Maybe Text+showRecordCon pprCtx expr@(RecordCon _ _ flds) =+  Just $ printOutputableQualified pprCtx $     expr { rcon_flds = preprocessRecordCon flds }-showRecordCon _ = Nothing+showRecordCon _ _ = Nothing  showRecordConFlds :: p ~ GhcTc => HsExpr p -> Maybe [Name] showRecordConFlds (RecordCon _ _ flds) =@@ -591,12 +613,14 @@     getFieldName = getVarName . unLoc . hfbRHS . unLoc showRecordConFlds _ = Nothing -showRecordApp :: RecordAppExpr -> Maybe Text-showRecordApp (RecordAppExpr _ recConstr fla)-  = Just $ printOutputable recConstr <>  " { "+showRecordApp :: NamePprCtx -> RecordAppExpr -> Maybe Text+showRecordApp pprCtx (RecordAppExpr _ recConstr fla)+  = Just $ printOutputableQualified pprCtx recConstr <>  " { "          <> T.intercalate ", " (showFieldWithArg <$> fla)          <> " }"-  where showFieldWithArg (field, arg) = printFieldName field <> " = " <> printOutputable arg+  where+    showFieldWithArg (flSelector . unLoc -> name, arg) =+          wrappedIfSymOcc (printFieldName pprCtx (pprNameUnqualified name)) name <> " = " <> printOutputableQualified pprCtx arg  collectRecords :: GenericQ [RecordInfo] collectRecords = everythingBut (<>) (([], False) `mkQ` ignoreGenerated `extQ` getRecPatterns `extQ` getRecCons)@@ -689,6 +713,9 @@       [ RecordInfoPat realSpan' (unLoc pat) | RealSrcSpan realSpan' _ <- [ getLoc pat ]] getRecPatterns _ = ([], False) -printFieldName :: Outputable a => a -> Text-printFieldName = stripOccNamePrefix . printOutputable+printFieldName :: Outputable a => NamePprCtx -> a -> Text+printFieldName pprCtx = stripOccNamePrefix . printOutputableQualified pprCtx +wrappedIfSymOcc :: Text -> Name -> Text+wrappedIfSymOcc rendered name | isSymOcc (nameOccName name) = "(" <> rendered <> ")"+                              | otherwise                   = rendered
plugins/hls-explicit-record-fields-plugin/test/Main.hs view
@@ -29,7 +29,7 @@     , mkExpansionTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32     , mkExpansionTest "Mixed" "Mixed" 14 10 14 37     , mkExpansionTest "Construction" "Construction" 16 5 16 15-    , mkConversionTest "PositionalConstruction" "PositionalConstruction" 15 5 15 15+    , mkConversionTest "PositionalConstruction" "PositionalConstruction" 17 5 17 15     , mkExpansionTest "HsExpanded1" "HsExpanded1" 17 10 17 20     , mkExpansionTest "HsExpanded2" "HsExpanded2" 23 10 23 22     , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52@@ -38,8 +38,10 @@     , mkTestNoAction "Prefix" "Prefix" 10 11 10 28     , mkTestNoAction "PartiallyAppliedCon" "PartiallyAppliedCon" 7 8 7 12     , mkConversionTest "PolymorphicRecordConstruction" "PolymorphicRecordConstruction" 15 5 15 15+    , mkConversionTest "QualifiedPositionalConstruction" "QualifiedPositionalConstruction" 9 10 9 15     , mkConversionTest "CursorAwarePositional" "CursorPositional" 15 26 15 34     , mkExpansionTest "CursorAwareRecords" "CursorRecords" 9 40 9 40+    , mkConversionTest "UnicodeStrings" "UnicodeStrings" 10 12 10 17     ]   , testGroup "inlay hints"     [ mkInlayHintsTest "Construction" Nothing 16 $ \ih -> do@@ -77,30 +79,37 @@                         , _paddingLeft = Just True                         }] -    , mkInlayHintsTest "PositionalConstruction" Nothing 15 $ \ih -> do+    , mkInlayHintsTest "PositionalConstruction" Nothing 17 $ \ih -> do         let mkLabelPart' = mkLabelPartOffsetLengthSub1 "PositionalConstruction"         foo <- mkLabelPart' 5 4 "foo="         bar <- mkLabelPart' 6 4 "bar="         baz <- mkLabelPart' 7 4 "baz="+        sym <- mkLabelPart' 8 4 "(><)="         (@?=) ih-          [ defInlayHint { _position = Position 15 11+          [ defInlayHint { _position = Position 17 11                          , _label = InR [ foo ]-                         , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ]+                         , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c, (><) = d }" 17 5 18 ]                          , _tooltip = Just $ InL "Convert to traditional record syntax"                          , _paddingLeft = Nothing                          }-          , defInlayHint { _position = Position 15 13+          , defInlayHint { _position = Position 17 13                          , _label = InR [ bar ]-                         , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ]+                         , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c, (><) = d }" 17 5 18 ]                          , _tooltip = Just $ InL "Convert to traditional record syntax"                          , _paddingLeft = Nothing                          }-          , defInlayHint { _position = Position 15 15+          , defInlayHint { _position = Position 17 15                          , _label = InR [ baz ]-                         , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ]+                         , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c, (><) = d }" 17 5 18 ]                          , _tooltip = Just $ InL "Convert to traditional record syntax"                          , _paddingLeft = Nothing                          }+          , defInlayHint { _position = Position 17 17+                         , _label = InR [ sym ]+                         , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c, (><) = d }" 17 5 18 ]+                         , _tooltip = Just $ InL "Convert to traditional record syntax"+                         , _paddingLeft = Nothing+                         }           ]     , mkInlayHintsTest "PositionalConstructionDuplicateRecordFields" Nothing 15 $ \ih -> do         let mkLabelPart' = mkLabelPartOffsetLengthSub1 "PositionalConstructionDuplicateRecordFields"@@ -290,6 +299,24 @@           , defInlayHint { _position = Position 15 15                          , _label = InR [ baz ]                          , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ]+                         , _tooltip = Just $ InL "Convert to traditional record syntax"+                         , _paddingLeft = Nothing+                         }+          ]+    , mkInlayHintsTest "UnicodeStrings" Nothing 10 $ \ih -> do+        let mkLabelPart' = mkLabelPartOffsetLengthSub1 "UnicodeStrings"+        name  <- mkLabelPart' 5 4 "αβγa="+        count <- mkLabelPart' 6 4 "count="+        (@?=) ih+          [ defInlayHint { _position = Position 10 18+                         , _label = InR [ name ]+                         , _textEdits = Just [ mkLineTextEdit "MyRec { αβγa = \"αβγ\", count = 42 }" 10 12 26 ]+                         , _tooltip = Just $ InL "Convert to traditional record syntax"+                         , _paddingLeft = Nothing+                         }+          , defInlayHint { _position = Position 10 24+                         , _label = InR [ count ]+                         , _textEdits = Just [ mkLineTextEdit "MyRec { αβγa = \"αβγ\", count = 42 }" 10 12 26 ]                          , _tooltip = Just $ InL "Convert to traditional record syntax"                          , _paddingLeft = Nothing                          }
plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstruction.expected.hs view
@@ -6,6 +6,7 @@   { foo :: Int   , bar :: Int   , baz :: Char+  , (><) :: Int   }  convertMe :: () -> MyRec@@ -13,4 +14,5 @@   let a = 3       b = 5       c = 'a'-  in MyRec { foo = a, bar = b, baz = c }+      d = 8+  in MyRec { foo = a, bar = b, baz = c, (><) = d }
plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstruction.hs view
@@ -6,6 +6,7 @@   { foo :: Int   , bar :: Int   , baz :: Char+  , (><) :: Int   }  convertMe :: () -> MyRec@@ -13,4 +14,5 @@   let a = 3       b = 5       c = 'a'-  in MyRec a b c+      d = 8+  in MyRec a b c d
+ plugins/hls-explicit-record-fields-plugin/test/testdata/QualifiedPositionalConstruction.expected.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE Haskell2010 #-}++module QualifiedPositionalConstruction where++import qualified Data.Foldable as Foldable++data Foo = Foo { bar :: [Int] }++foo :: Foo+foo = Foo { bar = (Foldable.toList [1, 2, 3]) }
+ plugins/hls-explicit-record-fields-plugin/test/testdata/QualifiedPositionalConstruction.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE Haskell2010 #-}++module QualifiedPositionalConstruction where++import qualified Data.Foldable as Foldable++data Foo = Foo { bar :: [Int] }++foo :: Foo+foo = Foo (Foldable.toList [1, 2, 3])
+ plugins/hls-explicit-record-fields-plugin/test/testdata/UnicodeStrings.expected.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE Haskell2010 #-}++module UnicodeStrings where++data MyRec = MyRec+  { αβγa  :: String+  , count :: Int+  }++convertMe :: MyRec+convertMe = MyRec { αβγa = "αβγ", count = 42 }
+ plugins/hls-explicit-record-fields-plugin/test/testdata/UnicodeStrings.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE Haskell2010 #-}++module UnicodeStrings where++data MyRec = MyRec+  { αβγa  :: String+  , count :: Int+  }++convertMe :: MyRec+convertMe = MyRec "αβγ" 42
+ plugins/hls-export-plugin/src/Ide/Plugin/Export.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE RecordWildCards #-}++module Ide.Plugin.Export (descriptor) where++import           Control.Applicative              ((<|>))+import           Control.Concurrent.STM           (atomically)+import           Control.Lens+import           Control.Monad.IO.Class           (liftIO)+import           Data.Maybe                       (isJust, isNothing)+import           Data.Text                        (Text)+import qualified Data.Text                        as T+import           Data.Text.Utf16.Rope.Mixed       (Rope)+import           Development.IDE+import           Development.IDE.Core.PluginUtils (runActionE, useE)+import           Development.IDE.Core.Shake       (getDiagnostics)+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat.Error (_TcRnUnusedTopBind,+                                                   msgEnvelopeErrorL)+import qualified GHC.LanguageExtensions.Type      as LangExt (Extension (..))+import           Ide.Plugin.Error                 (getNormalizedFilePathE)+import           Ide.Plugin.Export.Cursor+import           Ide.Plugin.Export.ExactPrint+import           Ide.Plugin.Export.Exports+import           Ide.Plugin.Export.Utils+import           Ide.Types+import qualified Ide.Types                        as Ide+import qualified Language.LSP.Protocol.Lens       as L+import           Language.LSP.Protocol.Message    (Method (..), SMethod (..))+import           Language.LSP.Protocol.Types++descriptor :: PluginId -> PluginDescriptor IdeState+descriptor plId =+  let exportHandlers = mkPluginHandler SMethod_TextDocumentCodeAction quickCodeActionHandlers+  in (defaultPluginDescriptor plId "Code actions for module export lists")+    { Ide.pluginHandlers = exportHandlers+    }++quickCodeActionHandlers :: PluginMethodHandler IdeState Method_TextDocumentCodeAction+quickCodeActionHandlers state _plId (CodeActionParams _ _ doc range _) = do+  let uri = doc ^. L.uri+  nfp <- getNormalizedFilePathE uri+  (ps, isCpp, mUnder, msrc) <- runActionE "Export.getInputs" state $ do+    pm <- useE GetParsedModuleWithComments nfp+    let ps = pm_parsed_source pm+        isCpp = xopt LangExt.Cpp (ms_hspp_opts (pm_mod_summary pm))+        mUnder = if isExplicit ps then locateUnderCursor (range ^. L.start) ps else Nothing+    -- Only a CPP module about to be offered an action needs the buffer (to find+    -- directives in the export list), so skip the fetch otherwise.+    msrc <- if isJust mUnder && isCpp then snd <$> useE GetFileContents nfp else pure Nothing+    pure (ps, isCpp, mUnder, msrc)+  case mUnder of+    -- A CPP module whose buffer we could not read may have directives in the+    -- export list that a reprint would silently erase. Withhold rather than risk+    -- it.+    Just under | not (isCpp && isNothing msrc) -> do+      -- The names GHC flags as defined-but-unused. Attach the action to the+      -- unused diagnostics as well.+      unusedDiags <- liftIO $ unusedTopBindDiagnostics state nfp+      pure . InL . map InR $+        [ ca+        | Just (verb, title, edits) <-+            [ addAction msrc under ps+            , removeAction msrc under ps+            ]+        , let fixes = [ d | d <- unusedDiags, locateUnderCursor (d ^. L.range . L.start) ps == Just under ]+              ca = mkAction (verb <> " `" <> title <> "`")+                     & L.edit ?~ singleFileEdit uri edits+                     & L.diagnostics .~ (if null fixes then Nothing else Just fixes)+        ]+    _ -> pure (InL [])++-- | The LSP diagnostics for names GHC reports as unused top-level definitions.+unusedTopBindDiagnostics :: IdeState -> NormalizedFilePath -> IO [Diagnostic]+unusedTopBindDiagnostics state nfp = do+  diags <- atomically $ getDiagnostics state+  pure [ fdLspDiagnostic d | d <- diags, fdFilePath d == nfp, isUnusedTopBind d ]+  where+    isUnusedTopBind =+      has (fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnUnusedTopBind)++addAction :: Maybe Rope -> UnderCursor -> ParsedSource -> Maybe (Text, Text, [TextEdit])+addAction msrc under ps = case under of+  Decl flavor n+    | n `isExported` ps -> Nothing+    | otherwise -> ("Export", T.pack (printRdrName n),) <$> addExport msrc ps (mkExportIE flavor n)+  Constructor t c+    | c `isExported` ps -> Nothing+    | otherwise ->+        ("Export", T.pack (printRdrName t) <> "(" <> T.pack (printRdrName c) <> ")",)+          <$> addConstructorExport msrc t c ps+  Header -> Nothing++removeAction :: Maybe Rope -> UnderCursor -> ParsedSource -> Maybe (Text, Text, [TextEdit])+removeAction msrc under ps = case under of+  Decl _ n -> ("Unexport", T.pack (printRdrName n),) <$> removeExport msrc ps n+  -- A bare uppercase entry denotes the type, so when the constructor shares the+  -- type's name, skip the standalone-removal fallback.+  Constructor t c ->+    ("Unexport", T.pack (printRdrName c),) <$>+      (removeConstructorExport msrc t c ps+        <|> if rdrNameFS c == rdrNameFS t then Nothing else removeExport msrc ps c)+  Header -> Nothing
+ plugins/hls-export-plugin/src/Ide/Plugin/Export/Cursor.hs view
@@ -0,0 +1,89 @@+module Ide.Plugin.Export.Cursor+  ( ExportFlavor (..)+  , UnderCursor (..)+  , locateUnderCursor+  ) where++import           Control.Applicative        ((<|>))+import           Data.Foldable              (toList)+import           Data.List                  (find)+import           Data.Maybe+import           Development.IDE+import           Development.IDE.GHC.Compat++-- | How a top-level entity is rendered in an export list.+data ExportFlavor+  = ExportName     -- ^ bare @x@. An operator is parenthesized with no @type@ keyword. Values and type synonyms.+  | ExportPattern  -- ^ @pattern X@.+  | ExportFamily   -- ^ bare @T@. An operator becomes @type (:<)@. Type and data families.+  | ExportAll      -- ^ @T(..)@. An operator becomes @type (:<)(..)@. Data, newtype, and class.+  deriving Eq++data UnderCursor+  = Decl ExportFlavor RdrName+  | Constructor RdrName RdrName+  | Header+  deriving Eq++locateUnderCursor :: Position -> ParsedSource -> Maybe UnderCursor+locateUnderCursor pos ps = classifyHeader pos (unLoc ps) <|> classifyInDecl+  where+    classifyInDecl = do+      L _ decl <- find (\(L l _) -> pos `isInsideSrcSpan` locA l) (hsmodDecls (unLoc ps))+      classifyDecl pos decl++-- | Match column-free so cursor anywhere on the @module ... where@ line counts.+classifyHeader :: Position -> HsModule GhcPs -> Maybe UnderCursor+classifyHeader pos mod = inName <|> inExports+  where+    isIn :: HasSrcSpan a => Maybe a -> Maybe UnderCursor+    isIn el = el >>= \n -> if pos `isInsideSrcSpanLines` getLoc n then Just Header else Nothing+    inName = isIn $ hsmodName mod+    inExports = isIn $ hsmodExports mod++-- | Line-based span containment, column-agnostic.+isInsideSrcSpanLines :: Position -> SrcSpan -> Bool+Position l _ `isInsideSrcSpanLines` r = case srcSpanToRange r of+  Just (Range (Position sl _) (Position el _)) -> sl <= l && l <= el+  _                                            -> False++-- | The exportable entities a top-level declaration defines, each with its+-- export flavor and located name.+declEntities :: HsDecl GhcPs -> [(ExportFlavor, LIdP GhcPs)]+declEntities = \case+  ValD _ (PatSynBind _ PSB {psb_id = lname}) -> [(ExportPattern, lname)]+  ValD _ FunBind {fun_id = lname}            -> [(ExportName, lname)]+  TyClD _ DataDecl {tcdLName = lname}        -> [(ExportAll, lname)]+  TyClD _ ClassDecl {tcdLName = lname}       -> [(ExportAll, lname)]+  TyClD _ SynDecl {tcdLName = lname}         -> [(ExportName, lname)]+  TyClD _ FamDecl {tcdFam = fam}             -> [(ExportFamily, fdLName fam)]+  _                                          -> []++classifyDecl :: Position -> HsDecl GhcPs -> Maybe UnderCursor+classifyDecl pos decl =+      listToMaybe [Decl flavor (unLoc n) | (flavor, n) <- declEntities decl, onName n]+  <|> typeSigUnderCursor+  <|> constructorUnderDecl+  where+    onName (L l _) = pos `isInsideSrcSpan` locA l+    -- A signature is not a definition (so not in 'declEntities'), but its name+    -- is still a valid place to invoke the export action from.+    typeSigUnderCursor = case decl of+      SigD _ (TypeSig _ names _) -> Decl ExportName . unLoc <$> find onName names+      _                          -> Nothing+    constructorUnderDecl = case decl of+      TyClD _ DataDecl {tcdLName = lname, tcdDataDefn = HsDataDefn {dd_cons = cons}}+        -> Constructor (unLoc lname) <$> constructorUnderCursor pos cons+      _ -> Nothing++constructorUnderCursor :: Position -> DataDefnCons (LConDecl GhcPs) -> Maybe RdrName+constructorUnderCursor pos cons =+  listToMaybe . mapMaybe nameAt $ extract_cons cons+  where+    nameAt (L _ cd) =+      listToMaybe [n | L l n <- conDeclNames cd, pos `isInsideSrcSpan` locA l]++    conDeclNames = \case+      ConDeclH98 {con_name = lname} -> [lname]+      ConDeclGADT {con_names = lnames} -> toList lnames+      _ -> []
+ plugins/hls-export-plugin/src/Ide/Plugin/Export/ExactPrint.hs view
@@ -0,0 +1,353 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Ide.Plugin.Export.ExactPrint+  ( LExportList+  , mkExportIE+  , appendIE+  , removeMatchingIE+  , addCtorUnderParent+  , removeCtorUnderParent+  , printExportList+  , printIE+  , freshCtorEntry+  ) where++import           Control.Lens                              (_last, over)+import           Data.Bifunctor                            (first)+import           Data.List                                 (mapAccumL)+import           Data.List.NonEmpty                        (NonEmpty (..))+import           Data.Text                                 (Text)+import qualified Data.Text                                 as T+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Orphans               ()+#if MIN_VERSION_ghc(9,11,0)+import           GHC                                       (DeltaPos (..),+                                                            TrailingAnn (..))+#elif MIN_VERSION_ghc(9,9,0)+import           GHC                                       (DeltaPos (..),+                                                            LocatedL,+                                                            NoAnn (..),+                                                            TrailingAnn (..),+                                                            noAnn)+#else+import           GHC                                       (DeltaPos (..),+                                                            LocatedL,+                                                            TrailingAnn (..),+                                                            addAnns,+                                                            emptyComments,+                                                            noAnn)+#endif++import           Language.Haskell.GHC.ExactPrint           (addComma,+                                                            exactPrint,+                                                            getEntryDP,+                                                            setEntryDP)++#if MIN_VERSION_ghc(9,11,0)+import           GHC                                       (EpToken (..),+                                                            LocatedLI)+#else+import           GHC                                       (AddEpAnn (..))+#endif+import           Data.Maybe                                (listToMaybe)+import           Development.IDE.GHC.ExactPrint.Annotation (ensureTrailingComma,+                                                            epl, isCommaAnn,+                                                            parenthesizeName,+                                                            removeTrailingCommaAnn,+                                                            trailingAnns,+                                                            withTrailingComma)+import           GHC                                       (LocatedN)+import           Ide.Plugin.Export.Cursor                  (ExportFlavor (..))+import           Ide.Plugin.Export.Utils++-- | Located @[LIE GhcPs]@, the shape of an export list. Aliases either+-- 'LocatedL' (pre-9.12) or 'LocatedLI'.+#if MIN_VERSION_ghc(9,11,0)+type LExportList = LocatedLI [LIE GhcPs]+#else+type LExportList = LocatedL [LIE GhcPs]+#endif++mkExportIE :: ExportFlavor -> RdrName -> LIE GhcPs+mkExportIE flavor rdr = case flavor of+  ExportName    -> ieVar (mkWrappedName WrapPlain rdr)+  ExportPattern -> ieVar (mkWrappedName WrapPattern rdr)+  ExportFamily  -> mkTypeAbsIE' (mkWrappedName keywordWrap rdr)+  ExportAll     -> mkTypeAllIE' (mkWrappedName keywordWrap rdr)+  where+    keywordWrap+      | isSymOcc (rdrNameOcc rdr) = WrapType+      | otherwise                 = WrapPlain++ieVar :: LIEWrappedName GhcPs -> LIE GhcPs+ieVar w =+  reLocA $ L noSrcSpan $ IEVar+#if MIN_VERSION_ghc(9,8,0)+    Nothing+#else+    noExtField+#endif+    w+#if MIN_VERSION_ghc(9,9,0)+    Nothing+#endif++mkTypeAbsIE' :: LIEWrappedName GhcPs -> LIE GhcPs+mkTypeAbsIE' w =+  reLocA $ L noSrcSpan $ IEThingAbs+#if MIN_VERSION_ghc(9,11,0)+    Nothing+#elif MIN_VERSION_ghc(9,8,0)+    (Nothing, noAnn)+#else+    noAnn+#endif+    w+#if MIN_VERSION_ghc(9,9,0)+    Nothing+#endif++mkTypeAllIE' :: LIEWrappedName GhcPs -> LIE GhcPs+mkTypeAllIE' w =+  reLocA $ L noSrcSpan $ IEThingAll+#if MIN_VERSION_ghc(9,11,0)+    (Nothing, (EpTok (epl 1), EpTok (epl 0), EpTok (epl 0)))+#elif MIN_VERSION_ghc(9,9,0)+    ( Nothing+    , [ AddEpAnn AnnOpenP  (epl 1)+      , AddEpAnn AnnDotdot (epl 0)+      , AddEpAnn AnnCloseP (epl 0)+      ]+    )+#elif MIN_VERSION_ghc(9,8,0)+    ( Nothing+    , addAnns mempty+        [ AddEpAnn AnnOpenP  (epl 1)+        , AddEpAnn AnnDotdot (epl 0)+        , AddEpAnn AnnCloseP (epl 0)+        ]+        emptyComments+    )+#else+    (addAnns mempty+       [ AddEpAnn AnnOpenP  (epl 1)+       , AddEpAnn AnnDotdot (epl 0)+       , AddEpAnn AnnCloseP (epl 0)+       ]+       emptyComments)+#endif+    w+#if MIN_VERSION_ghc(9,9,0)+    Nothing+#endif++-- | @T(C1, C2, ...)@. The non-empty list is the child constructors.+mkTypeWithIE :: RdrName -> NonEmpty RdrName -> LIE GhcPs+mkTypeWithIE parent ctors =+  reLocA $ L noSrcSpan $ IEThingWith+#if MIN_VERSION_ghc(9,11,0)+    (Nothing, (EpTok (epl 1), NoEpTok, NoEpTok, EpTok (epl 0)))+#elif MIN_VERSION_ghc(9,9,0)+    (Nothing, [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)])+#elif MIN_VERSION_ghc(9,8,0)+    ( Nothing+    , addAnns mempty+        [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)]+        emptyComments+    )+#else+    (addAnns mempty+       [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)]+       emptyComments)+#endif+    (mkIEName parent)+    NoIEWildcard+    children+#if MIN_VERSION_ghc(9,9,0)+    Nothing+#endif+  where+    children = mkIEName c : map (first addComma . mkIEName) cs+    c :| cs = ctors++-- | Map over an @IEThingWith@'s listed constructors, a no-op for any other item.+overThingWithChildren :: ([LIEWrappedName GhcPs] -> [LIEWrappedName GhcPs]) -> IE GhcPs -> IE GhcPs+#if MIN_VERSION_ghc(9,9,0)+overThingWithChildren f (IEThingWith x n w cs docs) = IEThingWith x n w (f cs) docs+#else+overThingWithChildren f (IEThingWith x n w cs)      = IEThingWith x n w (f cs)+#endif+overThingWithChildren _ ie                          = ie++data WrapKind = WrapPlain | WrapPattern | WrapType++mkIEName :: RdrName -> LIEWrappedName GhcPs+mkIEName = mkWrappedName WrapPlain++-- | Wrap an 'RdrName' as an export item. Operators are parenthesized and any+-- @pattern@ or @type@ keyword is followed by a single space.+mkWrappedName :: WrapKind -> RdrName -> LIEWrappedName GhcPs+mkWrappedName kind rdr =+  reLocA $ L noSrcSpan $ case kind of+    WrapPlain   -> IEName noExtField plainName+    WrapPattern -> IEPattern keywordTok spacedName+    WrapType    -> IEType keywordTok spacedName+  where+    plainName = parenthesizeOperator (reLocA (L noSrcSpan rdr))+    spacedName = setEntryDP plainName (SameLine 1)+    keywordTok =+#if MIN_VERSION_ghc(9,11,0)+      EpTok (epl 0)+#else+      epl 0+#endif++parenthesizeOperator :: LocatedN RdrName -> LocatedN RdrName+parenthesizeOperator ln+  | isSymOcc (rdrNameOcc (unLoc ln)) = parenthesizeName ln+  | otherwise = ln++appendIE :: LIE GhcPs -> LExportList -> LExportList+appendIE item (L l items) = L l (fixLast items ++ [newItem (not (null items))])+  where+    newItem hasSibling =+      setEntryDP (first removeTrailingCommaAnn item) (SameLine (if hasSibling then 1 else 0))+    -- Reuse the comma that already separates the list's items. On a multiline+    -- leading comma list that comma carries a 'DifferentLine' delta, so the new+    -- separator lands on its own line instead of collapsing onto the last item.+    fixLast = over _last (first addSep)+    addSep = maybe ensureTrailingComma withTrailingComma (separatorComma items)++-- | The trailing comma that separates existing items, if the list has any.+separatorComma :: [LIE GhcPs] -> Maybe TrailingAnn+separatorComma items =+  listToMaybe [c | L ann _ <- items, c <- trailingAnns ann, isCommaAnn c]++-- | Drop the first element matching @p@. A removed head hands its entry delta+-- to the next element so the list keeps its start, and the new last element+-- loses its separator comma.+-- - @Nothing@ if nothing matches+-- - @Just []@ if the sole element was removed.+removeListItem+  :: (LocatedAn AnnListItem a -> Bool)+  -> [LocatedAn AnnListItem a]+  -> Maybe [LocatedAn AnnListItem a]+removeListItem p items = case break p items of+  (_, [])               -> Nothing+  (pre, removed : post) ->+    let survivors = case (pre, post) of+          ([], next : rest) -> setEntryDP next (getEntryDP removed) : rest+          _                 -> pre ++ post+     in Just (over _last (first removeTrailingCommaAnn) survivors)++removeMatchingIE :: (IE GhcPs -> Bool) -> LExportList -> Maybe LExportList+removeMatchingIE p (L l items) = L l <$> removeListItem (p . unLoc) items++-- | 'Nothing' iff @ctor@ is already exported (via @T(..)@ or @T(...,ctor,...)@).+addCtorUnderParent ::+  -- | parent+  RdrName ->+  -- | ctor+  RdrName ->+  LExportList ->+  Maybe LExportList+addCtorUnderParent parent ctor lst@(L l items) =+  case ctorExportEdit parent ctor items of+    AlreadyExported -> Nothing+    AppendParent    -> Just (appendIE newThing lst)+    UpgradeBare     -> Just (L l (map (transformParent (const (unLoc newThing))) items))+    AddChild        -> Just (L l (map (transformParent (addCtorChildren ctor)) items))+  where+    newThing = mkTypeWithIE parent (ctor :| [])+    transformParent f (L itemLoc ie)+      | parentNameIs (rdrNameFS parent) ie = L itemLoc (f ie)+      | otherwise = L itemLoc ie++-- | Append @ctor@ to an @IEThingWith@'s children, reusing the sibling separator+-- comma. No-op for other items.+addCtorChildren :: RdrName -> IE GhcPs -> IE GhcPs+addCtorChildren ctor = overThingWithChildren $ \cs ->+  let hasSibling = not (null cs)+      newChild = setEntryDP (mkIEName ctor) (SameLine (if hasSibling then 1 else 0))+   in (if hasSibling then map (first ensureTrailingComma) cs else cs) ++ [newChild]++-- | Remove @ctor@ from the export entries listing it under @parent@, or+-- 'Nothing' if none does. Removing the last child downgrades @T(ctor)@ to @T@.+removeCtorUnderParent ::+  -- | parent+  RdrName ->+  -- | ctor+  RdrName ->+  LExportList ->+  Maybe LExportList+removeCtorUnderParent parent ctor (L l items)+  | edited    = Just (L l items')+  | otherwise = Nothing+  where+    (edited, items') = mapAccumL dropCtor False items+    parentFS = rdrNameFS parent+    ctorFS = rdrNameFS ctor+    isCtor = (== ctorFS) . lieWrappedNameFS++    dropCtor changed item@(L itemLoc ie)+      | parentNameIs parentFS ie+      , Just children <- ieThingWithChildren ie+      , Just kept <- removeListItem isCtor children+      = (True, L itemLoc (rebuild ie kept))+      | otherwise = (changed, item)++    -- An empty child list means ctor was the only child, so collapse T(ctor)+    -- to a bare T.+    rebuild ie []   = downgradeToAbs ie+    rebuild ie kept = overThingWithChildren (const kept) ie++    -- Reuse the head so type/operator wrapping survives, e.g. `type (:<)(C)`+    -- becomes `type (:<)`.+    downgradeToAbs ie = case ieThingWithHead ie of+      Just n  -> unLoc (mkTypeAbsIE' (setEntryDP n (SameLine 0)))+      Nothing -> ie++printExportList :: LExportList -> Text+printExportList l = T.pack (exactPrint (setEntryDP l (SameLine 0)))++-- | Exactprint a single item, without the surrounding list layout. Dropping+-- the trailing comma keeps a spliced item from carrying it into text that+-- already supplies its own.+printIE :: LIE GhcPs -> Text+printIE item = T.pack (exactPrint (setEntryDP (first removeTrailingCommaAnn item) (SameLine 0)))++-- | A fresh @T(ctor)@ export entry rendered as text, or 'Nothing' if @ctor@ is+-- already exported in the parsed list. Under CPP this adds a standalone entry so+-- the splice never reprints an existing @T(...)@ span, which can straddle a+-- directive.+freshCtorEntry :: RdrName -> RdrName -> [LIE GhcPs] -> Maybe Text+freshCtorEntry parent ctor items = case ctorExportEdit parent ctor items of+  AlreadyExported -> Nothing+  _               -> Just (printIE (mkTypeWithIE parent (ctor :| [])))++-- | How to add @ctor@ to an export list so its parent type @T@ exports it.+data CtorEdit+  = AlreadyExported  -- ^ @T(..)@ or @T(..., ctor, ...)@, nothing to do+  | AppendParent     -- ^ no entry for @T@ yet, add a fresh @T(ctor)@+  | UpgradeBare      -- ^ replace the bare @T@ entry with @T(ctor)@+  | AddChild         -- ^ add @ctor@ to the existing @T(...)@ entry++-- | Decide how @ctor@ should be added under @parent@, classifying the first+-- matching export item by its constructor-carrying shape.+ctorExportEdit :: RdrName -> RdrName -> [LIE GhcPs] -> CtorEdit+ctorExportEdit parent ctor = go+  where+    parentFS = rdrNameFS parent+    ctorFS = rdrNameFS ctor+    go [] = AppendParent+    go (L _ ie : rest)+      | parentNameIs parentFS ie = case ie of+          IEThingAll {} -> AlreadyExported+          IEThingAbs {} -> UpgradeBare+          _ | Just cs <- ieThingWithChildren ie ->+                if any ((== ctorFS) . lieWrappedNameFS) cs then AlreadyExported else AddChild+            | otherwise -> go rest+      | otherwise = go rest
+ plugins/hls-export-plugin/src/Ide/Plugin/Export/Exports.hs view
@@ -0,0 +1,84 @@+module Ide.Plugin.Export.Exports+  ( isExplicit+  , isExported+  , addExport+  , addConstructorExport+  , removeExport+  , removeConstructorExport+  ) where++import           Data.Maybe                         (isJust)+import           Data.Text                          (Text)+import           Data.Text.Utf16.Rope.Mixed         (Rope)+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Error          (srcSpanToRange)+import           Development.IDE.GHC.ExactPrint.CPP (spanHasCpp)+import           Ide.Plugin.Export.ExactPrint+import           Ide.Plugin.Export.Utils+import           Language.Haskell.GHC.ExactPrint    (makeDeltaAst)+import           Language.LSP.Protocol.Types++isExplicit :: ParsedSource -> Bool+isExplicit = isJust . hsmodExports . unLoc++-- | Also matches names appearing only as constructor children of an 'IEThingWith' parent.+isExported :: RdrName -> ParsedSource -> Bool+isExported n ps = case hsmodExports (unLoc ps) of+  Nothing          -> False+  Just (L _ items) -> any (covers . unLoc) items+  where+    nFS = rdrNameFS n+    covers ie = parentNameIs nFS ie || isInIE nFS ie++-- | Extract the export list and pick an edit strategy: splice surgically when+-- the span holds a CPP directive, otherwise reprint the whole transformed list.+withExportList+  :: Maybe Rope+  -> ParsedSource+  -> (LExportList -> Maybe LExportList)          -- ^ reprint transform+  -> (Range -> LExportList -> Maybe [TextEdit])  -- ^ list holds a directive+  -> Maybe [TextEdit]+withExportList msrc ps reprint onCpp = do+  exports <- hsmodExports (unLoc ps)+  full <- srcSpanToRange (getLoc exports)+  if spanHasCpp msrc full+    then onCpp full exports+    else do+      newList <- reprint (makeDeltaAst exports)+      Just [TextEdit full (printExportList newList)]++addExport :: Maybe Rope -> ParsedSource -> LIE GhcPs -> Maybe [TextEdit]+addExport msrc ps item =+  withExportList msrc ps (Just . appendIE item) $ \full _ ->+    Just [insertAfterOpen full (printIE item)]++addConstructorExport :: Maybe Rope -> RdrName -> RdrName -> ParsedSource -> Maybe [TextEdit]+addConstructorExport msrc parent ctor ps =+  withExportList msrc ps (addCtorUnderParent parent ctor) $ \full exports ->+    (\txt -> [insertAfterOpen full txt]) <$> freshCtorEntry parent ctor (unLoc exports)++-- | Splice @itemTxt@ in right after the opening paren with a trailing comma,+-- @( <itemTxt>, <existing> )@.+insertAfterOpen :: Range -> Text -> TextEdit+insertAfterOpen (Range (Position sl sc) _) itemTxt =+  TextEdit (Range pos pos) (" " <> itemTxt <> ",")+  where+    -- `sc` is the column of `(`, so insert just past it.+    pos = Position sl (sc + 1)++-- | Reprinting would drop the directives the parser stripped, so unexport is+-- declined when the export list holds a directive.+removeExport :: Maybe Rope -> ParsedSource -> RdrName -> Maybe [TextEdit]+removeExport msrc ps name =+  withExportList msrc ps (removeMatchingIE matches) declineUnderCpp+  where+    matches = parentNameIs (rdrNameFS name)++removeConstructorExport :: Maybe Rope -> RdrName -> RdrName -> ParsedSource -> Maybe [TextEdit]+removeConstructorExport msrc parent ctor ps =+  withExportList msrc ps (removeCtorUnderParent parent ctor) declineUnderCpp++-- | An 'onCpp' handler that declines: the edit has no safe surgical form, so it+-- is offered only when the list reprints cleanly.+declineUnderCpp :: Range -> LExportList -> Maybe [TextEdit]+declineUnderCpp _ _ = Nothing
+ plugins/hls-export-plugin/src/Ide/Plugin/Export/Utils.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE RecordWildCards #-}+module Ide.Plugin.Export.Utils where++import qualified Data.Map.Strict                 as Map+import           Data.Text                       (Text)+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat.Util+import           Language.LSP.Protocol.Types++rdrNameFS :: RdrName -> FastString+rdrNameFS = occNameFS . rdrNameOcc++ieParentName :: IE GhcPs -> Maybe RdrName+ieParentName e = case e of+#if MIN_VERSION_ghc(9,9,0)+  IEVar _ (L _ wn) _           -> Just (ieWrappedRdrName wn)+  IEThingAbs _ (L _ wn) _      -> Just (ieWrappedRdrName wn)+  IEThingAll _ (L _ wn) _      -> Just (ieWrappedRdrName wn)+  IEThingWith _ (L _ wn) _ _ _ -> Just (ieWrappedRdrName wn)+#else+  IEVar _ (L _ wn)             -> Just (ieWrappedRdrName wn)+  IEThingAbs _ (L _ wn)        -> Just (ieWrappedRdrName wn)+  IEThingAll _ (L _ wn)        -> Just (ieWrappedRdrName wn)+  IEThingWith _ (L _ wn) _ _   -> Just (ieWrappedRdrName wn)+#endif+  _                            -> Nothing++-- | The listed constructors of an @IEThingWith@ (@T(C1, C2)@), or 'Nothing' otherwise.+ieThingWithChildren :: IE GhcPs -> Maybe [LIEWrappedName GhcPs]+#if MIN_VERSION_ghc(9,9,0)+ieThingWithChildren (IEThingWith _ _ _ cs _) = Just cs+#else+ieThingWithChildren (IEThingWith _ _ _ cs)   = Just cs+#endif+ieThingWithChildren _                        = Nothing++-- | The head name of an @IEThingWith@, e.g. @T@ in @T(C1, C2)@.+ieThingWithHead :: IE GhcPs -> Maybe (LIEWrappedName GhcPs)+#if MIN_VERSION_ghc(9,9,0)+ieThingWithHead (IEThingWith _ n _ _ _) = Just n+#else+ieThingWithHead (IEThingWith _ n _ _)   = Just n+#endif+ieThingWithHead _                       = Nothing++ieWrappedRdrName :: IEWrappedName GhcPs -> RdrName+ieWrappedRdrName = \case+  IEName _ (L _ rdr)    -> rdr+  IEPattern _ (L _ rdr) -> rdr+  IEType _ (L _ rdr)    -> rdr+#if MIN_VERSION_ghc(9,11,0)+  IEDefault _ (L _ rdr) -> rdr+#endif+#if MIN_VERSION_ghc(9,13,0)+  IEData _ (L _ rdr)    -> rdr+#endif++-- | True when the export item's head name is the given 'FastString'.+parentNameIs :: FastString -> IE GhcPs -> Bool+parentNameIs fs = maybe False ((== fs) . rdrNameFS) . ieParentName++-- | The 'FastString' of a located wrapped name, e.g. an @IEThingWith@ child.+lieWrappedNameFS :: LIEWrappedName GhcPs -> FastString+lieWrappedNameFS = rdrNameFS . ieWrappedRdrName . unLoc++-- | True when @n@ is listed as a child constructor of an @IEThingWith@.+isInIE :: FastString -> IE GhcPs -> Bool+isInIE n = maybe False (any ((== n) . lieWrappedNameFS)) . ieThingWithChildren++singleFileEdit :: Uri -> [TextEdit] -> WorkspaceEdit+singleFileEdit uri edits = WorkspaceEdit (Just (Map.singleton uri edits)) Nothing Nothing++mkAction :: Text -> CodeAction+mkAction title = CodeAction {..}+  where+    _title = title+    _kind = Just CodeActionKind_RefactorRewrite+    _diagnostics = Nothing+    _isPreferred = Nothing+    _disabled = Nothing+    _edit = Nothing+    _command = Nothing+    _data_ = Nothing
+ plugins/hls-export-plugin/test/Main.hs view
@@ -0,0 +1,458 @@+module Main (main) where++import           Control.Lens               ((^.))+import           Data.Char                  (isSpace)+import           Data.Either                (rights)+import           Data.List                  (sort)+import           Data.Maybe                 (fromMaybe)+import qualified Data.Text                  as T+import           Ide.Plugin.Export          (descriptor)+import qualified Language.LSP.Protocol.Lens as L+import           System.FilePath            ((</>))+import           Test.Hls+import           Test.Hls.FileSystem        (copy, directProject,+                                             mkVirtualFileTree)++plugin :: PluginTestDescriptor ()+plugin = mkPluginTestDescriptor' descriptor "export"++testDataDir :: FilePath+testDataDir = "plugins" </> "hls-export-plugin" </> "test" </> "testdata"++-- | Open the named module in its own temporary single-file project, so each+-- test compiles only the file it needs and cannot pick up signals from a+-- sibling module.+runExport :: FilePath -> (TextDocumentIdentifier -> Session a) -> IO a+runExport = runExportWith []++-- | Like 'runExport' but also copies the named extra files into the project,+-- e.g. a header a CPP @#include@ pulls in next to the module.+runExportWith :: [FilePath] -> FilePath -> (TextDocumentIdentifier -> Session a) -> IO a+runExportWith extra hsFile act =+    runSessionWithTestConfig def+        { testDirLocation = Right (mkVirtualFileTree testDataDir (directProject hsFile <> map copy extra))+        , testPluginDescriptor = plugin+        } $ \_dir -> do+            doc <- openDoc hsFile "haskell"+            waitForKickDone+            act doc++codeActionTitles :: TextDocumentIdentifier -> Range -> Session [T.Text]+codeActionTitles doc range =+    sort . map (^. L.title) . rights . map toEither+        <$> getCodeActions doc range++executeByPrefix :: T.Text -> TextDocumentIdentifier -> Range -> Session ()+executeByPrefix prefix doc range = do+    actions <- rights . map toEither <$> getCodeActions doc range+    case filter (\ca -> prefix `T.isPrefixOf` (ca ^. L.title)) actions of+        (ca:_) -> executeCodeAction ca+        []     -> liftIO $ assertFailure (T.unpack prefix <> "...` action not offered")++executeExportAction, executeRemoveAction :: TextDocumentIdentifier -> Range -> Session ()+executeExportAction = executeByPrefix "Export `"+executeRemoveAction = executeByPrefix "Unexport `"++noActionWithPrefix :: T.Text -> TextDocumentIdentifier -> Range -> Session ()+noActionWithPrefix prefix doc range = do+    titles <- codeActionTitles doc range+    liftIO $ not (any (prefix `T.isPrefixOf`) titles)+        @? ("Did not expect " <> T.unpack prefix <> " action, saw: " <> show titles)++noExportOffered, noRemoveOffered :: TextDocumentIdentifier -> Range -> Session ()+noExportOffered = noActionWithPrefix "Export `"+noRemoveOffered = noActionWithPrefix "Unexport `"++-- | Fail unless some variant is an infix of the text. The message dumps it.+assertAnyInfix :: T.Text -> [T.Text] -> Assertion+assertAnyInfix hay variants =+    any (`T.isInfixOf` hay) variants+        @? ("Expected one of " <> show variants <> " in:\n" <> T.unpack hay)++containsAfter :: TextDocumentIdentifier -> [T.Text] -> Session ()+containsAfter doc expected = documentContents doc >>= liftIO . (`assertAnyInfix` expected)++-- | Fail unless every needle is an infix of the haystack. Used to assert that+-- CPP directives and conditional items survive an edit verbatim.+assertContainsAll :: T.Text -> [T.Text] -> Assertion+assertContainsAll hay = mapM_ $ \needle ->+    needle `T.isInfixOf` hay+        @? ("Expected " <> show needle <> " in:\n" <> T.unpack hay)++-- | Lines from the first @(@ through the @) where@ line (included, so an item on+-- the closing line still counts).+exportListRegion :: T.Text -> [T.Text]+exportListRegion txt =+    let afterOpen     = dropWhile (not . T.isInfixOf "(") (T.lines txt)+        (body, close) = break (T.isInfixOf ") where") afterOpen+    in body ++ take 1 close++-- | Does @name@ appear in the export list at CPP nesting level 0, i.e. not+-- guarded by any @#if@/@#ifdef@/@#ifndef@?+exportedUnconditionally :: T.Text -> T.Text -> Bool+exportedUnconditionally name txt = go (0 :: Int) (exportListRegion txt)+  where+    go _ [] = False+    go n (l:ls)+        | "#if"    `T.isPrefixOf` T.stripStart l = go (n + 1) ls+        | "#endif" `T.isPrefixOf` T.stripStart l = go (max 0 (n - 1)) ls+        | n == 0, name `T.isInfixOf` l           = True+        | otherwise                              = go n ls++-- | True when the export-list region carries no doubled or leading comma. A+-- trailing comma before @)@ is legal Haskell, so @,)@ is not flagged.+wellFormedExportList :: T.Text -> Bool+wellFormedExportList txt = not (any (`T.isInfixOf` compact) ["(,", ",,"])+  where+    compact = T.filter (not . isSpace) (T.unlines (exportListRegion txt))++-- | Run an action at the position, check the export list is well formed, return the new text.+runAndCheck :: (TextDocumentIdentifier -> Range -> Session ()) -> TextDocumentIdentifier -> Range -> Session T.Text+runAndCheck act doc pos = do+    act doc pos+    txt <- documentContents doc+    liftIO $ wellFormedExportList txt+        @? ("malformed export list, got:\n" <> T.unpack txt)+    pure txt++exportAndCheck :: TextDocumentIdentifier -> Range -> Session T.Text+exportAndCheck = runAndCheck executeExportAction++-- | Crudely re-run CPP for the macro EXAMPLE_FLAG over already-edited text,+-- keeping the branch the given definedness selects. Single level, just enough+-- to inspect the configuration the server did not parse.+preprocessExampleFlag :: Bool -> T.Text -> T.Text+preprocessExampleFlag defined = T.unlines . go Nothing . T.lines+  where+    -- Nothing outside any conditional. Just b inside one, emitting only when b.+    go _ [] = []+    go st (l:ls)+        | isDir "#ifdef"  = go (Just defined) ls+        | isDir "#ifndef" = go (Just (not defined)) ls+        | isDir "#else"   = go (fmap not st) ls+        | isDir "#endif"  = go Nothing ls+        | fromMaybe True st = l : go st ls+        | otherwise         = go st ls+      where isDir d = d `T.isPrefixOf` T.stripStart l++rangeAt :: UInt -> UInt -> Range+rangeAt l c = Range (Position l c) (Position l c)++-- | The CPP block the testdata guards with @#ifdef EXAMPLE_FLAG@. The flag is+-- never defined, so the branch is inactive and must survive an edit verbatim.+flagBlock :: [T.Text]+flagBlock = ["#ifdef EXAMPLE_FLAG", ", flagged", "#endif"]++-- | The new export of @name@ must sit at CPP nesting level 0, never in a branch.+assertExportedUnconditionally :: T.Text -> T.Text -> Assertion+assertExportedUnconditionally name txt =+    exportedUnconditionally name txt+        @? (T.unpack name <> " must be exported outside any CPP branch, got:\n" <> T.unpack txt)++-- | The 'flagBlock' survives verbatim and @name@ lands outside it.+assertFlaggedBlockKept :: T.Text -> T.Text -> Assertion+assertFlaggedBlockKept name txt =+    assertContainsAll txt flagBlock >> assertExportedUnconditionally name txt++-- | Run @exec@ at the position, assert the resulting export list is well-formed,+-- then assert the document contains one of the @expected@ variants.+execCase :: (TextDocumentIdentifier -> Range -> Session ())+         -> TestName -> FilePath -> UInt -> UInt -> [T.Text] -> TestTree+execCase exec name file l c expected = testCase name $ runExport file $ \doc -> do+    _ <- runAndCheck exec doc (rangeAt l c)+    containsAfter doc expected++addCase, removeCase :: TestName -> FilePath -> UInt -> UInt -> [T.Text] -> TestTree+addCase    = execCase executeExportAction+removeCase = execCase executeRemoveAction++-- | Assert the export or unexport action is not offered at the position.+absentCase :: (TextDocumentIdentifier -> Range -> Session ())+           -> TestName -> FilePath -> UInt -> UInt -> TestTree+absentCase absent name file l c = testCase name $ runExport file $ \doc ->+    absent doc (rangeAt l c)++noCase, noRemoveCase :: TestName -> FilePath -> UInt -> UInt -> TestTree+noCase       = absentCase noExportOffered+noRemoveCase = absentCase noRemoveOffered++-- | Run @act@ at the position, assert the list is well-formed, then run @check@+-- over the resulting document text.+checkCase :: (TextDocumentIdentifier -> Range -> Session T.Text)+          -> TestName -> FilePath -> UInt -> UInt -> (T.Text -> Assertion) -> TestTree+checkCase act name file l c check = testCase name $ runExport file $ \doc -> do+    txt <- act doc (rangeAt l c)+    liftIO (check txt)++exportCase :: TestName -> FilePath -> UInt -> UInt -> (T.Text -> Assertion) -> TestTree+exportCase = checkCase exportAndCheck++main :: IO ()+main = defaultTestRunner $ testGroup "Export"+    [ testGroup "Add"+        [ testGroup "value bindings"+            [ addCase "add value to export list" "AddExport.hs" 6 0+                ["module AddExport (foo, Bar, bar)"]+            , noCase "no action when value already exported" "AddExport.hs" 3 0  -- on `foo`+            , addCase "append follows a multi-line leading-comma list" "AddExportMultiline.hs" 11 0  -- on `baz`+                ["  , baz\n  ) where"]+            ]++        , testGroup "type declarations"+            [ addCase "add bare type as T(..)" "AddExport.hs" 9 5  -- on `Baz` type name+                ["Baz(..)", "Baz (..)"]+            ]++        , testGroup "constructors"+            [ addCase "constructor with no parent entry appends T (C)" "AddExport.hs" 9 12  -- on `Baz1`, no Baz entry yet+                ["Baz (Baz1)", "Baz(Baz1)"]+            , addCase "constructor under bare-type parent promotes to T(C)" "AddCtor.hs" 3 11  -- on `Bar1`, Bar is IEThingAbs+                ["Bar (Bar1)", "Bar(Bar1)"]+            , addCase "constructor merges into existing IEThingWith parent" "AddCtor.hs" 2 18  -- on `Foo2`, Foo has [Foo1]+                ["Foo (Foo1, Foo2)", "Foo(Foo1, Foo2)"]+            , noCase "constructor already in IEThingWith children suppresses action" "AddCtor.hs" 2 11  -- on `Foo1`, already child of Foo(Foo1)+            , noCase "constructor under IEThingAll T(..) suppresses action" "AddCtor.hs" 4 11  -- on `Baz1`, Baz(..) covers it+            , noCase "constructor exported standalone suppresses action" "AddCtor.hs" 5 11  -- on `Qux1`, Qux1 standalone in list+            ]++        , testGroup "type classes"+            [ addCase "add class as T(..)" "AddClass.hs" 8 6  -- on `Baz` class name+                ["module AddClass (Foo (..), Bar, Baz (..))"]+            , noCase "no add action when class exported as T(..)" "AddClass.hs" 2 6  -- on `Foo`, exported as Foo (..)+            , noCase "no add action when class exported as bare T" "AddClass.hs" 5 6  -- on `Bar`, exported as bare+            , noCase "no add action on class method" "AddClass.hs" 9 2  -- on `baz1` inside `class Baz a where`+            ]++        , testGroup "layout variants"+            [ addCase "add to an empty export list" "AddExportEmpty.hs" 2 0  -- on `foo`+                ["module AddExportEmpty (foo) where"]+            , addCase "append after a trailing comma" "AddExportTrailingComma.hs" 7 0  -- on `bar`+                ["( foo, bar"]+            , addCase "preserve a haddock comment between items" "AddExportComment.hs" 16 0  -- on `quux`+                ["  -- * For testing\n  , baz\n  , quux\n  ) where"]+            ]++        , testGroup "declaration kinds"+            [ addCase "function operator is parenthesized" "AddExportKinds.hs" 8 1  -- on `(<|)`+                ["(placeholder, (<|))"]+            , addCase "infix function exports bare name" "AddExportKinds.hs" 11 3  -- on `f`+                ["(placeholder, f)"]+            , addCase "newtype exports as T(..)" "AddExportKinds.hs" 13 8  -- on `NT`+                ["placeholder, NT(..)", "placeholder, NT (..)"]+            , addCase "type synonym exports bare" "AddExportKinds.hs" 15 5  -- on `Syn`+                ["(placeholder, Syn)"]+            , addCase "type family exports bare" "AddExportKinds.hs" 17 12  -- on `TF`+                ["(placeholder, TF)"]+            , addCase "pattern synonym gets a pattern prefix" "AddExportKinds.hs" 20 9  -- on `Pat`+                ["(placeholder, pattern Pat)"]+            , addCase "data operator gets type keyword and (..)" "AddExportKinds.hs" 22 7  -- on `(:<)`+                ["placeholder, type (:<)(..)", "placeholder, type (:<) (..)"]+            ]++        , testGroup "type-level operators"+            [ addCase "type synonym operator has no type keyword" "AddExportTypeOps.hs" 8 7  -- on `(:<>)`+                ["(placeholder, (:<>))"]+            , addCase "type family operator gets type keyword" "AddExportTypeOps.hs" 10 14  -- on `(:+:)`+                ["(placeholder, type (:+:))"]+            , addCase "typeclass operator gets type keyword and (..)" "AddExportTypeOps.hs" 12 8  -- on `(:*:)`+                ["placeholder, type (:*:)(..)", "placeholder, type (:*:) (..)"]+            , addCase "newtype operator gets type keyword and (..)" "AddExportTypeOps.hs" 14 10  -- on `(:->)`+                ["placeholder, type (:->)(..)", "placeholder, type (:->) (..)"]+            , addCase "pattern synonym operator is parenthesized" "AddExportTypeOps.hs" 16 11  -- on `(:++)`+                ["(placeholder, pattern (:++))"]+            ]++        , testGroup "negative cases"+            [ noCase "no action on implicit module" "Implicit.hs" 3 0+            , noCase "no action when cursor on RHS" "AddExport.hs" 6 6  -- col 6 is on the `2` of `bar = 2`+            , noCase "no action on a where-bound name" "AddExportNegatives.hs" 7 8  -- on `whereBound`+            , noCase "no action on a record field" "AddExportNegatives.hs" 9 18  -- on `recField`+            ]++        , testGroup "CPP in the export list"+            -- EXAMPLE_FLAG is never defined in the test project, so #ifdef branches+            -- are inactive and #ifndef branches are active. The edit must preserve+            -- every directive verbatim and place the new export outside any branch.+            [ exportCase "preserves a trailing #ifdef block" "CppExportTail.hs" 15 0  -- on `baz`+                (assertFlaggedBlockKept "baz")++            , exportCase "preserves a leading #ifndef block" "CppExportHead.hs" 12 0 $ \txt -> do  -- on `bar`+                -- the whole guarded block survives verbatim, not just stray substrings+                assertContainsAll txt ["#ifndef EXAMPLE_FLAG\n    foo\n#endif"]+                assertExportedUnconditionally "bar" txt++            , exportCase "preserves both #if/#else branches" "CppExportElse.hs" 20 0 $ \txt -> do  -- on `extra`+                assertContainsAll txt+                    ["#ifdef EXAMPLE_FLAG", ", windows", "#else", ", posix", "#endif"]+                assertExportedUnconditionally "extra" txt++            , testCase "preserves an #include directive" $ runExportWith ["CppExportInclude.h"] "CppExportInclude.hs" $ \doc -> do+                txt <- exportAndCheck doc (rangeAt 13 0)  -- on `extra`+                liftIO $ do+                    assertContainsAll txt ["#include \"CppExportInclude.h\"", "( extra, foo"]+                    assertExportedUnconditionally "extra" txt++            , exportCase "appends a new T(C) beside a CPP block" "CppCtorAppend.hs" 11 11 $ \txt -> do  -- on `Baz1`, no Baz entry yet+                assertFlaggedBlockKept "Baz1" txt+                txt `assertAnyInfix` ["Baz (Baz1)", "Baz(Baz1)"]++            , exportCase "adds a separate entry beside an IEThingWith parent" "CppCtorExtend.hs" 8 18 $ \txt -> do  -- on `Foo2`, Foo has [Foo1]+                assertFlaggedBlockKept "Foo2" txt+                assertContainsAll txt ["Foo(Foo1)"]+                txt `assertAnyInfix` ["Foo (Foo2)", "Foo(Foo2)"]++            , exportCase "adds a separate entry without a double comma" "CppCtorMid.hs" 9 18 $ \txt -> do  -- on `Foo2`, Foo(Foo1) precedes `, bar`+                assertContainsAll txt (flagBlock <> [", bar", "Foo(Foo1)"])+                txt `assertAnyInfix` ["Foo (Foo2)", "Foo(Foo2)"]++            , exportCase "adds a separate entry beside a bare-type parent" "CppCtorUpgrade.hs" 8 11 $ \txt -> do  -- on `Bar1`, Bar is IEThingAbs+                assertFlaggedBlockKept "Bar1" txt+                txt `assertAnyInfix` ["Bar (Bar1)", "Bar(Bar1)"]++            , exportCase "exports an operator beside a CPP block" "CppExportKinds.hs" 12 1  -- on `(<|)`+                (assertFlaggedBlockKept "(<|)")++            , exportCase "exports a pattern synonym beside a CPP block" "CppExportKinds.hs" 16 8  -- on `Zero`+                (assertFlaggedBlockKept "pattern Zero")++            , exportCase "adds a separate entry beside a directive inside a constructor list" "CppCtorIntra.hs" 9 24 $ \txt -> do  -- on `Foo2`+                -- the #ifdef sits inside Foo(...), where an in-place merge would erase it+                assertContainsAll txt ["#ifdef EXAMPLE_FLAG\n      , Bar\n#endif", "Foo(Foo1"]+                txt `assertAnyInfix` ["Foo (Foo2)", "Foo(Foo2)"]++            , exportCase "front-inserts even when the close paren shares a line" "CppExportParenShared.hs" 18 0 $ \txt -> do  -- on `baz`+                assertContainsAll txt (flagBlock <> [", bar )"])+                assertExportedUnconditionally "baz" txt++            , exportCase "no double comma when the last item already has a trailing comma" "CppExportTrailingComma.hs" 15 0 $ \txt -> do  -- on `baz`+                -- a doubled `,,` would be caught by exportAndCheck's well-formedness check+                assertContainsAll txt ["#ifdef EXAMPLE_FLAG", "flagged,", "#endif"]+                assertExportedUnconditionally "baz" txt++            , exportCase "edit stays valid in the unparsed CPP branch" "CppExportOtherBranch.hs" 12 0 $ \txt -> do  -- on `bar`, the only item is in the other branch+                -- the single item lives under #ifndef, so it is the whole parsed list.+                -- The front-insert plus trailing comma stays valid when the flag flips+                -- and that item disappears.+                let otherBranch = preprocessExampleFlag True txt+                wellFormedExportList otherBranch+                    @? ("edit breaks the EXAMPLE_FLAG-defined configuration:\n" <> T.unpack otherBranch)+            ]+        ]++    , testGroup "Export fixes the unused-binding warning"+        [ knownBrokenForGhcVersions [GHC96]+            "TcRnUnusedName provenance is unstructured before GHC 9.8 (GHC #20115)" $+          testCase "Export action attaches the -Wunused-top-binds diagnostic" $ runExport "ExportUnusedFix.hs" $ \doc -> do+            actions <- rights . map toEither <$> getCodeActions doc (rangeAt 6 0)  -- on `unused`+            case filter ((== "Export `unused`") . (^. L.title)) actions of+                (ca:_) -> liftIO $ not (null (fromMaybe [] (ca ^. L.diagnostics)))+                            @? "Export action should carry the unused-binding diagnostic"+                []     -> liftIO $ assertFailure $+                            "Export `unused` not offered; saw: " <> show (map (^. L.title) actions)+        ]++    , testGroup "Remove"+        [ testGroup "value bindings"+            [ removeCase "remove first value (foo)" "RemoveExport.hs" 3 0+                ["module RemoveExport (Bar, Baz (Baz1))"]++            , noRemoveCase "no remove action when value not in export list" "AddExport.hs" 6 0  -- `bar` not exported++            , removeCase "unexporting the sole export empties the list to ()" "SoleExport.hs" 3 0  -- on `only`, the only export+                ["module SoleExport () where"]++            , removeCase "remove first item of a multi-line list keeps own-line layout" "RemoveFirstMultiline.hs" 6 0  -- on `foo`, the first export+                ["( bar\n  , baz\n  ) where"]++            , testCase "remove first item drops its comment, keeps the others'" $ runExport "RemoveItemComment.hs" $ \doc -> do+                executeRemoveAction doc (rangeAt 6 0)  -- on `foo`, the first export+                txt <- documentContents doc+                liftIO $ do+                    assertContainsAll txt ["bar -- the bar", "baz -- the baz"]+                    not ("the foo" `T.isInfixOf` txt) @? ("foo's comment survived:\n" <> T.unpack txt)++            , testCase "remove middle item drops its comment, keeps the others'" $ runExport "RemoveItemComment.hs" $ \doc -> do+                executeRemoveAction doc (rangeAt 9 0)  -- on `bar`, the middle export+                txt <- documentContents doc+                liftIO $ do+                    assertContainsAll txt ["foo -- the foo", "baz -- the baz"]+                    not ("the bar" `T.isInfixOf` txt) @? ("bar's comment survived:\n" <> T.unpack txt)+            ]++        , testGroup "type declarations"+            [ removeCase "remove bare type (middle item)" "RemoveExport.hs" 5 5  -- on `Bar`+                ["module RemoveExport (foo, Baz (Baz1))"]+            , removeCase "remove IEThingWith type removes whole entry" "RemoveCtor.hs" 2 5  -- on `Foo` type+                ["module RemoveCtor (Bar (..), Baz1)"]+            , removeCase "remove IEThingAll type removes whole entry" "RemoveCtor.hs" 3 5  -- on `Bar` type with (..)+                ["module RemoveCtor (Foo (Foo1, Foo2), Baz1)"]+            ]++        , testGroup "constructors"+            [ removeCase "remove sole constructor downgrades to bare type" "RemoveExport.hs" 6 11  -- on `Baz1` in Baz(Baz1)+                ["module RemoveExport (foo, Bar, Baz)"]+            , removeCase "remove first constructor of T(C1, C2) yields T (C2)" "RemoveCtor.hs" 2 11  -- on `Foo1` in Foo(Foo1, Foo2)+                ["Foo (Foo2)", "Foo(Foo2)"]+            , removeCase "remove second constructor of T(C1, C2) yields T (C1)" "RemoveCtor.hs" 2 18  -- on `Foo2` in Foo(Foo1, Foo2)+                ["Foo (Foo1)", "Foo(Foo1)"]+            , removeCase "remove standalone-exported constructor" "RemoveCtor.hs" 4 11  -- on `Baz1` standalone+                ["module RemoveCtor (Foo (Foo1, Foo2), Bar (..))"]+            , noRemoveCase "constructor under IEThingAll suppresses remove action" "RemoveCtor.hs" 3 11  -- on `Bar1`, only Bar(..) in list+            , noRemoveCase "constructor not in export list suppresses remove action" "RemoveCtor.hs" 2 25  -- on `Foo3`, not in any entry++            -- `data Bar = Bar`: unexporting the constructor leaves the abstract type+            -- exported, so unexport must skip the standalone-removal fallback.+            , noRemoveCase "constructor sharing its type's name does not unexport the type" "RemoveCtorNameClash.hs" 5 11  -- on the constructor `Bar`++            , removeCase "unexporting the type still works when a constructor shares its name" "RemoveCtorNameClash.hs" 5 5  -- on the type `Bar`+                ["module RemoveCtorNameClash (foo)"]+            , removeCase "downgrading an operator type keeps the type keyword" "RemoveCtorOp.hs" 4 15  -- on `Op`, the sole constructor of (:+:)+                ["(type (:+:)) where", "(type (:+:) ) where"]++            , testCase "removing a child preserves the survivors' multiline layout" $ runExport "RemoveCtorMultiline.hs" $ \doc -> do+                executeRemoveAction doc (rangeAt 8 18)  -- on `Foo2` in the data decl, the middle child+                txt <- documentContents doc+                let region = exportListRegion txt+                liftIO $ do+                    -- Survivors keep their layout: head not flushed to `(`, Foo3 on its own line.+                    assertContainsAll txt ["( Foo1\n", "        , Foo3\n"]+                    not (any ("Foo2" `T.isInfixOf`) region) @? ("Foo2 still exported:\n" <> T.unpack txt)++            , testCase "removing a middle child keeps the surviving siblings' comments" $ runExport "RemoveCtorComment.hs" $ \doc -> do+                executeRemoveAction doc (rangeAt 8 18)  -- on `Foo2` in the data decl+                txt <- documentContents doc+                liftIO $ do+                    assertContainsAll txt ["Foo1 -- first", "Foo3 -- third"]+                    -- The removed child takes its own trailing comment with it.+                    not ("second" `T.isInfixOf` txt) @? ("Foo2's comment lingered:\n" <> T.unpack txt)++            , testCase "removing the head child keeps the new head's own comment" $ runExport "RemoveCtorComment.hs" $ \doc -> do+                executeRemoveAction doc (rangeAt 8 11)  -- on `Foo1` in the data decl+                txt <- documentContents doc+                liftIO $ do+                    -- Foo2 slides into Foo1's slot keeping its own `-- second`,+                    -- and Foo1's `-- first` is deleted along with Foo1.+                    assertContainsAll txt ["Foo2 -- second", "Foo3 -- third"]+                    not ("first" `T.isInfixOf` txt) @? ("Foo1's comment survived:\n" <> T.unpack txt)+            ]++        , testGroup "type classes"+            [ removeCase "remove class exported as T(..)" "RemoveClass.hs" 2 6  -- on `Foo`+                ["module RemoveClass (Bar, Baz (baz1))"]+            , removeCase "remove class exported as bare T" "RemoveClass.hs" 5 6  -- on `Bar`+                ["module RemoveClass (Foo (..), Baz (baz1))"]+            , removeCase "remove class exported as T(method)" "RemoveClass.hs" 8 6  -- on `Baz`+                ["module RemoveClass (Foo (..), Bar)"]+            , noRemoveCase "no remove action when class not in export list" "RemoveClass.hs" 12 6  -- on `Qux`, not exported+            , noRemoveCase "no remove action on class method" "RemoveClass.hs" 9 2  -- on `baz1` inside `class Baz a where`+            ]++        , testGroup "negative cases"+            [ noRemoveCase "no remove action on implicit module" "Implicit.hs" 3 0+            , noRemoveCase "no remove action when cursor on RHS" "RemoveExport.hs" 3 6  -- on the `1` of `foo = 1`+            -- A reprint would erase the directives the parser stripped, so removal is+            -- declined whenever the export list holds a CPP directive.+            , noRemoveCase "no remove action under a CPP export list" "CppExportTail.hs" 9 0  -- on `foo`, exported beside an #ifdef block+            ]+        ]+    ]
+ plugins/hls-export-plugin/test/testdata/AddClass.hs view
@@ -0,0 +1,10 @@+module AddClass (Foo (..), Bar) where++class Foo a where+  foo1 :: a -> Int++class Bar a where+  bar1 :: a -> Int++class Baz a where+  baz1 :: a -> Int
+ plugins/hls-export-plugin/test/testdata/AddCtor.hs view
@@ -0,0 +1,6 @@+module AddCtor (Foo (Foo1), Bar, Baz (..), Qux1) where++data Foo = Foo1 | Foo2 | Foo3+data Bar = Bar1 | Bar2+data Baz = Baz1 | Baz2+data Qux = Qux1 | Qux2
+ plugins/hls-export-plugin/test/testdata/AddExport.hs view
@@ -0,0 +1,10 @@+module AddExport (foo, Bar) where++foo :: Int+foo = 1++bar :: Int+bar = 2++data Bar = Bar+data Baz = Baz1 | Baz2
+ plugins/hls-export-plugin/test/testdata/AddExportComment.hs view
@@ -0,0 +1,18 @@+module AddExportComment+  ( foo+  , bar+  -- * For testing+  , baz+  ) where++foo :: Int+foo = 1++bar :: Int+bar = 2++baz :: Int+baz = 3++quux :: Int+quux = 4
+ plugins/hls-export-plugin/test/testdata/AddExportEmpty.hs view
@@ -0,0 +1,4 @@+module AddExportEmpty () where++foo :: Int+foo = 1
+ plugins/hls-export-plugin/test/testdata/AddExportKinds.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies    #-}+{-# LANGUAGE TypeOperators   #-}+module AddExportKinds (placeholder) where++placeholder :: Int+placeholder = 0++(<|) :: a -> a -> a+(<|) x _ = x++a `f` b = b++newtype NT = NT ()++type Syn = ()++type family TF p++pattern Pat :: a -> (a, a)+pattern Pat a = (a, a)++data (:<) = Mk
+ plugins/hls-export-plugin/test/testdata/AddExportMultiline.hs view
@@ -0,0 +1,13 @@+module AddExportMultiline+  ( foo+  , bar+  ) where++foo :: Int+foo = 1++bar :: Int+bar = 2++baz :: Int+baz = 3
+ plugins/hls-export-plugin/test/testdata/AddExportNegatives.hs view
@@ -0,0 +1,10 @@+module AddExportNegatives (placeholder) where++placeholder :: Int+placeholder = 0++withWhere :: ()+withWhere = whereBound+  where whereBound = ()++data Rec = Rec { recField :: () }
+ plugins/hls-export-plugin/test/testdata/AddExportTrailingComma.hs view
@@ -0,0 +1,9 @@+module AddExportTrailingComma+  ( foo,+  ) where++foo :: Int+foo = 1++bar :: Int+bar = 2
+ plugins/hls-export-plugin/test/testdata/AddExportTypeOps.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies    #-}+{-# LANGUAGE TypeOperators   #-}+module AddExportTypeOps (placeholder) where++placeholder :: Int+placeholder = 0++type (:<>) = ()++type family (:+:)++class (:*:) a++newtype (:->) = MkArr ()++pattern x :++ y = (x, y)
+ plugins/hls-export-plugin/test/testdata/CppCtorAppend.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE CPP #-}+module CppCtorAppend+  ( foo+#ifdef EXAMPLE_FLAG+  , flagged+#endif+  ) where++foo :: Int+foo = 1++data Baz = Baz1 | Baz2++flagged :: Int+flagged = 0
+ plugins/hls-export-plugin/test/testdata/CppCtorExtend.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE CPP #-}+module CppCtorExtend+  ( Foo(Foo1)+#ifdef EXAMPLE_FLAG+  , flagged+#endif+  ) where++data Foo = Foo1 | Foo2++flagged :: Int+flagged = 0
+ plugins/hls-export-plugin/test/testdata/CppCtorIntra.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE CPP #-}+module CppCtorIntra+  ( Foo(Foo1+#ifdef EXAMPLE_FLAG+      , Bar+#endif+      )+  ) where++data Foo = Foo1 | Bar | Foo2++foo :: Int+foo = 0
+ plugins/hls-export-plugin/test/testdata/CppCtorMid.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE CPP #-}+module CppCtorMid+  ( Foo(Foo1)+  , bar+#ifdef EXAMPLE_FLAG+  , flagged+#endif+  ) where++data Foo = Foo1 | Foo2++bar :: Int+bar = 0++flagged :: Int+flagged = 0
+ plugins/hls-export-plugin/test/testdata/CppCtorUpgrade.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE CPP #-}+module CppCtorUpgrade+  ( Bar+#ifdef EXAMPLE_FLAG+  , flagged+#endif+  ) where++data Bar = Bar1 | Bar2++flagged :: Int+flagged = 0
+ plugins/hls-export-plugin/test/testdata/CppExportElse.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE CPP #-}+module CppExportElse+  ( foo+#ifdef EXAMPLE_FLAG+  , windows+#else+  , posix+#endif+  ) where++foo :: Int+foo = 1++windows :: Int+windows = 1++posix :: Int+posix = 2++extra :: Int+extra = 3
+ plugins/hls-export-plugin/test/testdata/CppExportHead.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE CPP #-}+module CppExportHead+  (+#ifndef EXAMPLE_FLAG+    foo+#endif+  ) where++foo :: Int+foo = 1++bar :: Int+bar = 2
+ plugins/hls-export-plugin/test/testdata/CppExportInclude.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE CPP #-}+module CppExportInclude+  ( foo+#include "CppExportInclude.h"+  ) where++foo :: Int+foo = 1++included :: Int+included = 2++extra :: Int+extra = 3
+ plugins/hls-export-plugin/test/testdata/CppExportKinds.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}+module CppExportKinds+  ( foo+#ifdef EXAMPLE_FLAG+  , flagged+#endif+  ) where++foo :: Int+foo = 1++(<|) :: Int -> Int -> Int+a <| b = a + b++pattern Zero :: Int+pattern Zero = 0++flagged :: Int+flagged = 2
+ plugins/hls-export-plugin/test/testdata/CppExportOtherBranch.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE CPP #-}+module CppExportOtherBranch+  (+#ifndef EXAMPLE_FLAG+    foo+#endif+  ) where++foo :: Int+foo = 1++bar :: Int+bar = 2
+ plugins/hls-export-plugin/test/testdata/CppExportParenShared.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE CPP #-}+module CppExportParenShared+  ( foo+#ifdef EXAMPLE_FLAG+  , flagged+#endif+  , bar ) where++foo :: Int+foo = 1++flagged :: Int+flagged = 2++bar :: Int+bar = 3++baz :: Int+baz = 4
+ plugins/hls-export-plugin/test/testdata/CppExportTail.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE CPP #-}+module CppExportTail+  ( foo+#ifdef EXAMPLE_FLAG+  , flagged+#endif+  ) where++foo :: Int+foo = 1++flagged :: Int+flagged = 2++baz :: Int+baz = 3
+ plugins/hls-export-plugin/test/testdata/CppExportTrailingComma.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE CPP #-}+module CppExportTrailingComma+  ( foo,+#ifdef EXAMPLE_FLAG+    flagged,+#endif+  ) where++foo :: Int+foo = 1++flagged :: Int+flagged = 2++baz :: Int+baz = 3
+ plugins/hls-export-plugin/test/testdata/ExportUnusedFix.hs view
@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -Wunused-top-binds #-}+module ExportUnusedFix (used) where++used :: Int+used = 1++unused :: Int+unused = 2
+ plugins/hls-export-plugin/test/testdata/Implicit.hs view
@@ -0,0 +1,4 @@+module Implicit where++something :: Int+something = 42
+ plugins/hls-export-plugin/test/testdata/RemoveClass.hs view
@@ -0,0 +1,14 @@+module RemoveClass (Foo (..), Bar, Baz (baz1)) where++class Foo a where+  foo1 :: a -> Int++class Bar a where+  bar1 :: a -> Int++class Baz a where+  baz1 :: a -> Int+  baz2 :: a -> Int++class Qux a where+  qux1 :: a -> Int
+ plugins/hls-export-plugin/test/testdata/RemoveCtor.hs view
@@ -0,0 +1,5 @@+module RemoveCtor (Foo (Foo1, Foo2), Bar (..), Baz1) where++data Foo = Foo1 | Foo2 | Foo3+data Bar = Bar1 | Bar2+data Baz = Baz1 | Baz2
+ plugins/hls-export-plugin/test/testdata/RemoveCtorComment.hs view
@@ -0,0 +1,9 @@+module RemoveCtorComment+    ( Foo+        ( Foo1 -- first+        , Foo2 -- second+        , Foo3 -- third+        )+    ) where++data Foo = Foo1 | Foo2 | Foo3
+ plugins/hls-export-plugin/test/testdata/RemoveCtorMultiline.hs view
@@ -0,0 +1,9 @@+module RemoveCtorMultiline+    ( Foo+        ( Foo1+        , Foo2+        , Foo3+        )+    ) where++data Foo = Foo1 | Foo2 | Foo3
+ plugins/hls-export-plugin/test/testdata/RemoveCtorNameClash.hs view
@@ -0,0 +1,6 @@+module RemoveCtorNameClash (foo, Bar) where++foo :: Int+foo = 1++data Bar = Bar
+ plugins/hls-export-plugin/test/testdata/RemoveCtorOp.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE TypeOperators      #-}+module RemoveCtorOp (type (:+:) (Op)) where++data a :+: b = Op
+ plugins/hls-export-plugin/test/testdata/RemoveExport.hs view
@@ -0,0 +1,7 @@+module RemoveExport (foo, Bar, Baz (Baz1)) where++foo :: Int+foo = 1++data Bar = Bar+data Baz = Baz1 | Baz2
+ plugins/hls-export-plugin/test/testdata/RemoveFirstMultiline.hs view
@@ -0,0 +1,14 @@+module RemoveFirstMultiline+  ( foo+  , bar+  , baz+  ) where++foo :: Int+foo = 1++bar :: Int+bar = 2++baz :: Int+baz = 3
+ plugins/hls-export-plugin/test/testdata/RemoveItemComment.hs view
@@ -0,0 +1,14 @@+module RemoveItemComment+  ( foo -- the foo+  , bar -- the bar+  , baz -- the baz+  ) where++foo :: Int+foo = 1++bar :: Int+bar = 2++baz :: Int+baz = 3
+ plugins/hls-export-plugin/test/testdata/SoleExport.hs view
@@ -0,0 +1,4 @@+module SoleExport (only) where++only :: Int+only = 1
plugins/hls-gadt-plugin/test/Main.hs view
@@ -34,12 +34,12 @@     , runTest "ConstructorContext" "ConstructorContext" 2 0 2 38     , runTest "Context" "Context" 2 0 4 41     , runTest "Pragma" "Pragma" 2 0 3 29-    , runTest "SingleDerivingGHC92" "SingleDerivingGHC92" 2 0 3 14-    , gadtPragmaTest "ghc-9.2 don't need to insert GADTs pragma" False+    , runTest "SingleDeriving" "SingleDeriving" 2 0 3 14+    , gadtPragmaTest "no need to insert GADTs pragma"     ] -gadtPragmaTest :: TestName -> Bool -> TestTree-gadtPragmaTest title hasGADT = testCase title+gadtPragmaTest :: TestName -> TestTree+gadtPragmaTest title = testCase title     $ withCanonicalTempDir     $ \dir -> runSessionWithServer def gadtPlugin dir $ do         doc <- createDoc "A.hs" "haskell" (T.unlines ["module A where", "data Foo = Bar"])@@ -47,7 +47,6 @@         (act:_) <- findGADTAction <$> getCodeActions doc (Range (Position 1 0) (Position 1 1))         executeCodeAction act         let expected = T.unlines $-                ["{-# LANGUAGE GADTs #-}" | hasGADT] ++                 ["module A where", "data Foo where", "  Bar :: Foo"]         contents <- skipManyTill anyMessage (getDocumentEdit doc)         liftIO $ contents @?= expected
plugins/hls-gadt-plugin/test/testdata/SingleDeriving.expected.hs view
@@ -2,4 +2,4 @@  data Foo a b where   Bar :: b -> a -> Foo a b-  deriving Eq+  deriving (Eq)
− plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.expected.hs 
@@ -1,5 +0,0 @@-module SingleDerivingGHC92 where--data Foo a b where-  Bar :: b -> a -> Foo a b-  deriving (Eq)
− plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.hs 
@@ -1,4 +0,0 @@-module SingleDerivingGHC92 where--data Foo a b = Bar b a- deriving (Eq)
plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs view
@@ -19,6 +19,7 @@ import           Development.IDE.Core.PluginUtils (runActionE, useE) import           Development.IDE.Core.Shake       (toKnownFiles) import qualified Development.IDE.Core.Shake       as Shake+import           Development.IDE.Core.Text        (lineAt) import           Development.IDE.Graph.Classes    (Hashable, NFData) import           GHC.Generics                     (Generic) import           Ide.Plugin.Error                 (PluginError (..))@@ -109,8 +110,7 @@     contents <-         err "Error getting file contents"         =<< liftIO (runAction "notes.getfileContents" state (getFileContents nfp))-    line <- err "Line not found in file" (listToMaybe $ Rope.lines $ fst-        (Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) contents))+    line <- err "Line not found in file" (lineAt (fromIntegral l) contents)     pure $ listToMaybe $ mapMaybe (atPos $ fromIntegral c) $ matchAllText noteRefRegex line   where     atPos c arr = case arr A.! 0 of@@ -290,7 +290,7 @@           let lineText =                 case mbRope of                   Nothing   -> ""-                  Just rope -> fromMaybe "" $ listToMaybe $ drop (fromIntegral line) $ Rope.lines rope+                  Just rope -> fromMaybe "" $ lineAt (fromIntegral line) rope                mbRange = findNoteRange lineText note line @@ -391,8 +391,4 @@  getLinePrefix :: Rope.Rope -> Position -> Text getLinePrefix rope (Position line col) =-  case Rope.splitAtLine (fromIntegral line) rope of-    (_, rest) ->-      case Rope.lines rest of-        (l:_) -> T.take (fromIntegral col) l-        _     -> ""+  maybe "" (T.take (fromIntegral col)) (lineAt (fromIntegral line) rope)
plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs view
@@ -94,9 +94,7 @@     parsedModule <- liftIO $ runAction "Pragmas.GetParsedModule" state $ getParsedModule normalizedFilePath     let parsedModuleDynFlags = ms_hspp_opts . pm_mod_summary <$> parsedModule         nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents-    activeDiagnosticsInRange (shakeExtras state) normalizedFilePath caRange >>= \case-        Nothing -> pure $ LSP.InL []-        Just fileDiags -> do+    activeDiagnosticsInRange (shakeExtras state) normalizedFilePath caRange >>= \fileDiags -> do             let actions = concatMap (mkSuggest parsedModuleDynFlags) fileDiags             pure $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> nubOrdOn snd actions
plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs view
@@ -7,7 +7,7 @@ import           Development.IDE.GHC.Compat.ExactPrint (ExactPrint, exactPrint) import           Development.IDE.GHC.Compat.Util import           Generics.SYB                          (ext1Q, ext2Q, extQ)-import           GHC.Hs                                hiding (AnnLet)+import           GHC.Hs import           GHC.Hs.Dump import           GHC.Plugins                           hiding (AnnLet) import           Prelude                               hiding ((<>))
plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs view
@@ -24,13 +24,10 @@       modifySigWithM,       genAnchor1,       setPrecedingLines,-      addParens,       addParensToCtxt,-      modifyAnns,       removeComma,       -- * Helper function       eqSrcSpan,-      epl,       epAnn,       removeTrailingComma,       annotateParsedSource,@@ -67,6 +64,10 @@                                                           parsePattern,                                                           parseType) import           Development.IDE.GHC.Compat.ExactPrint+import           Development.IDE.GHC.ExactPrint.Annotation (epl,+                                                            isCommaAnn,+                                                            modifyAnns,+                                                            removeTrailingCommaAnn) import           Development.IDE.Graph                   (RuleResult, Rules) import           Development.IDE.Graph.Classes import           Generics.SYB@@ -93,16 +94,13 @@ import           GHC                                     ( Anchor (..),                                                           AnchorOperation,                                                           EpAnn (..),-                                                          NameAdornment (NameParens),-                                                          NameAnn (..),                                                           SrcSpanAnn' (SrcSpanAnn),                                                           SrcSpanAnnA,-                                                          TrailingAnn (AddCommaAnn),                                                           emptyComments,                                                           realSrcSpan,                                                           spanAsAnchor) import           GHC.Parser.Annotation                   (AnnContext (..),-                                                          EpaLocation (EpaDelta),+                                                          EpaLocation,                                                           deltaPos) import           GHC.Types.SrcLoc                        (generatedSrcSpan) #endif@@ -122,10 +120,7 @@ #if MIN_VERSION_ghc(9,11,0)                                                           EpToken (..), #endif-                                                          NameAdornment (..),-                                                          NameAnn (..),                                                           SrcSpanAnnA,-                                                          TrailingAnn (..),                                                           deltaPos,                                                           emptyComments,                                                           spanAsAnchor)@@ -301,7 +296,7 @@     LocatedAn l ast ->     Graft (Either String) a graft' needs_space dst val = Graft $ \dflags a -> do-    val' <- annotate dflags needs_space val+    val' <- annotate dflags needs_space dst val     pure $         everywhere'             ( mkT $@@ -371,7 +366,7 @@                             Just val' -> do                                 val'' <-                                     hoistTransform (either Fail.fail pure)-                                        (annotate @AnnListItem @(HsExpr GhcPs) dflags needs_space (mk_parens val'))+                                        (annotate @AnnListItem @(HsExpr GhcPs) dflags needs_space dst (mk_parens val'))                                 pure val''                             Nothing -> pure val                 l -> pure l@@ -395,7 +390,7 @@                             Just val' -> do                                 val'' <-                                     hoistTransform (either Fail.fail pure) $-                                        annotate dflags False $ maybeParensAST val'+                                        annotate dflags False dst $ maybeParensAST val'                                 pure val''                             Nothing -> pure val                 l -> pure l@@ -667,6 +662,7 @@     , Typeable l     , Outputable l     , Outputable ast+    , ExactPrint (LocatedAn l ast) #if !MIN_VERSION_ghc(9,9,0)     , Default l #endif@@ -719,12 +715,17 @@ -- | Given an 'LHSExpr', compute its exactprint annotations. --   Note that this function will throw away any existing annotations (and format) annotate :: ASTElement l ast-    => DynFlags -> Bool -> LocatedAn l ast -> TransformT (Either String) (LocatedAn l ast)-annotate dflags needs_space ast = do+    => DynFlags -> Bool -> SrcSpan -> LocatedAn l ast -> TransformT (Either String) (LocatedAn l ast)+annotate dflags _needs_space _loc ast = do     uniq <- show <$> uniqueSrcSpanT     let rendered = render dflags ast     expr' <- TransformT $ lift $ mapLeft (showSDoc dflags . ppr) $ parseAST dflags uniq rendered-    pure $ setPrecedingLines expr' 0 (bool 0 1 needs_space)+#if MIN_VERSION_ghc(9,9,0)+    let L l e = makeDeltaAst expr'+    pure $ L l{entry = spanAsAnchor _loc} e+#else+    pure $ setPrecedingLines expr' 0 (bool 0 1 _needs_space)+#endif  -- | Given an 'LHsDecl', compute its exactprint annotations. annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (LHsDecl GhcPs)@@ -732,7 +733,12 @@     uniq <- show <$> uniqueSrcSpanT     let rendered = render dflags ast     expr' <- TransformT $ lift $ mapLeft (showSDoc dflags . ppr) $ parseDecl dflags uniq rendered-    pure $ setPrecedingLines expr' 1 0+#if MIN_VERSION_ghc(9,9,0)+    let expr'' = makeDeltaAst expr'+#else+    let expr'' = expr'+#endif+    pure $ setPrecedingLines expr'' 1 0  ------------------------------------------------------------------------------ @@ -772,64 +778,11 @@ #endif         | otherwise = it -epl :: Int -> EpaLocation-#if MIN_VERSION_ghc(9,11,0)-epl n = EpaDelta (UnhelpfulSpan UnhelpfulNoLocationInfo) (SameLine n) []-#else-epl n = EpaDelta (SameLine n) []-#endif- epAnn :: SrcSpan -> ann -> EpAnn ann epAnn srcSpan anns = EpAnn (spanAsAnchor srcSpan) anns emptyComments -modifyAnns :: LocatedAn a ast -> (a -> a) -> LocatedAn a ast-#if MIN_VERSION_ghc(9,9,0)-modifyAnns x f = first (fmap f) x-#else-modifyAnns x f = first ((fmap.fmap) f) x-#endif- removeComma :: SrcSpanAnnA -> SrcSpanAnnA-#if MIN_VERSION_ghc(9,9,0)-removeComma  (EpAnn anc (AnnListItem as) cs)-  = EpAnn anc (AnnListItem (filter (not . isCommaAnn) as)) cs-  where-      isCommaAnn AddCommaAnn{} = True-      isCommaAnn _             = False-#else-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-#endif--addParens :: Bool -> GHC.NameAnn -> GHC.NameAnn-#if MIN_VERSION_ghc(9,11,0)-addParens True it@NameAnn{} =-        it{nann_adornment = NameParens (EpTok (epl 0)) (EpTok (epl 0)) }-addParens True it@NameAnnCommas{} =-        it{nann_adornment = NameParens (EpTok (epl 0)) (EpTok (epl 0)) }-addParens True it@NameAnnOnly{} =-        it{nann_adornment = NameParens (EpTok (epl 0)) (EpTok (epl 0)) }-addParens True it@NameAnnTrailing{} =-  NameAnn{nann_adornment = NameParens (EpTok (epl 0)) (EpTok (epl 0)), nann_name = epl 0, nann_trailing = nann_trailing it}-#else-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, ..}-#endif-addParens _ it = it+removeComma = removeTrailingCommaAnn  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
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs view
@@ -19,9 +19,10 @@  import           Control.Applicative                               ((<|>)) import           Control.Arrow                                     (second,-                                                                    (&&&),                                                                     (>>>)) import           Control.Concurrent.STM.Stats                      (atomically)+import           Control.Lens                                      hiding (List,+                                                                    uncons, use) import           Control.Monad.Extra import           Control.Monad.IO.Class import           Control.Monad.Trans.Except                        (ExceptT (ExceptT))@@ -29,7 +30,7 @@ import           Data.Char import qualified Data.DList                                        as DL import           Data.Function-import           Data.Functor+import qualified Data.Generics                                     as SYB import qualified Data.HashMap.Strict                               as Map import qualified Data.HashSet                                      as Set import           Data.List.Extra@@ -37,7 +38,6 @@ import qualified Data.List.NonEmpty                                as NE import qualified Data.Map.Strict                                   as M import           Data.Maybe-import           Data.Ord                                          (comparing) import qualified Data.Set                                          as S import qualified Data.Text                                         as T import qualified Data.Text.Encoding                                as T@@ -49,9 +49,13 @@ import           Development.IDE.Core.Shake                        hiding (Log) import           Development.IDE.GHC.Compat                        hiding                                                                    (ImplicitPrelude)-#if !MIN_VERSION_ghc(9,11,0)+import           Development.IDE.GHC.Compat.Error                  (TcRnMessage (..),+                                                                    _CouldNotDeducePred,+                                                                    _TcRnMessage,+                                                                    _TcRnSolverReport,+                                                                    msgEnvelopeErrorL,+                                                                    reportContentL) import           Development.IDE.GHC.Compat.Util-#endif import           Development.IDE.GHC.Error import           Development.IDE.GHC.ExactPrint import qualified Development.IDE.GHC.ExactPrint                    as E@@ -78,11 +82,14 @@ import           GHC.Iface.Ext.Types                               (ContextInfo (..),                                                                     IdentifierDetails (..)) import qualified GHC.LanguageExtensions                            as Lang++import           GHC.Tc.Errors.Types                               (ShadowedNameProvenance (..)) import           Ide.Logger                                        hiding                                                                    (group) import           Ide.PluginUtils                                   (extendToFullLines,                                                                     subRange) import           Ide.Types+import qualified Language.LSP.Protocol.Lens                        as L import           Language.LSP.Protocol.Message                     (Method (..),                                                                     SMethod (..)) import           Language.LSP.Protocol.Types                       (ApplyWorkspaceEditParams (..),@@ -95,14 +102,23 @@                                                                     ShowMessageParams (..),                                                                     TextDocumentIdentifier (TextDocumentIdentifier),                                                                     TextEdit (TextEdit, _range),-                                                                    UInt,                                                                     WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges),                                                                     type (|?) (InL, InR),                                                                     uriToFilePath)+import qualified Language.LSP.Protocol.Types                       as TE (TextEdit (..)) import qualified Text.Fuzzy.Parallel                               as TFP-import           Text.Regex.TDFA                                   ((=~), (=~~))+import           Text.Regex.TDFA                                   ((=~~))  -- See Note [Guidelines For Using CPP In GHCIDE Import Statements]+#if MIN_VERSION_ghc(9,7,0)+import           GHC.Tc.Errors.Types                               (UnusedImportName (..),+                                                                    UnusedImportReason (..))+import           GHC.Tc.Types.Constraint                           (ctLoc,+                                                                    ctOrigin)+--import           GHC.Types.Name.Occurrence (OccName,occNameSpace)+#else+import           Text.Regex.TDFA                                   ((=~))+#endif  #if !MIN_VERSION_ghc(9,9,0) import           Development.IDE.GHC.Compat.ExactPrint             (makeDeltaAst)@@ -120,6 +136,10 @@                                                                     EpaLocation' (..),                                                                     HasLoc (..)) #endif+#if MIN_VERSION_ghc(9,7,0) && !MIN_VERSION_ghc(9,11,0)+import           GHC.Tc.Types.Constraint                           (ctl_env)+import           GHC.Tc.Types.CtLocEnv                             (getCtLocEnvLoc)+#endif  #if MIN_VERSION_ghc(9,11,0) import           GHC                                               (AnnsModule (am_where),@@ -127,8 +147,11 @@                                                                     EpaLocation,                                                                     EpaLocation' (..),                                                                     HasLoc (..))+import           GHC.Tc.Types.CtLoc                                (ctl_env,+                                                                    getCtLocEnvLoc) #endif +import           GHC.Tc.Types.Origin                               (CtOrigin (LiteralOrigin))  ------------------------------------------------------------------------------------------------- @@ -138,12 +161,13 @@   contents <- liftIO $ runAction "hls-refactor-plugin.codeAction.getUriContents" state $ getUriContents $ toNormalizedUri uri   liftIO $ do     let mbFile = toNormalizedFilePath' <$> uriToFilePath uri-    allDiags <- atomically $ fmap fdLspDiagnostic . filter (\d -> mbFile == Just (fdFilePath d)) <$> getDiagnostics state+    allDiags <- atomically $ filter (\d -> mbFile == Just (fdFilePath d)) <$> getDiagnostics state     (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile     let       textContents = fmap Rope.toText contents       actions = caRemoveRedundantImports parsedModule textContents allDiags range uri                <> caRemoveInvalidExports parsedModule textContents allDiags range uri+               <> caDeleteUnusedBindings parsedModule textContents allDiags range uri     pure $ InL actions  -------------------------------------------------------------------------------------------------@@ -151,9 +175,8 @@ iePluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState iePluginDescriptor recorder plId =   let old =-        mkGhcideCAsPlugin [-            wrap suggestExportUnusedTopBinding-          , wrap suggestModuleTypo+        mkGhcideCAsPlugin+          [ wrap suggestModuleTypo           , wrap suggestFixConstructorImport           , wrap suggestExtendImport           , wrap suggestImportDisambiguation@@ -185,7 +208,6 @@     , wrap suggestImplicitParameter     , wrap suggestNewDefinition     , wrap Development.IDE.Plugin.Plugins.AddArgument.plugin-    , wrap suggestDeleteUnusedBinding     ]     plId     "Provides various quick fixes for bindings"@@ -286,6 +308,9 @@ liftEither (Left _)  = mzero liftEither (Right x) = return x +tcMessageFd :: FileDiagnostic -> Maybe TcRnMessage+tcMessageFd fd = fd ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage+ -------------------------------------------------------------------------------------------------  findSigOfDecl :: p ~ GhcPass p0 => (IdP p -> Bool) -> [LHsDecl p] -> Maybe (Sig p)@@ -352,14 +377,6 @@             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-    [ hsib_body-      | L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = (unLoc -> HsSig {sig_body = hsib_body})})) <- decls,-        showSDoc df (ppr hsib_body) == instanceHead-    ]- #if MIN_VERSION_ghc(9,9,0) findDeclContainingLoc :: (Foldable t, HasLoc l) => Position -> t (GenLocated l e) -> Maybe (GenLocated l e) #else@@ -367,31 +384,14 @@ #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 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 occurrence imports", concatMap snd result) =-    result <> [hideAll]+suggestHideShadow :: ParsedSource -> T.Text -> Maybe TcModuleResult -> Maybe HieAstResult -> FileDiagnostic -> [(T.Text, [Either TextEdit Rewrite])]+suggestHideShadow ps fileContents mTcM mHar fd@FileDiagnostic{fdLspDiagnostic=Diagnostic{_range,_message}}+  | Just (TcRnShadowedName occname (ShadowedNameProvenanceGlobal gres)) <- tcMessageFd fd ,+    identifier <- printOutputable occname,+    imps <- [(printOutputable $ importSpecModule modl,importSpecLoc modl) | GRE{ gre_imp = iss } <- gres,modl <- iss],+    result@(_:_) <- nubOrdBy (compare `on` fst) $ imps >>= uncurry (suggests identifier),+    hideAll <- ("Hide " <> identifier <> " from all occurrence imports", concatMap snd result)+    = result <> [hideAll]   | otherwise = []   where     L _ HsModule {hsmodImports} = ps@@ -399,8 +399,7 @@     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),+        isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) s,         mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName,         title <- "Hide " <> identifier <> " from " <> modName =         if modName == "Prelude" && null mDecl@@ -447,8 +446,9 @@       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,..}+suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> FileDiagnostic -> [(T.Text, [TextEdit])]+#if !MIN_VERSION_ghc(9,7,0)+suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _  HsModule{hsmodImports}} contents FileDiagnostic{fdLspDiagnostic=Diagnostic{_range,_message}} --     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@@ -474,9 +474,32 @@         case matchRegexUnifySpaces binding "([^ ]+)\\(([^)]+)\\)" of           Just [_, fields] -> [binding, fields]           _                -> [binding]+#else+suggestRemoveRedundantImport _ contents+  fd@FileDiagnostic{fdLspDiagnostic=Diagnostic{_range}}+    | Just (TcRnUnusedImport impDecl (UnusedImportSome names)) <- tcMessageFd fd+      , Just c <- contents+      , let bindings = names >>= bindingsInImp+      , ranges <- map (rangesForBindingImport impDecl . T.unpack) bindings+    , ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges)+    , not (null ranges')+      = [( "Remove " <> T.intercalate ", " (pprBinding <$> names) <> " from import" , [ TextEdit r "" | r <- ranges' ] )]+    | Just (TcRnUnusedImport _ UnusedImportNone) <- tcMessageFd fd =+      [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]+    | otherwise = []+    where+      bindingsInImp ::UnusedImportName -> [T.Text]+      bindingsInImp (UnusedImportNameRecField NoParent name) = [printOutputable name]+      bindingsInImp b@(UnusedImportNameRecField (ParentIs _) field) = [pprBinding b,printOutputable field]+      bindingsInImp (UnusedImportNameRegular name) = [printOutputable name]+      pprBinding ::UnusedImportName -> T.Text+      pprBinding (UnusedImportNameRecField NoParent name) = printOutputable $ occName name+      pprBinding (UnusedImportNameRecField (ParentIs parent) field) = printOutputable parent <> "("<> printOutputable  field <> ")"+      pprBinding (UnusedImportNameRegular name) = printOutputable name+#endif -diagInRange :: Diagnostic -> Range -> Bool-diagInRange Diagnostic {_range = dr} r = dr `subRange` extendedRange+diagInRange :: FileDiagnostic -> Range -> Bool+diagInRange FileDiagnostic{fdLspDiagnostic=Diagnostic{_range=dr}} r = dr `subRange` extendedRange   where     -- Ensures the range captures full lines. Makes it easier to trigger the correct     -- "remove redundant" code actions from anywhere on the offending line.@@ -488,7 +511,7 @@ -- is likely to be removed and less likely the warning will be disabled. -- Therefore actions to remove a single or all redundant imports should be -- preferred, so that the client can prioritize them higher.-caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> Range -> Uri -> [Command |? CodeAction]+caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [FileDiagnostic] -> Range -> Uri -> [Command |? CodeAction] caRemoveRedundantImports m contents allDiags contextRange uri   | Just pm <- m,     r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) allDiags,@@ -500,7 +523,7 @@       = caRemoveCtx ++ [caRemoveAll]   | otherwise = []   where-    removeSingle title tedit diagnostic = mkCA title (Just CodeActionKind_QuickFix) Nothing [diagnostic] WorkspaceEdit{..} where+    removeSingle title tedit diagnostic = mkCA title (Just CodeActionKind_QuickFix) Nothing [fdLspDiagnostic diagnostic] WorkspaceEdit{..} where         _changes = Just $ M.singleton uri tedit         _documentChanges = Nothing         _changeAnnotations = Nothing@@ -518,7 +541,7 @@         _data_ = Nothing         _changeAnnotations = Nothing -caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> Range -> Uri -> [Command |? CodeAction]+caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [FileDiagnostic] -> Range -> Uri -> [Command |? CodeAction] caRemoveInvalidExports m contents allDiags contextRange uri   | Just pm <- m,     Just txt <- contents,@@ -541,13 +564,14 @@       = Just (title, dig, ranges)       | otherwise = Nothing +    removeSingle :: (T.Text, FileDiagnostic, [Range]) -> Maybe (Command |? CodeAction)     removeSingle (_, _, []) = Nothing     removeSingle (title, diagnostic, ranges) = Just $ InR $ CodeAction{..} where         tedit = concatMap (\r -> [TextEdit r ""]) $ nubOrd ranges         _changes = Just $ M.singleton uri tedit         _title = title         _kind = Just CodeActionKind_QuickFix-        _diagnostics = Just [diagnostic]+        _diagnostics = Just [fdLspDiagnostic diagnostic]         _documentChanges = Nothing         _edit = Just WorkspaceEdit{..}         _command = Nothing@@ -572,32 +596,41 @@         _data_ = Nothing         _changeAnnotations = Nothing -suggestRemoveRedundantExport :: ParsedModule -> Diagnostic -> Maybe (T.Text, [Range])-suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..}-  | msg <- unifySpaces _message+suggestRemoveRedundantExport :: ParsedModule -> FileDiagnostic -> Maybe (T.Text, [Range])+suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} fd@FileDiagnostic{fdLspDiagnostic=Diagnostic{_range,_message}}+    | modl <-  (tcMessageFd fd) >>= unnecessaryExportModule+  , msg <- unifySpaces _message   , Just export <- hsmodExports   , Just exportRange <- getLocatedRange export   , exports <- unLoc export   , Just (removeFromExport, !ranges) <- fmap (getRanges exports . notInScope) (extractNotInScopeName msg)-                         <|> (,[_range]) <$> matchExportItem msg-                         <|> (,[_range]) <$> matchDupExport msg+                         <|>  (,[_range]) <$> modl   , 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])]+unnecessaryExportModule :: TcRnMessage -> Maybe T.Text+unnecessaryExportModule (TcRnDupeModuleExport (ModuleName mod))       = Just $ T.pack $ "Module " <> unpackFS mod+unnecessaryExportModule (TcRnExportedModNotImported (ModuleName mod)) = Just $ T.pack $ "Module " <> unpackFS mod+unnecessaryExportModule (TcRnNullExportedModule (ModuleName mod))     = Just $ T.pack $ "Module " <> unpackFS mod+unnecessaryExportModule (TcRnMissingExportList (ModuleName mod))      = Just $ T.pack $ "Module " <> unpackFS mod+#if MIN_VERSION_ghc(9,7,0)+unnecessaryExportModule (TcRnDodgyExports (GRE {gre_name})) = Just (( printOutputable $ occName gre_name) <> "(..)" )+#else+unnecessaryExportModule (TcRnDodgyExports name) = Just (( printOutputable $ occName name) <> "(..)" )+#endif+unnecessaryExportModule _ = Nothing++suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> FileDiagnostic -> [(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: ‘([^ ]+)’"+  fd@FileDiagnostic{fdLspDiagnostic=Diagnostic{_range,_message}}+    | Just name <- unusedName fd     , Just indexedContent <- indexedByPosition . T.unpack <$> contents       = let edits = flip TextEdit "" <$> relatedRanges indexedContent (T.unpack name)         in ([("Delete ‘" <> name <> "’", edits) | not (null edits)])@@ -661,7 +694,7 @@               in Just (mkSrcSpan startLoc' endLoc', False)       findRelatedSigSpan1 _ _ = Nothing -      -- for where clause+      -- for where and let expression bindings       findRelatedSpanForMatch         :: PositionIndexedString         -> String@@ -670,7 +703,7 @@       findRelatedSpanForMatch         indexedContent         name-        (L _ Match{m_grhss=GRHSs{grhssLocalBinds}}) = do+        (L _ Match{m_grhss=GRHSs{grhssLocalBinds, grhssGRHSs}}) = do         let emptyBag bag = #if MIN_VERSION_ghc(9,11,0)                 null bag@@ -681,10 +714,23 @@                   if emptyBag bag                   then []                   else concatMap (findRelatedSpanForHsBind indexedContent name lsigs) bag-        case grhssLocalBinds of-          (HsValBinds _ (ValBinds _ bag lsigs)) -> go bag lsigs-          _                                     -> [] +            findLetBinds :: SYB.GenericQ (DL.DList (HsLocalBinds GhcPs))+            findLetBinds = SYB.everything mappend (mempty `SYB.mkQ` letBinds)+              where+                letBinds :: HsExpr GhcPs -> DL.DList (HsLocalBinds GhcPs)+                letBinds = \case+#if !MIN_VERSION_ghc(9,9,0)+                    HsLet _ _ lb _ _ -> pure lb+#else+                    HsLet _ lb _ -> pure lb+#endif+                    _            -> mempty++        flip concatMap (grhssLocalBinds : DL.toList (findLetBinds grhssGRHSs)) $ \case+                (HsValBinds _ (ValBinds _ bag lsigs)) -> go bag lsigs+                _                                     -> []+       findRelatedSpanForHsBind         :: PositionIndexedString         -> String@@ -710,102 +756,78 @@       isSameName :: IdP GhcPs -> String -> Bool       isSameName x name = T.unpack (printOutputable x) == name -data ExportsAs = ExportName | ExportPattern | ExportFamily | ExportAll-  deriving (Eq)--getLocatedRange :: HasSrcSpan a => a -> Maybe Range-getLocatedRange = srcSpanToRange . getLoc+unusedName :: FileDiagnostic -> Maybe T.Text+#if MIN_VERSION_ghc(9,7,0)+unusedName fd = do+  (TcRnUnusedName name _reason) <- tcMessageFd fd+  return $ printOutputable name+#else+unusedName FileDiagnostic{fdLspDiagnostic=Diagnostic{_message}} = do+  [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’"+  return name+#endif -suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> Diagnostic -> Maybe (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: (type constructor or class |data constructor )?‘([^ ]+)’"-  , Just (exportType, _) <--      find (matchWithDiagnostic _range . snd)-      . mapMaybe (\(L l b) -> if isTopLevel (locA l) then exportsAs b else Nothing)-      $ hsmodDecls-  , Just exports       <- fmap (fmap reLoc) . reLoc <$> hsmodExports-  , Just exportsEndPos <- _end <$> getLocatedRange exports-  , let name'          = printExport exportType name-        sep            = exportSep source $ map getLocatedRange <$> exports-        exportName     = case sep of-          Nothing -> (if needsComma source exports then ", " else "") <> name'-          Just  s -> s <> name'-        exportsEndPos' = exportsEndPos { _character = pred $ _character exportsEndPos }-        insertPos      = fromMaybe exportsEndPos' $ case (sep, unLoc exports) of-          (Just _, exports'@(_:_)) -> fmap _end . getLocatedRange $ last exports'-          _                        -> Nothing-  = Just ("Export ‘" <> name <> "’", TextEdit (Range insertPos insertPos) exportName)-  | otherwise = Nothing+caDeleteUnusedBindings :: Maybe ParsedModule -> Maybe T.Text -> [FileDiagnostic] -> Range -> Uri -> [Command |? CodeAction]+caDeleteUnusedBindings m contents allDiags contextRange uri+  | Just pm <- m,+    r <- join $ map (\d -> repeat d `zip` suggestDeleteUnusedBinding pm contents d) allDiags,+    -- `allEdits` contains the representative edits to make.+    -- Representative means the edit with a range that subsumes the others,+    -- because GHC emits diagnostics for the top level binding *and* the where clause.+    allEdits <-+      -- take the representative and drop the others+      concatMap headToList $+      -- deduplicate by creating groups of ranges (same group if any subsumes the other)+      groupBy subsumesEither+      -- Sort to put related ranges next to each other+      (sortOn TE._range [ e | (_, (_, edits)) <- r, e <- edits]),+    caRemoveAll <- removeAll allEdits,+    ctxEdits <- [ x | x@(d, _) <- r, d `diagInRange` contextRange],+    not $ null ctxEdits,+    caRemoveCtx <- map (\(d, (title, tedit)) -> removeSingle title tedit d) ctxEdits+      = caRemoveCtx ++ [caRemoveAll]+  | otherwise = []   where-    exportSep :: T.Text -> Located [Maybe Range] -> Maybe T.Text-    exportSep src (L (RealSrcSpan _ _) xs@(_ : tl@(_ : _))) =-      case mapMaybe (\(e, s) -> (,) <$> e <*> s) $ zip (fmap _end <$> xs) (fmap _start <$> tl) of-        []     -> Nothing-        bounds -> Just smallestSep-          where-            smallestSep-              = snd-              $ minimumBy (comparing fst)-              $ map (T.length &&& id)-              $ nubOrd-              $ map (\(prevEnd, nextStart) -> textInRange (Range prevEnd nextStart) src) bounds-    exportSep _   _ = Nothing--    -- We get the last export and the closing bracket and check for comma in that range.-    needsComma :: T.Text -> Located [Located (IE GhcPs)] -> Bool-    needsComma _ (L _ []) = False-    needsComma source (L (RealSrcSpan l _) exports) =-      let closeParen = _end $ realSrcSpanToRange l-          lastExport = fmap _end . getLocatedRange $ last exports-      in-      case lastExport of-        Just lastExport ->-          not $ T.any (== ',') $ textInRange (Range lastExport closeParen) source-        _ -> False-    needsComma _ _ = False--    opLetter :: T.Text-    opLetter = ":!#$%&*+./<=>?@\\^|-~"--    parenthesizeIfNeeds :: Bool -> T.Text -> T.Text-    parenthesizeIfNeeds needsTypeKeyword x-      | T.any (c ==) opLetter = (if needsTypeKeyword then "type " else "") <> "(" <> x <> ")"-      | otherwise = x-      where-        c = T.head 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 " <> parenthesizeIfNeeds False x-    printExport ExportFamily x  = parenthesizeIfNeeds True x-    printExport ExportAll x     = parenthesizeIfNeeds True x <> "(..)"--    isTopLevel :: SrcSpan -> Bool-    isTopLevel span = fmap (_character . _start) (srcSpanToRange span) == Just 0+    removeSingle title tedit fd = mkCA title (Just CodeActionKind_QuickFix) Nothing [fdLspDiagnostic fd] WorkspaceEdit{..} where+        _changes = Just $ M.singleton uri tedit+        _documentChanges = Nothing+        _changeAnnotations = Nothing+    removeAll tedit = InR $ CodeAction{..} where+        _changes = Just $ M.singleton uri tedit+        _title = "Delete all unused bindings"+        _kind = Just CodeActionKind_QuickFix+        _diagnostics = Nothing+        _documentChanges = Nothing+        _edit = Just WorkspaceEdit{..}+        _isPreferred = Just False+        _command = Nothing+        _disabled = Nothing+        _data_ = Nothing+        _changeAnnotations = Nothing+    headToList []      = []+    headToList (x : _) = [x]+    subsumesEither (TE._range -> range1) (TE._range -> range2) = subRange range1 range2 || subRange range2 range1 -    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+getLocatedRange :: HasSrcSpan a => a -> Maybe Range+getLocatedRange = srcSpanToRange . getLoc -suggestAddTypeAnnotationToSatisfyConstraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestAddTypeAnnotationToSatisfyConstraints sourceOpt Diagnostic{_range=_range,..}+suggestAddTypeAnnotationToSatisfyConstraints :: Maybe T.Text -> FileDiagnostic -> [(T.Text, [TextEdit])]+#if MIN_VERSION_ghc(9,7,0)+suggestAddTypeAnnotationToSatisfyConstraints _ fd@FileDiagnostic{fdLspDiagnostic=Diagnostic{_range,_message}}+    | Just (TcRnWarnDefaulting cts _ typ ) <- (tcMessageFd fd)+    , ((lit,ct):_) <- [(lit , x) |   x <- cts, LiteralOrigin lit <- [ctOrigin x]]+    , typ <- printOutputable typ+    , lit <- printOutputable lit+    = codeEdit (realSrcSpanToRange $ getCtLocEnvLoc $ ctl_env $ ctLoc ct) typ lit (makeAnnotatedLit typ lit)+    | otherwise = []+    where+      makeAnnotatedLit ty lit = "(" <> lit <> " :: " <> ty <> ")"+      codeEdit range ty lit replacement =+        let title = "Add type annotation ‘" <> ty <> "’ to ‘" <> lit <> "’"+            edits = [TextEdit range replacement]+        in  [( title, edits )]+#else+suggestAddTypeAnnotationToSatisfyConstraints sourceOpt FileDiagnostic{fdLspDiagnostic=Diagnostic{_range,_message}} -- File.hs:52:41: warning: --     * Defaulting the following constraint to type ‘Integer’ --        Num p0 arising from the literal ‘1’@@ -865,6 +887,7 @@         let title = "Add type annotation ‘" <> ty <> "’ to ‘" <> lit <> "’"             edits = [TextEdit range replacement]         in  [( title, edits )]+#endif  -- | GHC strips out backticks in case of infix functions as well as single quote --   in case of quoted name when using TemplateHaskellQuotes. Which is not desired.@@ -1236,76 +1259,39 @@                _                                  -> Nothing  -- | Suggests a constraint for a declaration for which a constraint is missing.-suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)]-suggestConstraint df ps diag@Diagnostic {..}-  | Just missingConstraint <- findMissingConstraint _message-  = let+suggestConstraint :: ParsedSource -> FileDiagnostic -> [(T.Text, Rewrite)]+suggestConstraint ps fd+  | Just missingConstraint <- structuredMissingConstraint+  = #if MIN_VERSION_ghc(9,9,0)-        parsedSource = ps+    let parsedSource = ps in #else-        parsedSource = makeDeltaAst ps+    let parsedSource = makeDeltaAst ps in #endif-        codeAction = if _message =~ ("the type signature for:" :: String)-                        then suggestFunctionConstraint df parsedSource-                        else suggestInstanceConstraint df parsedSource-     in codeAction diag missingConstraint+    -- The error site sits in exactly one of the two, so at most one fires.+       suggestFunctionConstraint parsedSource diag missingConstraint+    ++ suggestInstanceConstraint parsedSource diag missingConstraint   | otherwise = []     where-      findMissingConstraint :: T.Text -> Maybe T.Text-      findMissingConstraint t =-        let -- The regex below can be tested at:-            --   https://regex101.com/r/dfSivJ/1-            regex = "(No instance for|Could not deduce):? (\\((.+)\\)|‘(.+)’|.+) arising from" -- a use of / a do statement--            match = matchRegexUnifySpaces t regex--            -- For a string like:-            --   "Could not deduce: ?a::() arising from"-            -- The `matchRegexUnifySpaces` function returns two empty match-            -- groups at the end of the list. It's not clear why this is the-            -- case, so we select the last non-empty match group.-            getCorrectGroup = last . filter (/="")+      diag = fdLspDiagnostic fd -        in getCorrectGroup <$> match+      -- The missing constraint, taken from GHC's structured solver report.+      structuredMissingConstraint =+        fmap printOutputable $+          fd ^? fdStructuredMessageL+            . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage+            . _TcRnSolverReport . _1 . reportContentL . _CouldNotDeducePred  -- | 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)]+suggestInstanceConstraint :: ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)]+suggestInstanceConstraint (L _ HsModule {hsmodDecls}) diag missingConstraint+  -- The error range is inside an instance method, so the enclosing declaration+  -- is the instance whose context gains the constraint.+  | Just (L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = (unLoc -> HsSig{sig_body = sig})})))+      <- findDeclContainingLoc (diag ^. L.range . L.start) hsmodDecls+  = [(actionTitle missingConstraint, appendConstraint (T.unpack missingConstraint) sig)]   | otherwise = []     where-      instanceHead-        -- Suggests a constraint for an instance declaration with no existing constraints.-        -- • No instance for (Eq a) arising from a use of ‘==’-        --   Possible fix: add (Eq a) to the context of the instance declaration-        -- • In the expression: x == y-        --   In an equation for ‘==’: (Wrap x) == (Wrap y) = x == y-        --   In the instance declaration for ‘Eq (Wrap a)’-        | Just [instanceDeclaration] <- matchRegexUnifySpaces _message "In the instance declaration for ‘([^`]*)’"-        , Just instHead <- findInstanceHead df (T.unpack instanceDeclaration) hsmodDecls-        = Just instHead-        -- Suggests a constraint for an instance declaration with one or more existing constraints.-        -- • Could not deduce (Eq b) arising from a use of ‘==’-        --   from the context: Eq a-        --     bound by the instance declaration at /path/to/Main.hs:7:10-32-        --   Possible fix: add (Eq b) to the context of the instance declaration-        -- • In the second argument of ‘(&&)’, namely ‘x' == y'’-        --   In the expression: x == y && x' == y'-        --   In an equation for ‘==’:-        --       (Pair x x') == (Pair y y') = x == y && x' == y'-        | Just [instanceLineStr, constraintFirstCharStr]-            <- matchRegexUnifySpaces _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)"-        , Just (L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = (unLoc -> HsSig{sig_body = hsib_body})})))-            <- 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"@@ -1314,9 +1300,9 @@   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,+suggestImplicitParameter (L _ HsModule {hsmodDecls}) diag+  | Just [implicitT] <- matchRegexUnifySpaces (diag ^. L.message) "Unbound implicit parameter \\(([^:]+::.+)\\) arising",+    Just (L _ (ValD _ FunBind {fun_id = L _ funId})) <- findDeclContainingLoc (diag ^. L.range . L.start) hsmodDecls,     Just (TypeSig _ _ HsWC {hswc_body = (unLoc -> HsSig {sig_body = hsib_body})})       <- findSigOfDecl (== funId) hsmodDecls     =@@ -1328,35 +1314,15 @@ findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " >>= listToMaybe  -- | Suggests a constraint for a type signature with any number of existing constraints.-suggestFunctionConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)]--suggestFunctionConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint--- • No instance for (Eq a) arising from a use of ‘==’---   Possible fix:---     add (Eq a) to the context of---       the type signature for:---         eq :: forall a. a -> a -> Bool--- • In the expression: x == y---   In an equation for ‘eq’: eq x y = x == y---- • Could not deduce (Eq b) arising from a use of ‘==’---   from the context: Eq a---     bound by the type signature for:---                eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool---     at Main.hs:5:1-42---   Possible fix:---     add (Eq b) to the context of---       the type signature for:---         eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool--- • In the second argument of ‘(&&)’, namely ‘y == y'’---   In the expression: x == x' && y == y'---   In an equation for ‘eq’:---       eq (Pair x y) (Pair x' y') = x == x' && y == y'-  | Just typeSignatureName <- findTypeSignatureName _message-  , Just (TypeSig _ _ HsWC{hswc_body = (unLoc -> HsSig {sig_body = sig})})-    <- findSigOfDecl ((T.unpack typeSignatureName ==) . showSDoc df . ppr) hsmodDecls+suggestFunctionConstraint :: ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)]+suggestFunctionConstraint (L _ HsModule {hsmodDecls}) diag missingConstraint+  -- The error range is inside the function body, so the enclosing binding names+  -- the signature whose context gains the constraint.+  | Just (L _ (ValD _ FunBind {fun_id = L _ funId})) <- findDeclContainingLoc (diag ^. L.range . L.start) hsmodDecls+  , Just (TypeSig _ _ HsWC{hswc_body = (unLoc -> HsSig {sig_body})}) <- findSigOfDecl (== funId) hsmodDecls+  , let typeSignatureName = T.pack (printRdrName funId)   , title <- actionTitle missingConstraint typeSignatureName-  = [(title, appendConstraint (T.unpack missingConstraint) sig)]+  = [(title, appendConstraint (T.unpack missingConstraint) sig_body)]   | otherwise   = []     where@@ -1948,7 +1914,7 @@       linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)  -- | Returns the ranges for a binding in an import declaration-rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range]+rangesForBindingImport ::  OutputableBndrId p => ImportDecl (GhcPass p) -> String -> [Range] rangesForBindingImport ImportDecl{   ideclImportList = Just (Exactly, L _ lies)   } b =@@ -1990,7 +1956,7 @@           [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b']     ranges' _ = [] -rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]+rangesForBinding' :: OutputableBndrId p => String -> LIE ( GhcPass  p) -> [SrcSpan] #if MIN_VERSION_ghc(9,9,0) rangesForBinding' b (L (locA -> l) (IEVar _ nm _)) #else@@ -2029,12 +1995,6 @@   -- 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  -- | Process a list of (module_name, filename:src_span) values --
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs view
@@ -22,8 +22,7 @@ import           Data.Functor                                 ((<&>)) import           Data.IORef.Extra import qualified Data.Map                                     as Map-import           Data.Maybe                                   (fromMaybe,-                                                               maybeToList)+import           Data.Maybe                                   (fromMaybe) import qualified Data.Text                                    as T import qualified Data.Text.Utf16.Rope.Mixed                   as Rope import           Development.IDE                              hiding@@ -80,7 +79,7 @@         caaHar <- onceIO $ runRule GetHieAst         caaBindings <- onceIO $ runRule GetBindings         caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs-        diags <- concat . maybeToList <$> activeDiagnosticsInRange (shakeExtras state) nfp _range+        diags <- activeDiagnosticsInRange (shakeExtras state) nfp _range         results <- liftIO $             sequence                 [
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs view
@@ -25,6 +25,8 @@ import           Development.IDE.GHC.Compat             hiding (Annotation) import           Development.IDE.GHC.Error import           Development.IDE.GHC.ExactPrint+import           Development.IDE.GHC.ExactPrint.Annotation (addParens, epl,+                                                            modifyAnns) import           Development.IDE.GHC.Util import           Development.IDE.Spans.Common import           GHC.Exts                               (IsList (fromList))@@ -202,7 +204,11 @@             [L _ (HsParTy EpAnn{anns=AnnParen{ap_close}} _)] -> Just ap_close #endif             _ -> Nothing-        ctxt' = over _last (first addComma) $ map dropHsParTy ctxt+        -- Drop parens only for a lone constraint. In a multi-constraint context+        -- an element's parens may be required.+        ctxt' = over _last (first addComma) $ case ctxt of+            [c] -> [dropHsParTy c]+            _   -> ctxt     return $ L l $ it{hst_ctxt = L l'' $ ctxt' ++ [constraint]}   go (L _ HsForAllTy{hst_body}) = go hst_body   go (L _ (HsParTy _ ty)) = go ty@@ -243,7 +249,7 @@ #endif  liftParseAST-    :: forall ast l.  (ASTElement l ast, ExactPrint (LocatedAn l ast))+    :: forall ast l.  (ASTElement l ast)     => DynFlags -> String -> TransformT (Either String) (LocatedAn l ast) liftParseAST df s = case parseAST df "" s of   Right x ->  pure (makeDeltaAst x)
− plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs 
@@ -1,20 +0,0 @@-module Development.IDE.Plugin.CodeAction.RuleTypes-    (PackageExports(..)-    ,IdentInfo(..)-    ) where--import           Control.DeepSeq                (NFData)-import           Data.Hashable                  (Hashable)-import           Development.IDE.Graph          (RuleResult)-import           Development.IDE.Types.Exports-import           Development.IDE.Types.HscEnvEq (HscEnvEq)-import           GHC.Generics                   (Generic)---- Rule type for caching Package Exports-type instance RuleResult PackageExports = ExportsMap--newtype PackageExports = PackageExports HscEnvEq-    deriving (Eq, Show, Generic)--instance Hashable PackageExports-instance NFData   PackageExports
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs view
@@ -26,7 +26,7 @@ -- See Note [Guidelines For Using CPP In GHCIDE Import Statements]  #if MIN_VERSION_ghc(9,6,0) && !MIN_VERSION_ghc(9,9,0)-import           Development.IDE.GHC.ExactPrint            (epl)+import           Development.IDE.GHC.ExactPrint.Annotation (epl) import           GHC.Parser.Annotation                     (TokenLocation (..)) #endif
plugins/hls-refactor-plugin/test/Main.hs view
@@ -317,7 +317,6 @@   , addFunctionConstraintTests   , removeRedundantConstraintsTests   , addTypeAnnotationsToLiteralsTest-  , exportUnusedTests   , addImplicitParamsConstraintTests   , removeExportTests   , Test.AddArgument.tests@@ -1291,7 +1290,7 @@                     , "b :: A"                     , "b = 0"                     ])-            (Range (Position 2 5) (Position 2 5))+            (Range (Position 2 5) (Position 2 6))             ["Add A to the import list of ModuleA"]             (T.unlines                     [ "module ModuleB where"@@ -2508,6 +2507,7 @@       , "some = ()"       ]       (4, 0)+      1       "Delete ‘f’"       [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"       , "module A (some) where"@@ -2525,6 +2525,7 @@       , "some = ()"       ]       (4, 2)+      1       "Delete ‘myPlus’"       [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"       , "module A (some) where"@@ -2547,6 +2548,7 @@       , ""       ]       (10, 4)+      1       "Delete ‘h’"       [ "{-# OPTIONS_GHC -Wunused-binds #-}"       , "module A (h, g) where"@@ -2570,6 +2572,7 @@       , "c = 5"       ]       (4, 0)+      1       "Delete ‘a’"       [ "{-# OPTIONS_GHC -Wunused-binds #-}"       , "module A (b, c) where"@@ -2589,6 +2592,7 @@       , "c = 5"       ]       (5, 0)+      1       "Delete ‘b’"       [ "{-# OPTIONS_GHC -Wunused-binds #-}"       , "module A (a, c) where"@@ -2608,6 +2612,7 @@       , "c = 5"       ]       (6, 0)+      1       "Delete ‘c’"       [ "{-# OPTIONS_GHC -Wunused-binds #-}"       , "module A (a, b) where"@@ -2615,12 +2620,65 @@       , "a, b :: Int"       , "a = 3"       , "b = 4"+      ],+  testSession "delete all unused level bindings" $+    testFor+      [ "{-# OPTIONS_GHC -Wunused-binds #-}"+      , "module A (some) where"+      , ""+      , "f :: Int -> Int"+      , "f 1 = let a = 1"+      , "      in a"+      , "f 2 = 2"+      , ""+      , "some = ()"+      , "  where"+      , "    a = 2"+      , ""+      , "unusedSome :: ()"+      , "unusedSome = ()"       ]+      (4, 0)+      3+      "Delete all unused bindings"+      [ "{-# OPTIONS_GHC -Wunused-binds #-}"+      , "module A (some) where"+      , ""+      , "some = ()"+      , "  where"+      ],+  testSession "delete unused local let expr bindings" $+    testFor+      [ "{-# OPTIONS_GHC -Wunused-binds #-}"+      , "module A (a, b, c) where"+      , ""+      , "a = let b = 1 in 2"+      , ""+      , "b = let c = 1"+      , "        d = 1"+      , "    in let e = 2 in d"+      , ""+      , "c = if (let a = 2 in True) then 1 else 1"+      ]+      (3, 8)+      4+      "Delete all unused bindings"+      [ "{-# OPTIONS_GHC -Wunused-binds #-}"+      , "module A (a, b, c) where"+      , ""+      , "a = let in 2"+      , ""+      , "b = let"+      , "        d = 1"+      , "    in let in d"+      , ""+      , "c = if (let in True) then 1 else 1"+      ]   ]   where-    testFor sourceLines pos@(l,c) expectedTitle expectedLines = do+    testFor sourceLines pos@(l,c) expectedNbrWarnings expectedTitle expectedLines = do       docId <- createDoc "A.hs" "haskell" $ T.unlines sourceLines-      expectDiagnostics [ ("A.hs", [(DiagnosticSeverity_Warning, pos, "not used", Nothing)]) ]+      expectDiagnostics [ ("A.hs", replicate expectedNbrWarnings (DiagnosticSeverity_Warning, pos, "not used", Nothing)) ]       action <- pickActionWithTitle expectedTitle =<< getCodeActions docId  (R l c l c)       executeCodeAction action       contentAfterAction <- documentContents docId@@ -2900,7 +2958,7 @@               ]       doc <- createDoc "Test.hs" "haskell" $ mkDoc "_"       _ <- waitForDiagnostics-      actions <- getCodeActions doc (Range (Position 2 13) (Position 2 14))+      actions <- getCodeActions doc (Range (Position 2 12) (Position 2 13))       chosen <- pickActionWithTitle "Replace _ with (<$>)" actions       executeCodeAction chosen       modifiedCode <- documentContents doc@@ -2913,7 +2971,7 @@               ]       doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`"       _ <- waitForDiagnostics-      actions <- getCodeActions doc (Range (Position 2 16) (Position 2 19))+      actions <- getCodeActions doc (Range (Position 2 18) (Position 2 19))       chosen <- pickActionWithTitle "Replace _ with (<$>)" actions       executeCodeAction chosen       modifiedCode <- documentContents doc@@ -3076,6 +3134,16 @@     , "  return ()"     ] +  -- See https://github.com/haskell/haskell-language-server/issues/3486+  quantifiedConstraintSourceCode :: T.Text -> T.Text+  quantifiedConstraintSourceCode context = T.unlines+    [ "{-# LANGUAGE QuantifiedConstraints #-}"+    , "{-# LANGUAGE RankNTypes #-}"+    , "module Testing where"+    , "f :: " <> context <> " => f Int -> m Bool"+    , "f x = return (x == x)"+    ]+   in testGroup "add function constraint"   [ checkCodeAction     "no preexisting constraint"@@ -3122,6 +3190,11 @@     "Add `Monad m` to the context of the type signature for `f`"     (missingMonadConstraint "")     (missingMonadConstraint "Monad m => ")+  , checkCodeAction+    "preexisting parenthesized quantified constraint"+    "Add `Monad m` to the context of the type signature for `f`"+    (quantifiedConstraintSourceCode "((forall a. Eq (f a)), Applicative m)")+    (quantifiedConstraintSourceCode "((forall a. Eq (f a)), Applicative m, Monad m)")   ]  checkCodeAction :: TestName -> T.Text -> T.Text -> T.Text -> TestTree@@ -3406,355 +3479,6 @@     , "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" -- in this test group we check that no code actions are created-    [ testSession "implicit exports" $ templateNoAction-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "{-# OPTIONS_GHC -Wmissing-signatures #-}"-      , "module A where"-      , "foo = id"-      ]-      (R 3 0 3 3)-      "Export ‘foo’"-    , testSession "not top-level" $ templateNoAction-      [ "{-# 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’"-    , testSession "type is exported but not the constructor of same name" $ templateNoAction-        [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-        , "module A (Foo) where"-        , "data Foo = Foo"-        ]-        (R 2 0 2 8)-        "Export ‘Foo’"-    , testSession "unused data field" $ templateNoAction-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A (Foo(Foo)) where"-      , "data Foo = Foo {foo :: ()}"-      ]-      (R 2 0 2 20)-      "Export ‘foo’"-    ]-  , testGroup "want suggestion"-    [ testSession "empty exports" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A ("-      , ") where"-      , "foo = id"-      ]-      (R 3 0 3 3)-      "Export ‘foo’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A ("-      , "foo) where"-      , "foo = id"-      ]-    , testSession "single line explicit exports" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A (foo) where"-      , "foo = id"-      , "bar = foo"-      ]-      (R 3 0 3 3)-      "Export ‘bar’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A (foo, bar) where"-      , "foo = id"-      , "bar = foo"-      ]-    , testSession "multi line explicit exports" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A"-      , "  ("-      , "    foo) where"-      , "foo = id"-      , "bar = foo"-      ]-      (R 5 0 5 3)-      "Export ‘bar’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A"-      , "  ("-      , "    foo, bar) where"-      , "foo = id"-      , "bar = foo"-      ]-    , testSession "export list ends in comma" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A"-      , "  (foo,"-      , "  ) where"-      , "foo = id"-      , "bar = foo"-      ]-      (R 5 0 5 3)-      "Export ‘bar’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A"-      , "  (foo,"-      , "  bar) where"-      , "foo = id"-      , "bar = foo"-      ]-    , testSession "style of multiple exports is preserved 1" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A"-      , "  ( foo"-      , "  , bar"-      , "  ) where"-      , "foo = id"-      , "bar = foo"-      , "baz = bar"-      ]-      (R 7 0 7 3)-      "Export ‘baz’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A"-      , "  ( foo"-      , "  , bar"-      , "  , baz"-      , "  ) where"-      , "foo = id"-      , "bar = foo"-      , "baz = bar"-      ]-    , testSession "style of multiple exports is preserved 2" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A"-      , "  ( foo,"-      , "    bar"-      , "  ) where"-      , "foo = id"-      , "bar = foo"-      , "baz = bar"-      ]-      (R 7 0 7 3)-      "Export ‘baz’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A"-      , "  ( foo,"-      , "    bar,"-      , "    baz"-      , "  ) where"-      , "foo = id"-      , "bar = foo"-      , "baz = bar"-      ]-    , testSession "style of multiple exports is preserved and selects smallest export separator" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A"-      , "  ( foo"-      , "  , bar"-      , "  -- * For testing"-      , "  , baz"-      , "  ) where"-      , "foo = id"-      , "bar = foo"-      , "baz = bar"-      , "quux = bar"-      ]-      (R 10 0 10 4)-      "Export ‘quux’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A"-      , "  ( foo"-      , "  , bar"-      , "  -- * For testing"-      , "  , baz"-      , "  , quux"-      , "  ) where"-      , "foo = id"-      , "bar = foo"-      , "baz = bar"-      , "quux = bar"-      ]-    , testSession "unused pattern synonym" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "{-# LANGUAGE PatternSynonyms #-}"-      , "module A () where"-      , "pattern Foo a <- (a, _)"-      ]-      (R 3 0 3 10)-      "Export ‘Foo’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "{-# LANGUAGE PatternSynonyms #-}"-      , "module A (pattern Foo) where"-      , "pattern Foo a <- (a, _)"-      ]-    , testSession "unused pattern synonym operator" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "{-# LANGUAGE PatternSynonyms #-}"-      , "module A () where"-      , "pattern x :+ y = (x, y)"-      ]-      (R 3 0 3 12)-      "Export ‘:+’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "{-# LANGUAGE PatternSynonyms #-}"-      , "module A (pattern (:+)) where"-      , "pattern x :+ y = (x, y)"-      ]-    , testSession "unused data type" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A () where"-      , "data Foo = Foo"-      ]-      (R 2 0 2 7)-      "Export ‘Foo’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A (Foo(..)) where"-      , "data Foo = Foo"-      ]-    , testSession "unused newtype" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A () where"-      , "newtype Foo = Foo ()"-      ]-      (R 2 0 2 10)-      "Export ‘Foo’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A (Foo(..)) where"-      , "newtype Foo = Foo ()"-      ]-    , testSession "unused type synonym" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A () where"-      , "type Foo = ()"-      ]-      (R 2 0 2 7)-      "Export ‘Foo’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A (Foo) where"-      , "type Foo = ()"-      ]-    , testSession "unused type family" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "{-# LANGUAGE TypeFamilies #-}"-      , "module A () where"-      , "type family Foo p"-      ]-      (R 3 0 3 15)-      "Export ‘Foo’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "{-# LANGUAGE TypeFamilies #-}"-      , "module A (Foo) where"-      , "type family Foo p"-      ]-    , testSession "unused typeclass" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A () where"-      , "class Foo a"-      ]-      (R 2 0 2 8)-      "Export ‘Foo’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A (Foo(..)) where"-      , "class Foo a"-      ]-    , testSession "infix" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A () where"-      , "a `f` b = ()"-      ]-      (R 2 0 2 11)-      "Export ‘f’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A (f) where"-      , "a `f` b = ()"-      ]-    , testSession "function operator" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A () where"-      , "(<|) = ($)"-      ]-      (R 2 0 2 9)-      "Export ‘<|’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "module A ((<|)) where"-      , "(<|) = ($)"-      ]-    , testSession "type synonym operator" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "{-# LANGUAGE TypeOperators #-}"-      , "module A () where"-      , "type (:<) = ()"-      ]-      (R 3 0 3 13)-      "Export ‘:<’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "{-# LANGUAGE TypeOperators #-}"-      , "module A ((:<)) where"-      , "type (:<) = ()"-      ]-    , testSession "type family operator" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "{-# LANGUAGE TypeFamilies #-}"-      , "{-# LANGUAGE TypeOperators #-}"-      , "module A () where"-      , "type family (:<)"-      ]-      (R 4 0 4 15)-      "Export ‘:<’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "{-# LANGUAGE TypeFamilies #-}"-      , "{-# LANGUAGE TypeOperators #-}"-      , "module A (type (:<)) where"-      , "type family (:<)"-      ]-    , testSession "typeclass operator" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "{-# LANGUAGE TypeOperators #-}"-      , "module A () where"-      , "class (:<) a"-      ]-      (R 3 0 3 11)-      "Export ‘:<’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "{-# LANGUAGE TypeOperators #-}"-      , "module A (type (:<)(..)) where"-      , "class (:<) a"-      ]-    , testSession "newtype operator" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "{-# LANGUAGE TypeOperators #-}"-      , "module A () where"-      , "newtype (:<) = Foo ()"-      ]-      (R 3 0 3 20)-      "Export ‘:<’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "{-# LANGUAGE TypeOperators #-}"-      , "module A (type (:<)(..)) where"-      , "newtype (:<) = Foo ()"-      ]-    , testSession "data type operator" $ template-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "{-# LANGUAGE TypeOperators #-}"-      , "module A () where"-      , "data (:<) = Foo ()"-      ]-      (R 3 0 3 17)-      "Export ‘:<’"-      [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-      , "{-# LANGUAGE TypeOperators #-}"-      , "module A (type (:<)(..)) where"-      , "data (:<) = Foo ()"-      ]-    ]-  ]-  where-    template origLines range actionTitle expectedLines =-      exportTemplate (Just range) origLines actionTitle (Just expectedLines)-    templateNoAction origLines range actionTitle =-      exportTemplate (Just range) origLines actionTitle Nothing- exportTemplate :: Maybe Range -> [T.Text] -> T.Text -> Maybe [T.Text] -> Session () exportTemplate mRange initialLines expectedAction expectedLines = do   doc <- createDoc "A.hs" "haskell" $ T.unlines initialLines@@ -3864,7 +3588,7 @@         , "a :: ()"         , "a = ()"         ]-        "Remove ‘module B’ from export"+        "Remove ‘Module B’ from export"         [ "module A () where"         , "a :: ()"         , "a = ()"
plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs view
@@ -21,7 +21,7 @@ import           Data.HashSet                          (HashSet) import qualified Data.HashSet                          as HS import           Data.List.NonEmpty                    (NonEmpty ((:|)),-                                                        groupWith)+                                                        groupAllWith) import qualified Data.Map                              as M import           Data.Maybe import           Data.Mod.Word@@ -226,7 +226,7 @@         Nothing -> pure []         Just mod -> liftIO $ mapMaybe rowToLoc <$> withHieDb (\hieDb ->             -- See Note [Generated references]-            filter (\(refRow HieDb.:. _) -> refIsGenerated refRow) <$>+            filter (\(refRow HieDb.:. _) -> not $ refIsGenerated refRow) <$>             findReferences                 hieDb                 True@@ -285,8 +285,8 @@     -- is generated from HieASTs containing GeneratedInfo     sourceOnlyRefMap = generateReferencesMap $ getAsts sourceOnlyAsts -collectWith :: (Hashable a, Eq b) => (a -> b) -> HashSet a -> [(b, HashSet a)]-collectWith f = map (\(a :| as) -> (f a, HS.fromList (a:as))) . groupWith f . HS.toList+collectWith :: (Hashable a, Ord b) => (a -> b) -> HashSet a -> [(b, HashSet a)]+collectWith f = map (\(a :| as) -> (f a, HS.fromList (a:as))) . groupAllWith f . HS.toList  -- | A variant 'getNamesAtPoint' that does not expect a 'PositionMapping' getNamesAtPoint' :: HieASTs a -> Position -> [Name]
plugins/hls-rename-plugin/test/Main.hs view
@@ -9,6 +9,8 @@ import           Data.Functor                (void) import qualified Data.Map                    as M import           Data.Text                   (Text, pack)+import qualified Data.Text.IO                as TIO+import           Development.IDE.Test        (referenceReady) import           Ide.Plugin.Config import qualified Ide.Plugin.Rename           as Rename import qualified Language.LSP.Protocol.Lens  as L@@ -27,6 +29,7 @@     [ prepareRenameTests     , renameTests     , moduleNameTests+    , crossModuleTests     ]  prepareRenameTests :: TestTree@@ -164,6 +167,24 @@         -- Make sure renaming succeeds         rename doc (Position 3 0) "foo'"     ]++crossModuleTests :: TestTree+crossModuleTests =+    testGroup+        "CrossModule"+        [ testCase "Term used in two modules" $ runRenameSession "" $ do+            defDoc <- openDoc "CrossModuleDefinition.hs" "haskell"+            useDoc <- openDoc "CrossModuleUsage.hs" "haskell"+            void $ skipManyTill anyMessage $ referenceReady (((==) "CrossModuleUsage.hs") . takeFileName)+            rename defDoc (Position 3 0) "succInt"+            assertGolden "CrossModuleDefinition" defDoc+            assertGolden "CrossModuleUsage" useDoc+        ]+  where+    assertGolden path doc = do+        actual <- documentContents doc+        expected <- liftIO $ TIO.readFile (testDataDir </> path <.> "expected" <.> "hs")+        liftIO $ assertEqual path expected actual  moduleNameTests :: TestTree moduleNameTests =
+ plugins/hls-rename-plugin/test/testdata/CrossModuleDefinition.expected.hs view
@@ -0,0 +1,4 @@+module CrossModuleDefinition (succInt) where++succInt :: Int -> Int+succInt x = x + 1
+ plugins/hls-rename-plugin/test/testdata/CrossModuleDefinition.hs view
@@ -0,0 +1,4 @@+module CrossModuleDefinition (increment) where++increment :: Int -> Int+increment x = x + 1
+ plugins/hls-rename-plugin/test/testdata/CrossModuleUsage.expected.hs view
@@ -0,0 +1,12 @@+module CrossModuleUse (incrementUsage) where++import CrossModuleDefinition (succInt)++incrementUsage :: Int -> Int+incrementUsage x = succInt x++incrementUsage2 :: Int -> Int+incrementUsage2 = succInt . succInt++incrementUsage3 :: Int -> Int+incrementUsage3 x = succInt (succInt (succInt x))
+ plugins/hls-rename-plugin/test/testdata/CrossModuleUsage.hs view
@@ -0,0 +1,12 @@+module CrossModuleUse (incrementUsage) where++import CrossModuleDefinition (increment)++incrementUsage :: Int -> Int+incrementUsage x = increment x++incrementUsage2 :: Int -> Int+incrementUsage2 = increment . increment++incrementUsage3 :: Int -> Int+incrementUsage3 x = increment (increment (increment x))
plugins/hls-rename-plugin/test/testdata/hie.yaml view
@@ -1,6 +1,8 @@ cradle:   direct:     arguments:+      - "CrossModuleDefinition"+      - "CrossModuleUsage"       - "DataConstructor"       - "ExportedFunction"       - "FieldPuns"
− plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs 
@@ -1,789 +0,0 @@-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DerivingStrategies    #-}-{-# LANGUAGE LambdaCase            #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE PatternSynonyms       #-}-{-# LANGUAGE RecordWildCards       #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE ViewPatterns          #-}--{-# OPTIONS -Wno-orphans #-}--module Ide.Plugin.Retrie (descriptor, Log) where--import           Control.Concurrent.STM               (readTVarIO)-import           Control.Exception.Safe               (Exception (..),-                                                       SomeException, assert,-                                                       catch, throwIO, try)-import           Control.Lens.Operators-import           Control.Monad                        (forM, unless, when)-import           Control.Monad.Error.Class            (MonadError (throwError))-import           Control.Monad.IO.Class               (MonadIO (liftIO))-import           Control.Monad.Trans.Class            (MonadTrans (lift))-import           Control.Monad.Trans.Except           (ExceptT (..), runExceptT)--import           Control.Monad.Trans.Maybe            (MaybeT)-import           Data.Aeson                           (FromJSON (..),-                                                       ToJSON (..))-import           Data.Bifunctor                       (second)-import qualified Data.ByteString                      as BS-import           Data.Data-import           Data.Either                          (partitionEithers)-import           Data.Hashable                        (unhashed)-import qualified Data.HashSet                         as Set-import           Data.IORef.Extra                     (atomicModifyIORef'_,-                                                       newIORef, readIORef)-import           Data.List.Extra                      (find, nubOrdOn)-import qualified Data.Map                             as Map-import           Data.Maybe                           (catMaybes)-import           Data.Monoid                          (First (First))-import           Data.String                          (IsString)-import qualified Data.Text                            as T-import qualified Data.Text.Encoding                   as T-import qualified Data.Text.Utf16.Rope.Mixed           as Rope-import           Development.IDE                      hiding (pluginHandlers)-import           Development.IDE.Core.Actions         (lookupMod)-import           Development.IDE.Core.PluginUtils-import           Development.IDE.Core.PositionMapping-import           Development.IDE.Core.Shake           (ShakeExtras (ShakeExtras, knownTargetsVar),-                                                       getShakeExtras,-                                                       hiedbWriter,-                                                       toKnownFiles, withHieDb)-import           Development.IDE.GHC.Compat           (GRHSs (GRHSs),-                                                       GenLocated (L), GhcPs,-                                                       GhcRn,-                                                       HsBindLR (FunBind),-                                                       HsExpr (HsApp, OpApp),-                                                       HsGroup (..),-                                                       HsValBindsLR (..),-                                                       HscEnv, ImportDecl (..),-                                                       LHsExpr, LRuleDecls,-                                                       Match, ModIface,-                                                       ModSummary (ModSummary, ms_hspp_buf, ms_mod),-                                                       Outputable, ParsedModule,-                                                       RuleDecl (HsRule),-                                                       RuleDecls (HsRules),-                                                       SourceText (..),-                                                       TyClDecl (SynDecl),-                                                       TyClGroup (..), fun_id,-                                                       isQual, isQual_maybe,-                                                       locA, mi_fixities,-                                                       moduleNameString,-                                                       ms_hspp_opts,-                                                       nameModule_maybe,-                                                       nameOccName, nameRdrName,-                                                       noLocA, occNameFS,-                                                       occNameString,-                                                       pattern IsBoot,-                                                       pattern NotBoot,-                                                       pattern RealSrcSpan,-                                                       pm_parsed_source,-                                                       rdrNameOcc, rds_rules,-                                                       srcSpanFile, topDir,-                                                       unLoc, unLocA)-import qualified Development.IDE.GHC.Compat           as GHC-import           Development.IDE.GHC.Compat.Util      hiding (catch, try)-import           Development.IDE.GHC.ExactPrint       (GetAnnotatedParsedSource (GetAnnotatedParsedSource),-                                                       TransformT)-import           Development.IDE.Spans.AtPoint        (LookupModule,-                                                       nameToLocation)-import           Development.IDE.Types.Shake          (WithHieDb)-import qualified GHC                                  as GHCGHC-import           GHC.Generics                         (Generic)-import           Ide.Plugin.Error                     (PluginError (PluginInternalError),-                                                       getNormalizedFilePathE)-import           Ide.PluginUtils-import           Ide.Types-import qualified Language.LSP.Protocol.Lens           as L-import           Language.LSP.Protocol.Message        as LSP-import           Language.LSP.Protocol.Types          as LSP-import           Language.LSP.Server                  (ProgressCancellable (Cancellable))-import           Retrie                               (Annotated (astA),-                                                       AnnotatedModule,-                                                       Fixity (Fixity),-                                                       FixityDirection (InfixL),-                                                       Options, Options_ (..),-                                                       Verbosity (Loud),-                                                       addImports, apply,-                                                       applyWithUpdate)-import           Retrie.Context-import           Retrie.CPP                           (CPP (NoCPP), parseCPP)-import           Retrie.ExactPrint                    (fix, makeDeltaAst,-                                                       transformA, unsafeMkA)-import           Retrie.Expr                          (mkLocatedHsVar)-import           Retrie.Fixity                        (FixityEnv, lookupOp,-                                                       mkFixityEnv)-import           Retrie.Monad                         (getGroundTerms,-                                                       runRetrie)-import           Retrie.Options                       (defaultOptions,-                                                       getTargetFiles)-import           Retrie.Replace                       (Change (..),-                                                       Replacement (..))-import           Retrie.Rewrites-import           Retrie.Rewrites.Function             (matchToRewrites)-import           Retrie.SYB                           (everything, extQ,-                                                       listify, mkQ)-import           Retrie.Types-import           Retrie.Universe                      (Universe)--import           GHC.Types.PkgQual--data Log-  = LogParsingModule FilePath--instance Pretty Log where-  pretty = \case-    LogParsingModule fp -> "Parsing module:" <+> pretty fp--descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState-descriptor recorder plId =-  (defaultPluginDescriptor plId "Provides code actions to inline Haskell definitions")-    { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction provider,-      pluginCommands = [retrieCommand recorder, retrieInlineThisCommand recorder]-    }--retrieCommandId :: CommandId-retrieCommandId = "retrieCommand"--retrieInlineThisCommandId :: CommandId-retrieInlineThisCommandId = "retrieInlineThisCommand"--retrieCommand :: Recorder (WithPriority Log) -> PluginCommand IdeState-retrieCommand recorder =-  PluginCommand retrieCommandId "run the refactoring" (runRetrieCmd recorder)--retrieInlineThisCommand :: Recorder (WithPriority Log) -> PluginCommand IdeState-retrieInlineThisCommand recorder =-  PluginCommand retrieInlineThisCommandId "inline function call"-    (runRetrieInlineThisCmd recorder)---- | Parameters for the runRetrie PluginCommand.-data RunRetrieParams = RunRetrieParams-  { description               :: T.Text,-    rewrites                  :: [RewriteSpec],-    originatingFile           :: Uri,-    restrictToOriginatingFile :: Bool-  }-  deriving (Eq, Show, Generic, FromJSON, ToJSON)--runRetrieCmd :: Recorder (WithPriority Log) ->  CommandFunction IdeState RunRetrieParams-runRetrieCmd recorder state token RunRetrieParams{originatingFile = uri, ..} = ExceptT $-  pluginWithIndefiniteProgress description token Cancellable $ \_updater -> do-    _ <- runExceptT $ do-        nfp <- getNormalizedFilePathE uri-        (session, _) <--            runActionE "Retrie.GhcSessionDeps" state $-                useWithStaleE GhcSessionDeps-                nfp-        (ms, binds, _, _, _) <- runActionE "Retrie.getBinds" state $ getBinds nfp-        let importRewrites = concatMap (extractImports ms binds) rewrites-        (errors, edits) <- liftIO $-            callRetrie-                recorder-                state-                (hscEnv session)-                (map Right rewrites <> map Left importRewrites)-                nfp-                restrictToOriginatingFile-        unless (null errors) $-            lift $ pluginSendNotification SMethod_WindowShowMessage $-                    ShowMessageParams MessageType_Warning $-                    T.unlines $-                        "## Found errors during rewrite:" :-                        ["-" <> T.pack (show e) | e <- errors]-        _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (\_ -> pure ())-        return ()-    return $ Right $ InR Null--data RunRetrieInlineThisParams = RunRetrieInlineThisParams-  { inlineIntoThisLocation :: !Location,-    inlineFromThisLocation :: !Location,-    inlineThisDefinition   :: !T.Text-  }-  deriving (Eq, Show, Generic, FromJSON, ToJSON)--runRetrieInlineThisCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState RunRetrieInlineThisParams-runRetrieInlineThisCmd recorder state _token RunRetrieInlineThisParams{..} = do-    nfp <- getNormalizedFilePathE $ getLocationUri inlineIntoThisLocation-    nfpSource <- getNormalizedFilePathE $ getLocationUri inlineFromThisLocation-    -- What we do here:-    --   Find the identifier in the given position-    --   Construct an inline rewrite for it-    --   Run retrie to get a list of changes-    --   Select the change that inlines the identifier in the given position-    --   Apply the edit-    astSrc <- runActionE "retrie" state $-        useE GetAnnotatedParsedSource nfpSource-    let fromRange = rangeToRealSrcSpan nfpSource $ getLocationRange inlineFromThisLocation-        intoRange = rangeToRealSrcSpan nfp $ getLocationRange inlineIntoThisLocation-    inlineRewrite <- liftIO $ constructInlineFromIdentifer (unsafeMkA astSrc 0) fromRange-    when (null inlineRewrite) $ throwError $ PluginInternalError "Empty rewrite"-    (session, _) <- runActionE "retrie" state $-      useWithStaleE GhcSessionDeps nfp-    (fixityEnv, cpp) <- liftIO $ getCPPmodule recorder state (hscEnv session) $ fromNormalizedFilePath nfp-    result <- liftIO $ try @_ @SomeException $-        runRetrie fixityEnv (applyWithUpdate myContextUpdater inlineRewrite) cpp-    case result of-        Left err -> throwError $ PluginInternalError $ "Retrie - crashed with: " <> T.pack (show err)-        Right (_,_,NoChange) -> throwError $ PluginInternalError "Retrie - inline produced no changes"-        Right (_,_,Change replacements imports) -> do-            let edits = asEditMap $ asTextEdits $ Change ourReplacement imports-                wedit = WorkspaceEdit (Just edits) Nothing Nothing-                ourReplacement = [ r-                    | r@Replacement{..} <- replacements-                    , RealSrcSpan intoRange Nothing `GHC.isSubspanOf` replLocation]-            _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit-                (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())-            return $ InR Null---- Override to skip adding binders to the context, which prevents inlining--- nested defined functions-myContextUpdater :: ContextUpdater-myContextUpdater c i =-    updateContext c i-    `extQ` (return . updExp)-    `extQ` (skipUpdate @(GRHSs GhcPs (LHsExpr GhcPs)))-    `extQ` (skipUpdate @(Match GhcPs (LHsExpr GhcPs)))-  where-    skipUpdate :: forall a m . Monad m => a -> TransformT m Context-    skipUpdate _ = pure c--    -- override to skip the HsLet case-    updExp :: HsExpr GhcPs -> Context-    updExp HsApp{} =-        c { ctxtParentPrec = HasPrec $ Retrie.Fixity (SourceText "HsApp") (10 + i - firstChild) InfixL }-    -- Reason for 10 + i: (i is index of child, 0 = left, 1 = right)-    -- In left child, prec is 10, so HsApp child will NOT get paren'd-    -- In right child, prec is 11, so every child gets paren'd (unless atomic)-    updExp (OpApp _ _ op _) = c { ctxtParentPrec = HasPrec $ lookupOp op (ctxtFixityEnv c) }-    updExp _ = c { ctxtParentPrec = NeverParen }-    -- Deal with Trees-That-Grow adding extension points-    -- as the first child everywhere.-    firstChild :: Int-    firstChild = 1--extractImports :: ModSummary -> [HsBindLR GhcRn GhcRn] -> RewriteSpec -> [ImportSpec]-extractImports ModSummary{ms_mod} topLevelBinds (Unfold thing)-  | Just FunBind {fun_matches}-  <- find (\case FunBind{fun_id = L _ n} -> T.unpack (printOutputable n) == thing ; _ -> False) topLevelBinds-  , names <- listify p fun_matches-  =-    [ AddImport {..}-    | let ideclSource = False,-        name <- names,-        let r = nameRdrName name,-        let ideclQualifiedBool = isQual r,-        let ideclAsString = moduleNameString . fst <$> isQual_maybe r,-        let ideclThing = Just (IEVar $ occNameString $ rdrNameOcc r),-        Just ideclNameString <--        [moduleNameString . GHC.moduleName <$> nameModule_maybe name]-    ]-    where-        p name = nameModule_maybe name /= Just ms_mod--- TODO handle imports for all rewrites-extractImports _ _ _ = []-----------------------------------------------------------------------------------provider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction-provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = do-  let (LSP.CodeActionContext _diags _monly _) = ca-  nfp <- getNormalizedFilePathE uri--  (ModSummary{ms_mod}, topLevelBinds, posMapping, hs_ruleds, hs_tyclds)-    <- runActionE "retrie" state $-        getBinds nfp--  extras@ShakeExtras{ withHieDb, hiedbWriter } <- liftIO $ runAction "" state getShakeExtras--  range <- fromCurrentRangeE posMapping range-  let pos = range ^. L.start-  let rewrites =-        concatMap (suggestBindRewrites uri pos ms_mod) topLevelBinds-          ++ concatMap (suggestRuleRewrites uri pos ms_mod) hs_ruleds-          ++ [ r-               | TyClGroup {group_tyclds} <- hs_tyclds,-                 L (locA -> l) g <- group_tyclds,-                 pos `isInsideSrcSpan` l,-                 r <- suggestTypeRewrites uri ms_mod g-             ]--  retrieCommands <- lift $-    forM rewrites $ \(title, kind, params) -> liftIO $ do-      let c = mkLspCommand plId retrieCommandId title (Just [toJSON params])-      return $ CodeAction title (Just kind) Nothing Nothing Nothing Nothing (Just c) Nothing--  inlineSuggestions <- liftIO $ runIdeAction "" extras $-    suggestBindInlines plId uri topLevelBinds range withHieDb (lookupMod hiedbWriter)-  let inlineCommands =-        [ Just $-            CodeAction _title (Just CodeActionKind_RefactorInline) Nothing Nothing Nothing Nothing (Just c) Nothing-        | c@Command{..} <- inlineSuggestions-        ]-  return $ InL [InR c | c <- retrieCommands ++ catMaybes inlineCommands]--getLocationUri :: Location -> Uri-getLocationUri Location{_uri} = _uri--getLocationRange :: Location -> Range-getLocationRange Location{_range} = _range--getBinds :: NormalizedFilePath -> ExceptT PluginError Action-  ( ModSummary-  , [HsBindLR GhcRn GhcRn]-  , PositionMapping-  , [LRuleDecls GhcRn]-  , [TyClGroup GhcRn]-  )-getBinds nfp = do-  (tm, posMapping) <- useWithStaleE TypeCheck nfp-  -- we use the typechecked source instead of the parsed source-  -- to be able to extract module names from the Ids,-  -- so that we can include adding the required imports in the retrie command-  let rn = tmrRenamed tm-  case rn of-#if MIN_VERSION_ghc(9,9,0)-    (HsGroup{hs_valds, hs_ruleds, hs_tyclds}, _, _, _, _) -> do-#else-    (HsGroup{hs_valds, hs_ruleds, hs_tyclds}, _, _, _) -> do-#endif-      topLevelBinds <- case hs_valds of-        ValBinds{} -> throwError $ PluginInternalError "getBinds: ValBinds not supported"-        XValBindsLR (GHC.NValBinds binds _sigs :: GHC.NHsValBindsLR GhcRn) ->-          pure [ decl-               | (_, bagBinds) <- binds-               , L _ decl <- bagToList bagBinds-               ]-      return (tmrModSummary tm, topLevelBinds, posMapping, hs_ruleds, hs_tyclds)--suggestBindRewrites ::-  Uri ->-  Position ->-  GHC.Module ->-  HsBindLR GhcRn GhcRn ->-  [(T.Text, CodeActionKind, RunRetrieParams)]-suggestBindRewrites originatingFile pos ms_mod FunBind {fun_id = L (locA -> l') rdrName}-  | pos `isInsideSrcSpan` l' =-    let pprNameText = printOutputable rdrName-        pprName = T.unpack pprNameText-        unfoldRewrite restrictToOriginatingFile =-            let rewrites = [Unfold (qualify ms_mod pprName)]-                description = "Unfold " <> pprNameText <> describeRestriction restrictToOriginatingFile-            in (description, CodeActionKind_RefactorInline, RunRetrieParams {..})-        foldRewrite restrictToOriginatingFile =-          let rewrites = [Fold (qualify ms_mod pprName)]-              description = "Fold " <> pprNameText <> describeRestriction restrictToOriginatingFile-           in (description, CodeActionKind_RefactorExtract, RunRetrieParams {..})-     in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True]-suggestBindRewrites _ _ _ _ = []--  -- find all the identifiers in the AST for which have source definitions-suggestBindInlines ::-    PluginId-    -> Uri-    -> [HsBindLR GhcRn GhcRn]-    -> Range-    -> WithHieDb-    -> (FilePath -> GHCGHC.ModuleName -> GHCGHC.Unit -> Bool -> MaybeT IdeAction Uri)-    -> IdeAction [Command]-suggestBindInlines plId _uri binds range hie lookupMod = do-    identifiers <- definedIdentifiers-    return $ map (\(name, siteLoc, srcLoc) ->-        let-            title = "Inline " <> printedName-            printedName = printOutputable name-            params = RunRetrieInlineThisParams-                { inlineIntoThisLocation = siteLoc-                , inlineFromThisLocation = srcLoc-                , inlineThisDefinition= printedName-                }-        in mkLspCommand plId retrieInlineThisCommandId title (Just [toJSON params])-        )-        (Set.toList identifiers)-    where-      definedIdentifiers =-        -- we search for candidates to inline in RHSs only, skipping LHSs-        everything (<>) (pure mempty `mkQ` getGRHSIdentifierDetails hie lookupMod) binds--      getGRHSIdentifierDetails ::-        WithHieDb-        -> (FilePath -> GHCGHC.ModuleName -> GHCGHC.Unit -> Bool -> MaybeT IdeAction Uri)-        -> GRHSs GhcRn (LHsExpr GhcRn)-        -> IdeAction (Set.HashSet (GHC.OccName, Location, Location))-      getGRHSIdentifierDetails a b it@GRHSs{} =-        -- we only select candidates for which we have source code-        everything (<>) (pure mempty `mkQ` getDefinedIdentifierDetailsViaHieDb a b) it--      getDefinedIdentifierDetailsViaHieDb :: WithHieDb -> LookupModule IdeAction -> GHC.LIdP GhcRn -> IdeAction (Set.HashSet (GHC.OccName, Location, Location))-      getDefinedIdentifierDetailsViaHieDb withHieDb lookupModule lname | name <- unLoc lname =-        case srcSpanToLocation (GHC.getLocA lname) of-            Just siteLoc-              | siteRange <- getLocationRange siteLoc-              , range `isSubrangeOf` siteRange -> do-                    mbSrcLocation <- nameToLocation withHieDb lookupModule name-                    return $ maybe mempty (Set.fromList . map (nameOccName name, siteLoc,)) mbSrcLocation-            _ -> pure mempty---describeRestriction :: IsString p => Bool -> p-describeRestriction restrictToOriginatingFile =-        if restrictToOriginatingFile then " in current file" else ""--suggestTypeRewrites ::-  Uri ->-  GHC.Module ->-  TyClDecl GhcRn ->-  [(T.Text, CodeActionKind, RunRetrieParams)]-suggestTypeRewrites originatingFile ms_mod SynDecl {tcdLName} =-    let pprNameText = printOutputable (unLocA tcdLName)-        pprName = T.unpack pprNameText-        unfoldRewrite restrictToOriginatingFile =-            let rewrites = [TypeForward (qualify ms_mod pprName)]-                description = "Unfold " <> pprNameText <> describeRestriction restrictToOriginatingFile-           in (description, CodeActionKind_RefactorInline, RunRetrieParams {..})-        foldRewrite restrictToOriginatingFile =-          let rewrites = [TypeBackward (qualify ms_mod pprName)]-              description = "Fold " <> pprNameText <> describeRestriction restrictToOriginatingFile-           in (description, CodeActionKind_RefactorExtract, RunRetrieParams {..})-     in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True]-suggestTypeRewrites _ _ _ = []--suggestRuleRewrites ::-  Uri ->-  Position ->-  GHC.Module ->-  LRuleDecls GhcRn ->-  [(T.Text, CodeActionKind, RunRetrieParams)]-suggestRuleRewrites originatingFile pos ms_mod (L _ HsRules {rds_rules}) =-    concat-        [ [ forwardRewrite   ruleName True-          , forwardRewrite   ruleName False-          , backwardsRewrite ruleName True-          , backwardsRewrite ruleName False-          ]-        | L (locA -> l) r  <- rds_rules,-          pos `isInsideSrcSpan` l,-          let HsRule {rd_name = L _ rn} = r,-          let ruleName = unpackFS rn-      ]-  where-    forwardRewrite ruleName restrictToOriginatingFile =-        let rewrites = [RuleForward (qualify ms_mod ruleName)]-            description = "Apply rule " <> T.pack ruleName <> " forward" <>-                            describeRestriction restrictToOriginatingFile--        in ( description,-            CodeActionKind_Refactor,-            RunRetrieParams {..}-            )-    backwardsRewrite ruleName restrictToOriginatingFile =-          let rewrites = [RuleBackward (qualify ms_mod ruleName)]-              description = "Apply rule " <> T.pack ruleName <> " backwards" <>-                              describeRestriction restrictToOriginatingFile-           in ( description,-                CodeActionKind_Refactor,-                RunRetrieParams {..}-              )--qualify :: Outputable mod => mod -> String -> String-qualify ms_mod x = T.unpack (printOutputable ms_mod) <> "." <> x------------------------------------------------------------------------------------ Retrie driving code--data CallRetrieError-  = CallRetrieInternalError String NormalizedFilePath-  | NoParse NormalizedFilePath-  | GHCParseError NormalizedFilePath String-  | NoTypeCheck NormalizedFilePath-  deriving (Eq)--instance Show CallRetrieError where-  show (CallRetrieInternalError msg f) = msg <> " - " <> fromNormalizedFilePath f-  show (NoParse f) = "Cannot parse: " <> fromNormalizedFilePath f-  show (GHCParseError f m) = "Cannot parse " <> fromNormalizedFilePath f <> " : " <> m-  show (NoTypeCheck f) = "File does not typecheck: " <> fromNormalizedFilePath f--instance Exception CallRetrieError--callRetrie ::-  Recorder (WithPriority Log) ->-  IdeState ->-  HscEnv ->-  [Either ImportSpec RewriteSpec] ->-  NormalizedFilePath ->-  Bool ->-  IO ([CallRetrieError], WorkspaceEdit)-callRetrie recorder state session rewrites origin restrictToOriginatingFile = do-  knownFiles <- toKnownFiles . unhashed <$> readTVarIO (knownTargetsVar $ shakeExtras state)-  let-      -- TODO cover all workspaceFolders-      target = "."--      retrieOptions :: Retrie.Options-      retrieOptions = (defaultOptions target)-        {Retrie.verbosity = Loud-        ,Retrie.targetFiles = map fromNormalizedFilePath $-            if restrictToOriginatingFile-                then [origin]-                else Set.toList knownFiles-        }--      (theImports, theRewrites) = partitionEithers rewrites--      annotatedImports =-        unsafeMkA (map (noLocA . toImportDecl) theImports) 0--  (originFixities, originParsedModule) <- reuseParsedModule state origin-  retrie <--    (\specs -> apply specs >> addImports annotatedImports)-      <$> parseSpecs state origin originParsedModule originFixities theRewrites--  targets <- getTargetFiles retrieOptions (getGroundTerms retrie)--  results <- forM targets $ \t -> runExceptT $ do-    (fixityEnv, cpp) <- ExceptT $ try $ getCPPmodule recorder state session t-    -- TODO add the imports to the resulting edits-    (_user, _ast, change@(Change _replacements _imports)) <--      lift $ runRetrie fixityEnv retrie cpp-    return $ asTextEdits change--  let (errors :: [CallRetrieError], replacements) = partitionEithers results-      editParams :: WorkspaceEdit-      editParams =-        WorkspaceEdit (Just $ asEditMap $ concat replacements) Nothing Nothing--  return (errors, editParams)--useOrFail ::-  IdeRule r v =>-  IdeState ->-  String ->-  (NormalizedFilePath -> CallRetrieError) ->-  r ->-  NormalizedFilePath ->-  IO (RuleResult r)-useOrFail state lbl mkException rule f =-  useRule lbl state rule f >>= maybe (liftIO $ throwIO $ mkException f) return--fixityEnvFromModIface :: ModIface -> FixityEnv-fixityEnvFromModIface modIface =-  mkFixityEnv-    [ (fs, (fs, fixity))-      | (n, fixity) <- mi_fixities modIface,-        let fs = occNameFS n-    ]--fixFixities :: Data ast =>-  IdeState-  -> NormalizedFilePath-  -> Annotated ast-  -> IO (FixityEnv, Annotated ast)-fixFixities state f pm = do-      HiFileResult {hirModIface} <--        useOrFail state "GetModIface" NoTypeCheck GetModIface f-      let fixities = fixityEnvFromModIface hirModIface-      res <- transformA pm (fix fixities)-      return (fixities, res)--fixAnns :: ParsedModule -> Annotated GHC.ParsedSource-fixAnns GHC.ParsedModule{pm_parsed_source} = unsafeMkA (makeDeltaAst pm_parsed_source) 0--parseSpecs-  :: IdeState-  -> NormalizedFilePath-  -> AnnotatedModule-  -> FixityEnv-  -> [RewriteSpec]-  -> IO [Rewrite Universe]-parseSpecs state origin originParsedModule originFixities specs = do-  -- retrie needs the libdir for `parseRewriteSpecs`-  libdir <- topDir . ms_hspp_opts . msrModSummary <$> useOrFail state "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary origin-  parseRewriteSpecs-    libdir-    (\_f -> return $ NoCPP originParsedModule)-    originFixities-    specs--constructfromFunMatches ::-  Annotated [GHCGHC.LocatedA (ImportDecl GhcPs)]-  -> GHCGHC.LocatedN GHCGHC.RdrName-  -> GHCGHC.MatchGroup GhcPs (GHCGHC.LocatedA (HsExpr GhcPs))-  -> TransformT IO [Rewrite Universe]-constructfromFunMatches imps fun_id fun_matches = do-    fe <- mkLocatedHsVar fun_id-    rewrites <- concat <$>-        forM (unLoc $ GHC.mg_alts fun_matches) (matchToRewrites fe imps LeftToRight)-    let urewrites = toURewrite <$> rewrites-    -- traceShowM $ map showQuery urewrites-    assert (not $ null urewrites) $-        return urewrites---- showQuery :: Rewrite Universe -> String--- showQuery = ppRewrite------ showQuery :: Rewrite (LHsExpr GhcPs) -> String--- showQuery q = unlines---     [ "template: " <> show (hash (printOutputable . showAstData NoBlankSrcSpan . astA . tTemplate . fst . qResult $ q))---     , "quantifiers: " <> show (hash (T.pack (show(Ext.toList $ qQuantifiers q))))---     , "matcher: " <> show (hash (printOutputable . showAstData NoBlankSrcSpan . astA . qPattern $ q))---     ]------ s :: Data a => a -> String--- s = T.unpack . printOutputable . showAstData NoBlankSrcSpan---         NoBlankEpAnnotations--constructInlineFromIdentifer :: Data a => Annotated (GenLocated l a) -> GHCGHC.RealSrcSpan -> IO [Rewrite Universe]-constructInlineFromIdentifer originParsedModule originSpan = do-    -- traceM $ s $ astA originParsedModule-    fmap astA $ transformA originParsedModule $ \(L _ m) -> do-        let ast = everything (<>) (First Nothing `mkQ` matcher) m-            matcher :: HsBindLR GhcPs GhcPs-                -> First ( GHCGHC.LocatedN GHCGHC.RdrName-                         , GHCGHC.MatchGroup GhcPs (GHCGHC.LocatedA (HsExpr GhcPs))-                         )-            matcher FunBind{fun_id, fun_matches}-                -- trace (show (GHC.getLocA fun_id) <> ": " <> s fun_id) False = undefined-                | RealSrcSpan sp _ <- GHC.getLocA fun_id-                , sp == originSpan =-                First $ Just (fun_id, fun_matches)-            matcher _ = First Nothing-        case ast of-            First (Just (fun_id, fun_matches))-                ->-                let imports = mempty in-                constructfromFunMatches imports fun_id fun_matches-            _ -> return $ error "could not find source code to inline"--asEditMap :: [(Uri, TextEdit)] -> Map.Map Uri [TextEdit]-asEditMap = Map.fromListWith (++) . map (second pure)--asTextEdits :: Change -> [(Uri, TextEdit)]-asTextEdits NoChange = []-asTextEdits (Change reps _imports) =-  [ (filePathToUri spanLoc, edit)-    | Replacement {..} <- nubOrdOn (realSpan . replLocation) reps,-      (RealSrcSpan rspan _) <- [replLocation],-      let spanLoc = unpackFS $ srcSpanFile rspan,-      let edit = TextEdit (realSrcSpanToRange rspan) (T.pack replReplacement)-  ]------------------------------------------------------------------------------------ Rule wrappers--_useRuleBlocking,-  _useRuleStale,-  useRule ::-    (IdeRule k v) =>-    String ->-    IdeState ->-    k ->-    NormalizedFilePath ->-    IO (Maybe (RuleResult k))-_useRuleBlocking label state rule f = runAction label state (use rule f)-_useRuleStale label state rule f =-  fmap fst-    <$> runIdeAction label (shakeExtras state) (useWithStaleFast rule f)---- | Chosen approach for calling ghcide Shake rules-useRule label = _useRuleStale ("Retrie." <> label)------------------------------------------------------------------------------------ Serialization wrappers and instances--deriving instance Eq RewriteSpec--deriving instance Show RewriteSpec--deriving instance Generic RewriteSpec--deriving instance FromJSON RewriteSpec--deriving instance ToJSON RewriteSpec--newtype IE name-  = IEVar name-  deriving stock (Eq, Show, Generic)-  deriving anyclass (FromJSON, ToJSON)---data ImportSpec = AddImport-  { ideclNameString    :: String,-    ideclSource        :: Bool,-    ideclQualifiedBool :: Bool,-    ideclAsString      :: Maybe String,-    ideclThing         :: Maybe (IE String)-  }-  deriving (Eq, Show, Generic, FromJSON, ToJSON)--toImportDecl :: ImportSpec -> GHC.ImportDecl GHC.GhcPs-toImportDecl AddImport {..} = GHC.ImportDecl {ideclSource = ideclSource', ..}-  where-    ideclSource' = if ideclSource then IsBoot else NotBoot-    toMod = noLocA . GHC.mkModuleName-    ideclName = toMod ideclNameString-    ideclSafe = False-    ideclImplicit = False-    ideclSourceSrc = NoSourceText-    ideclAs = toMod <$> ideclAsString-    ideclQualified = if ideclQualifiedBool then GHC.QualifiedPre else GHC.NotQualified--    ideclPkgQual = NoRawPkgQual--    ideclImportList = Nothing-    ideclExt = GHCGHC.XImportDeclPass-      { ideclAnn =-#if MIN_VERSION_ghc(9,9,0)-        GHCGHC.noAnn-#else-        GHCGHC.EpAnnNotUsed-#endif-      , ideclSourceText = ideclSourceSrc-      , ideclImplicit = ideclImplicit-      }--reuseParsedModule :: IdeState -> NormalizedFilePath -> IO (FixityEnv, Annotated GHCGHC.ParsedSource)-reuseParsedModule state f = do-        pm <- useOrFail state "Retrie.GetParsedModule" NoParse GetParsedModule f-        (fixities, pm') <- fixFixities state f (fixAnns pm)-        return (fixities, pm')--getCPPmodule :: Recorder (WithPriority Log) -> IdeState -> HscEnv -> FilePath -> IO (FixityEnv, CPP AnnotatedModule)-getCPPmodule recorder state session t = do-    -- TODO: is it safe to drop this makeAbsolute?-    let nt = toNormalizedFilePath' $ (toAbsolute $ rootDir state) t-    let getParsedModule f contents = do-          modSummary <- msrModSummary <$>-            useOrFail state "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary nt-          let ms' =-                modSummary-                  { ms_hspp_buf =-                      Just (stringToStringBuffer contents)-                  }-          logWith recorder Info $ LogParsingModule t-          parsed <- evalGhcEnv session (GHCGHC.parseModule ms')-              `catch` \e -> throwIO (GHCParseError nt (show @SomeException e))-          (fixities, parsed) <- fixFixities state f (fixAnns parsed)-          return (fixities, parsed)--    contents <- do-      mbContentsVFS <--        runAction "Retrie.GetFileContents" state $ getFileContents nt-      case mbContentsVFS of-        Just contents -> return $ Rope.toText contents-        Nothing       -> T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath nt)-    if any (T.isPrefixOf "#if" . T.toLower) (T.lines contents)-      then do-        fixitiesRef <- newIORef mempty-        let parseModule x = do-              (fix, res) <- getParsedModule nt x-              atomicModifyIORef'_ fixitiesRef (fix <>)-              return res-        res <- parseCPP parseModule contents-        fixities <- readIORef fixitiesRef-        return (fixities, res)-      else do-        (fixities, pm) <- reuseParsedModule state nt-        return (fixities, NoCPP pm)
− plugins/hls-retrie-plugin/test/Main.hs 
@@ -1,99 +0,0 @@-{-# LANGUAGE DisambiguateRecordFields #-}-{-# LANGUAGE LambdaCase               #-}-{-# LANGUAGE OverloadedStrings        #-}-{-# LANGUAGE PartialTypeSignatures    #-}--module Main (main) where--import           Control.Monad                     (void)-import qualified Data.Map                          as M-import           Data.Text                         (Text)-import qualified Development.IDE.GHC.ExactPrint    as ExactPrint-import qualified Development.IDE.Plugin.CodeAction as Refactor-import           Ide.Logger-import           Ide.Plugin.Config-import qualified Ide.Plugin.Retrie                 as Retrie-import           System.FilePath-import           Test.Hls--data LogWrap-    = RetrieLog Retrie.Log-    | ExactPrintLog ExactPrint.Log--instance Pretty LogWrap where-    pretty = \case-        RetrieLog msg -> pretty msg-        ExactPrintLog msg -> pretty msg--main :: IO ()-main = defaultTestRunner tests--retriePlugin :: PluginTestDescriptor LogWrap-retriePlugin =  mkPluginTestDescriptor (Retrie.descriptor . cmapWithPrio RetrieLog) "retrie"--refactorPlugin :: PluginTestDescriptor LogWrap-refactorPlugin = mkPluginTestDescriptor (Refactor.iePluginDescriptor  . cmapWithPrio ExactPrintLog) "refactor"--tests :: TestTree-tests = testGroup "Retrie"-    [ inlineThisTests-    ]--inlineThisTests :: TestTree-inlineThisTests = testGroup "Inline this"-    [-        testGroup "provider" [-            testProvider "lhs" "Identity" 4 1 ["Unfold function", "Unfold function in current file", "Fold function", "Fold function in current file"],-            testProvider "identifier" "Identity" 4 16 ["Inline identity"],-            testProvider "imported identifier" "Imported" 4 12 ["Inline identity"],-            testProvider "nested where" "NestedWhere" 4 16 ["Inline identity"],-            testProvider "nested let" "NestedLet" 6 12 ["Inline identity"],-            testProvider "class member" "Class" 5 16 [],-            testProvider "operator" "Operator" 4 16 ["Inline */"]-        ],-        testGroup "command" [-            testCommand "top level function" "Identity" 4 16,-            testCommand "top level function in another file" "Imported" 4 12,-            testCommand "nested where function" "NestedWhere" 4 16,-            testCommand "nested let function" "NestedLet" 6 12,-            testCommand "operator" "Operator" 4 16-        ]-    ]--testProvider :: TestName -> FilePath -> UInt -> UInt -> [Text] -> TestTree-testProvider title file line row expected = testCase title $ runWithRetrie $ do-    adoc <- openDoc (file <.> "hs") "haskell"-    _ <- waitForTypecheck adoc-    let position = Position line row-    codeActions <- getCodeActions adoc $ Range position position-    liftIO $ map codeActionTitle codeActions @?= map Just expected--testCommand :: TestName -> FilePath -> UInt -> UInt -> TestTree-testCommand title file row col = goldenWithRetrie title file $ \adoc -> do-    _ <- waitForTypecheck adoc-    let p = Position row col-    codeActions <- getCodeActions adoc $ Range p p-    case codeActions of-        [InR ca] -> do-            executeCodeAction ca-            void $ skipManyTill anyMessage $ getDocumentEdit adoc-        cas -> liftIO . assertFailure $ "One code action expected, got " <> show (length cas)--codeActionTitle :: (Command |? CodeAction) -> Maybe Text-codeActionTitle (InR CodeAction {_title}) = Just _title-codeActionTitle _                         = Nothing--goldenWithRetrie :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree-goldenWithRetrie title path act =-    goldenWithHaskellDoc (def { plugins = M.singleton "retrie" def }) testPlugins title testDataDir path "expected" "hs" act--runWithRetrie :: Session a -> IO a-runWithRetrie = runSessionWithServer def testPlugins testDataDir--testPlugins :: PluginTestDescriptor LogWrap-testPlugins =-    retriePlugin <>-    refactorPlugin  -- needed for the GetAnnotatedParsedSource rule--testDataDir :: FilePath-testDataDir = "plugins" </> "hls-retrie-plugin" </> "test" </> "testdata"
− plugins/hls-retrie-plugin/test/testdata/Class.hs 
@@ -1,7 +0,0 @@-module Class where--class Identity x where-    identity :: x -> x-    identity x = x--function x = identity x
− plugins/hls-retrie-plugin/test/testdata/Identity.expected.hs 
@@ -1,5 +0,0 @@-module Identity where--identity x = x--function x = x
− plugins/hls-retrie-plugin/test/testdata/Identity.hs 
@@ -1,5 +0,0 @@-module Identity where--identity x = x--function x = identity x
− plugins/hls-retrie-plugin/test/testdata/Imported.expected.hs 
@@ -1,5 +0,0 @@-module Imported where--import Identity--f x = x
− plugins/hls-retrie-plugin/test/testdata/Imported.hs 
@@ -1,5 +0,0 @@-module Imported where--import Identity--f x = identity x
− plugins/hls-retrie-plugin/test/testdata/Nested.expected.hs 
@@ -1,7 +0,0 @@-module Nested where----function x = x-  where-    identity x = x
− plugins/hls-retrie-plugin/test/testdata/NestedLet.expected.hs 
@@ -1,7 +0,0 @@-module NestedLet where----function x =-    let identity x = x-    in x
− plugins/hls-retrie-plugin/test/testdata/NestedLet.hs 
@@ -1,7 +0,0 @@-module NestedLet where----function x =-    let identity x = x-    in identity x
− plugins/hls-retrie-plugin/test/testdata/NestedNested.hs 
@@ -1,10 +0,0 @@--module NestedNested where----function x = meme x-  where-    meme x = identity x-    identity x = x-
− plugins/hls-retrie-plugin/test/testdata/NestedWhere.expected.hs 
@@ -1,7 +0,0 @@-module NestedWhere where----function x = x-  where-    identity x = x
− plugins/hls-retrie-plugin/test/testdata/NestedWhere.hs 
@@ -1,7 +0,0 @@-module NestedWhere where----function x = identity x-  where-    identity x = x
− plugins/hls-retrie-plugin/test/testdata/Operator.expected.hs 
@@ -1,5 +0,0 @@-module Operator where--x */ y = x--function x = x
− plugins/hls-retrie-plugin/test/testdata/Operator.hs 
@@ -1,5 +0,0 @@-module Operator where--x */ y = x--function x = x */ ()
− plugins/hls-retrie-plugin/test/testdata/hie.yaml 
@@ -1,11 +0,0 @@-cradle:-    direct:-      arguments:-        - Class.hs-        - Identity.hs-        - Imported.hs-        - Nested.hs-        - NestedLet.hs-        - NestedNested.hs-        - NestedWhere.hs-        - Operator.hs
plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs view
@@ -18,7 +18,6 @@       Ide.Types.pluginRules = Internal.getSemanticTokensRule recorder,       pluginConfigDescriptor =         defaultConfigDescriptor-          { configInitialGenericConfig = (configInitialGenericConfig defaultConfigDescriptor) {plcGlobalOn = False}-          , configCustomConfig = mkCustomConfig Internal.semanticConfigProperties+          { configCustomConfig = mkCustomConfig Internal.semanticConfigProperties           }     }
plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs view
@@ -34,7 +34,8 @@                                                            WithPriority,                                                            cmapWithPrio, define,                                                            fromNormalizedFilePath,-                                                           hieKind)+                                                           hieKind,+                                                           toNormalizedFilePath') import           Development.IDE.Core.PluginUtils         (runActionE, useE,                                                            useWithStaleE) import           Development.IDE.Core.Rules               (toIdeResult)@@ -43,7 +44,8 @@                                                            getShakeExtras,                                                            getVirtualFile) import           Development.IDE.GHC.Compat               hiding (Warning)-import           Development.IDE.GHC.Compat.Util          (mkFastString)+import           Development.IDE.GHC.Compat.Util          (mkFastString,+                                                           unpackFS) import           GHC.Iface.Ext.Types                      (HieASTs (getAsts),                                                            pattern HiePath) import           Ide.Logger                               (logWith)@@ -128,7 +130,12 @@   define (cmapWithPrio LogShake recorder) $ \GetSemanticTokens nfp -> handleError recorder $ do     (HAR {..}) <- withExceptT LogDependencyError $ useE GetHieAst nfp     (DKMap {getTyThingMap}, _) <- withExceptT LogDependencyError $ useWithStaleE GetDocMap nfp-    ast <- handleMaybe (LogNoAST $ show nfp) $ getAsts hieAst M.!? (HiePath . mkFastString . fromNormalizedFilePath) nfp+    -- On Windows, 'nfp' contains escaped backslashes \\\\. For files that use+    -- the CPP extension, 'hieAst' contains forward slashes '/', because the C+    -- preprocessor conflicts with backslashes. We need to "renormalize" it,+    -- so both paths have uniform separators+    let renormalize = \(HiePath p) -> HiePath . mkFastString . fromNormalizedFilePath . toNormalizedFilePath' . unpackFS $ p+    ast <- handleMaybe (LogNoAST $ show nfp) $ (M.mapKeys renormalize $ getAsts hieAst) M.!? (HiePath . mkFastString . fromNormalizedFilePath) nfp     virtualFile <- handleMaybeM LogNoVF $ getVirtualFile nfp     let hsFinder = idSemantic getTyThingMap (hieKindFunMasksKind hieKind) refMap     return $ computeRangeHsSemanticTokenTypeList hsFinder virtualFile ast
plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs view
@@ -38,19 +38,7 @@ mkFs = FS.mkVirtualFileTree testDataDir  semanticTokensPlugin :: Test.Hls.PluginTestDescriptor SemanticLog-semanticTokensPlugin = Test.Hls.mkPluginTestDescriptor enabledSemanticDescriptor "SemanticTokens"-  where-    enabledSemanticDescriptor recorder plId =-      let semanticDescriptor = Ide.Plugin.SemanticTokens.descriptor recorder plId-       in semanticDescriptor-            { pluginConfigDescriptor =-                (pluginConfigDescriptor semanticDescriptor)-                  { configInitialGenericConfig =-                      (configInitialGenericConfig (pluginConfigDescriptor semanticDescriptor))-                        { plcGlobalOn = True-                        }-                  }-            }+semanticTokensPlugin = Test.Hls.mkPluginTestDescriptor Ide.Plugin.SemanticTokens.descriptor "SemanticTokens"  -- if 9_10 and after we change the directory to the testdata/before_9_10 directory -- if 9_10 and after we change the directory to the testdata/after_9_10 directory
plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs view
@@ -60,7 +60,9 @@  import           GHC.Data.Bag                          (Bag) -#if MIN_VERSION_ghc(9,9,0)+#if MIN_VERSION_ghc(9,13,0)+import           GHC.Parser.Annotation                 (EpAnn (..), EpToken (..))+#elif MIN_VERSION_ghc(9,9,0) import           GHC.Parser.Annotation                 (EpAnn (..)) #else import           GHC.Parser.Annotation                 (SrcSpanAnn' (..))@@ -305,10 +307,18 @@ instance HasSplice AnnListItem HsExpr where     type SpliceOf HsExpr = HsSpliceCompat     matchSplice _ (HsUntypedSplice _ spl) = Just (UntypedSplice spl)+#if MIN_VERSION_ghc(9,13,0)+    matchSplice _ (HsTypedSplice _ (HsTypedSpliceExpr _ spl)) = Just (TypedSplice spl)+#else     matchSplice _ (HsTypedSplice _ spl)   = Just (TypedSplice spl)+#endif     matchSplice _ _                       = Nothing     expandSplice _ (UntypedSplice e) = fmap (first Right) $ rnUntypedSpliceExpr e+#if MIN_VERSION_ghc(9,13,0)+    expandSplice _ (TypedSplice e) = fmap (first Right) $ rnTypedSplice (HsTypedSpliceExpr NoEpTok e)+#else     expandSplice _ (TypedSplice e) = fmap (first Right) $ rnTypedSplice e+#endif  instance HasSplice AnnListItem Pat where     type SpliceOf Pat = HsUntypedSplice@@ -397,10 +407,18 @@         dflags = hsc_dflags hscEnv         showErrors = showBag +#if MIN_VERSION_ghc(9,13,0)+showBag :: (Error.Diagnostic a, Error.DiagnosticHint a ~ Error.GhcHint) => Bag (Error.MsgEnvelope a) -> String+#else showBag :: Error.Diagnostic a => Bag (Error.MsgEnvelope a) -> String+#endif showBag = show . fmap (fmap toDiagnosticMessage) +#if MIN_VERSION_ghc(9,13,0)+toDiagnosticMessage :: forall a. (Error.Diagnostic a, Error.DiagnosticHint a ~ Error.GhcHint) => a -> Error.DiagnosticMessage+#else toDiagnosticMessage :: forall a. Error.Diagnostic a => a -> Error.DiagnosticMessage+#endif toDiagnosticMessage message =     Error.DiagnosticMessage         { diagMessage = Error.diagnosticMessage
plugins/hls-splice-plugin/test/Main.hs view
@@ -54,6 +54,14 @@   , goldenTest "TQQTypeTypeError" Inplace 8 28   , goldenTest "TSimpleDecl" Inplace 8 1   , goldenTest "TQQDecl" Inplace 5 1+  , testGroup "Declaration Splices"+      [ goldenTest "TDeclForeignImport" Inplace 5 1+      , goldenTest "TDeclData" Inplace 5 1+      , goldenTest "TDeclNewtype" Inplace 5 1+      , goldenTest "TDeclInstance" Inplace 5 1+      , goldenTest "TDeclPatSyn" Inplace 6 1+      , goldenTest "TDeclPragma" Inplace 5 1+      ]   , goldenTestWithEdit "TTypeKindError" (         if ghcVersion >= GHC96 then           "96-expected"
+ plugins/hls-splice-plugin/test/testdata/TDeclData.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskell #-}+module TDeclData where+import Language.Haskell.TH++data MyData+  = MyConA Int | MyConB String+  deriving (Show, Eq)
+ plugins/hls-splice-plugin/test/testdata/TDeclData.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE TemplateHaskell #-}+module TDeclData where+import Language.Haskell.TH++$(pure <$> dataD (pure []) (mkName "MyData") [] Nothing+    [ normalC (mkName "MyConA") [bangType (bang noSourceUnpackedness noSourceStrictness) [t|Int|]]+    , normalC (mkName "MyConB") [bangType (bang noSourceUnpackedness noSourceStrictness) [t|String|]]+    ]+    [derivClause Nothing [conT ''Show, conT ''Eq]])
+ plugins/hls-splice-plugin/test/testdata/TDeclForeignImport.expected.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+module TDeclForeignImport where+import Language.Haskell.TH++foreign import ccall unsafe "math.h sin" c_sin :: Double -> Double
+ plugins/hls-splice-plugin/test/testdata/TDeclForeignImport.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+module TDeclForeignImport where+import Language.Haskell.TH++$(pure <$> forImpD cCall unsafe "math.h sin" (mkName "c_sin") [t|Double -> Double|])
+ plugins/hls-splice-plugin/test/testdata/TDeclInstance.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskell #-}+module TDeclInstance where+import Language.Haskell.TH++data Wrapper = MkWrapper Int+instance Show Wrapper where+  show (MkWrapper n) = ("Wrapper:" ++ show n)
+ plugins/hls-splice-plugin/test/testdata/TDeclInstance.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE TemplateHaskell #-}+module TDeclInstance where+import Language.Haskell.TH++$(do dataDec <- dataD (pure []) (mkName "Wrapper") [] Nothing+       [normalC (mkName "MkWrapper") [bangType (bang noSourceUnpackedness noSourceStrictness) [t|Int|]]]+       []+     instDec <- instanceD (pure []) (appT (conT ''Show) (conT (mkName "Wrapper")))+       [ funD (mkName "show") [clause [conP (mkName "MkWrapper") [varP (mkName "n")]]+           (normalB [|"Wrapper:" ++ show n|]) []]+       ]+     pure [dataDec, instDec])
+ plugins/hls-splice-plugin/test/testdata/TDeclNewtype.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskell #-}+module TDeclNewtype where+import Language.Haskell.TH++newtype MyNewtype+  = MkMyNewtype Int+  deriving Show
+ plugins/hls-splice-plugin/test/testdata/TDeclNewtype.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskell #-}+module TDeclNewtype where+import Language.Haskell.TH++$(pure <$> newtypeD (pure []) (mkName "MyNewtype") [] Nothing+    (normalC (mkName "MkMyNewtype") [bangType (bang noSourceUnpackedness noSourceStrictness) [t|Int|]])+    [derivClause Nothing [conT ''Show]])
+ plugins/hls-splice-plugin/test/testdata/TDeclPatSyn.expected.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PatternSynonyms #-}+module TDeclPatSyn where+import Language.Haskell.TH++pattern MyPattern <- 42
+ plugins/hls-splice-plugin/test/testdata/TDeclPatSyn.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PatternSynonyms #-}+module TDeclPatSyn where+import Language.Haskell.TH++$(pure <$> patSynD (mkName "MyPattern") (prefixPatSyn []) unidir (litP (integerL 42)))
+ plugins/hls-splice-plugin/test/testdata/TDeclPragma.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskell #-}+module TDeclPragma where+import Language.Haskell.TH++myId :: Int -> Int+{-# INLINE myId #-}+myId x = x
+ plugins/hls-splice-plugin/test/testdata/TDeclPragma.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE TemplateHaskell #-}+module TDeclPragma where+import Language.Haskell.TH++$(sequence+    [ sigD (mkName "myId") [t|Int -> Int|]+    , pragInlD (mkName "myId") Inline FunLike AllPhases+    , funD (mkName "myId") [clause [varP (mkName "x")] (normalB (varE (mkName "x"))) []]+    ])
src/HlsPlugins.hs view
@@ -35,16 +35,14 @@ import qualified Ide.Plugin.ExplicitImports        as ExplicitImports #endif -+#if hls_caseSplit+import qualified Ide.Plugin.CaseSplit              as CaseSplit+#endif  #if hls_rename import qualified Ide.Plugin.Rename                 as Rename #endif -#if hls_retrie-import qualified Ide.Plugin.Retrie                 as Retrie-#endif- #if hls_hlint import qualified Ide.Plugin.Hlint                  as Hlint #endif@@ -101,6 +99,10 @@ import qualified Ide.Plugin.Notes                  as Notes #endif +#if hls_export+import qualified Ide.Plugin.Export                 as Export+#endif+ -- formatters  #if hls_fourmolu@@ -181,9 +183,6 @@ #if hls_rename       let pId = "rename" in Rename.descriptor (pluginRecorder pId) pId: #endif-#if hls_retrie-      let pId = "retrie" in Retrie.descriptor (pluginRecorder pId) pId :-#endif #if hls_callHierarchy       CallHierarchy.descriptor "callHierarchy" : #endif@@ -199,6 +198,9 @@ #if hls_importLens       let pId = "importLens" in ExplicitImports.descriptor (pluginRecorder pId) pId: #endif+#if hls_caseSplit+      let pId = "caseSplit" in CaseSplit.descriptor (pluginRecorder pId) pId:+#endif #if hls_qualifyImportedNames       QualifyImportedNames.descriptor "qualifyImportedNames" : #endif@@ -247,5 +249,8 @@ #endif #if hls_notes       let pId = "notes" in Notes.descriptor (pluginRecorder pId) pId :+#endif+#if hls_export+      let pId = "export" in Export.descriptor pId : #endif       GhcIde.descriptors (pluginRecorder "ghcide")
+ test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.10.3/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs/build/hieBiosMainIs/autogen/PackageInfo_hieBiosMainIs.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE NoRebindableSyntax #-}+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}++{-|+Module      : PackageInfo_hieBiosMainIs+Description : Contents of some of the package's Cabal file's fields.++WARNING: This module was generated by Cabal. Any modifications will be+overwritten if the module is regenerated.++This module exports values that record information from some of the fields of+the package's Cabal package description file (Cabal file).++For further information about the fields in a Cabal file, see the Cabal User+Guide.+-}++module PackageInfo_hieBiosMainIs (+    name,+    version,+    synopsis,+    copyright,+    homepage,+  ) where++import Data.Version (Version(..))+import Prelude++-- |The content of the @name@ field of the package's Cabal file, but with any+-- hyphen characters replaced by underscore characters.+name :: String+name = "hieBiosMainIs"+-- |The content of the @version@ field of the package's Cabal file.+version :: Version+version = Version [0,1,0,0] []++-- |The content of the @synopsis@ field of the package's Cabal file.+synopsis :: String+synopsis = ""+-- |The content of the @copyright@ field of the package's Cabal file.+copyright :: String+copyright = ""+-- |The content of the @homepage@ field of the package's Cabal file.+homepage :: String+homepage = ""
+ test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.10.3/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs/build/hieBiosMainIs/autogen/Paths_hieBiosMainIs.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoRebindableSyntax #-}+#if __GLASGOW_HASKELL__ >= 810+{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}+#endif+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}++{-|+Module      : Paths_hieBiosMainIs+Description : Data file location, and package version and installation+              directories.++WARNING: This module was generated by Cabal. Any modifications will be+overwritten if the module is regenerated.++This module exports a function to locate data files, and values that record+the version of the package and some directories which the package has been+configured to be installed into.++For further information about Cabal's options for its configuration step, and+their default values, see the Cabal User Guide.+-}++module Paths_hieBiosMainIs (+    version,+    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,+    getDataFileName, getSysconfDir+  ) where+++import qualified Control.Exception as Exception+import Data.Version (Version(..))+import System.Environment (getEnv)+import Prelude+++#if defined(VERSION_base)++#if MIN_VERSION_base(4,0,0)+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#else+catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a+#endif++#else+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#endif+catchIO = Exception.catch++-- |The package version.+version :: Version+version = Version [0,1,0,0] []++-- |If the argument is a filename, the result is the name of a corresponding+-- file on the system on which the program is running, if the file were listed+-- in the @data-files@ field of the package's Cabal package description file.+-- No check is performed that the given filename is listed in that field.+getDataFileName :: FilePath -> IO FilePath+getDataFileName name = do+  dir <- getDataDir+  return (dir `joinFileName` name)++-- |The location of the directory specified by Cabal's @--bindir@ option (where+-- executables that the user might invoke are installed). This can be overridden+-- at runtime using the environment variable hieBiosMainIs_bindir.+getBinDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--libdir@ option (where+-- object libraries are installed). This can be overridden at runtime using the+-- environment variable hieBiosMainIs_libdir.+getLibDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--dynlibdir@ option+-- (where dynamic libraries are installed). This can be overridden at runtime+-- using the environment variable hieBiosMainIs_dynlibdir.+getDynLibDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--datadir@ option (where+-- architecture-independent data files are installed). This can be overridden at+-- runtime using the environment variable hieBiosMainIs_datadir.+getDataDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--libexedir@ option+-- (where executables that are not expected to be invoked directly by the user+-- are installed). This can be overridden at runtime using the environment+-- variable hieBiosMainIs_libexedir.+getLibexecDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--sysconfdir@ option+-- (where configuration files are installed). This can be overridden at runtime+-- using the environment variable hieBiosMainIs_sysconfdir.+getSysconfDir :: IO FilePath+++++bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath+bindir     = "/home/hugin/.cabal/bin"+libdir     = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.10.3-415c/hieBiosMainIs-0.1.0.0-inplace-hieBiosMainIs"+dynlibdir  = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.10.3-415c"+datadir    = "/home/hugin/.cabal/share/x86_64-linux-ghc-9.10.3-415c/hieBiosMainIs-0.1.0.0"+libexecdir = "/home/hugin/.cabal/libexec/x86_64-linux-ghc-9.10.3-415c/hieBiosMainIs-0.1.0.0"+sysconfdir = "/home/hugin/.cabal/etc"++getBinDir     = catchIO (getEnv "hieBiosMainIs_bindir")     (\_ -> return bindir)+getLibDir     = catchIO (getEnv "hieBiosMainIs_libdir")     (\_ -> return libdir)+getDynLibDir  = catchIO (getEnv "hieBiosMainIs_dynlibdir")  (\_ -> return dynlibdir)+getDataDir    = catchIO (getEnv "hieBiosMainIs_datadir")    (\_ -> return datadir)+getLibexecDir = catchIO (getEnv "hieBiosMainIs_libexecdir") (\_ -> return libexecdir)+getSysconfDir = catchIO (getEnv "hieBiosMainIs_sysconfdir") (\_ -> return sysconfdir)++++joinFileName :: String -> String -> FilePath+joinFileName ""  fname = fname+joinFileName "." fname = fname+joinFileName dir ""    = dir+joinFileName dir@(c:cs) fname+  | isPathSeparator (lastChar c cs) = dir ++ fname+  | otherwise                       = dir ++ pathSeparator : fname+ where+  -- We do not use Data.List.NonEmpty.last, as that would limit the module to+  -- base >= 4.9.0.0 (GHC >= 8.0.1).+  lastChar x [] = x+  lastChar _ (x:xs) = lastChar x xs++pathSeparator :: Char+pathSeparator = '/'++isPathSeparator :: Char -> Bool+isPathSeparator c = c == '/'
+ test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.12.2/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs/build/hieBiosMainIs/autogen/PackageInfo_hieBiosMainIs.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE NoRebindableSyntax #-}+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}++{-|+Module      : PackageInfo_hieBiosMainIs+Description : Contents of some of the package's Cabal file's fields.++WARNING: This module was generated by Cabal. Any modifications will be+overwritten if the module is regenerated.++This module exports values that record information from some of the fields of+the package's Cabal package description file (Cabal file).++For further information about the fields in a Cabal file, see the Cabal User+Guide.+-}++module PackageInfo_hieBiosMainIs (+    name,+    version,+    synopsis,+    copyright,+    homepage,+  ) where++import Data.Version (Version(..))+import Prelude++-- |The content of the @name@ field of the package's Cabal file, but with any+-- hyphen characters replaced by underscore characters.+name :: String+name = "hieBiosMainIs"+-- |The content of the @version@ field of the package's Cabal file.+version :: Version+version = Version [0,1,0,0] []++-- |The content of the @synopsis@ field of the package's Cabal file.+synopsis :: String+synopsis = ""+-- |The content of the @copyright@ field of the package's Cabal file.+copyright :: String+copyright = ""+-- |The content of the @homepage@ field of the package's Cabal file.+homepage :: String+homepage = ""
+ test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.12.2/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs/build/hieBiosMainIs/autogen/Paths_hieBiosMainIs.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoRebindableSyntax #-}+#if __GLASGOW_HASKELL__ >= 810+{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}+#endif+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}++{-|+Module      : Paths_hieBiosMainIs+Description : Data file location, and package version and installation+              directories.++WARNING: This module was generated by Cabal. Any modifications will be+overwritten if the module is regenerated.++This module exports a function to locate data files, and values that record+the version of the package and some directories which the package has been+configured to be installed into.++For further information about Cabal's options for its configuration step, and+their default values, see the Cabal User Guide.+-}++module Paths_hieBiosMainIs (+    version,+    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,+    getDataFileName, getSysconfDir+  ) where+++import qualified Control.Exception as Exception+import Data.Version (Version(..))+import System.Environment (getEnv)+import Prelude+++#if defined(VERSION_base)++#if MIN_VERSION_base(4,0,0)+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#else+catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a+#endif++#else+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#endif+catchIO = Exception.catch++-- |The package version.+version :: Version+version = Version [0,1,0,0] []++-- |If the argument is a filename, the result is the name of a corresponding+-- file on the system on which the program is running, if the file were listed+-- in the @data-files@ field of the package's Cabal package description file.+-- No check is performed that the given filename is listed in that field.+getDataFileName :: FilePath -> IO FilePath+getDataFileName name = do+  dir <- getDataDir+  return (dir `joinFileName` name)++-- |The location of the directory specified by Cabal's @--bindir@ option (where+-- executables that the user might invoke are installed). This can be overridden+-- at runtime using the environment variable hieBiosMainIs_bindir.+getBinDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--libdir@ option (where+-- object libraries are installed). This can be overridden at runtime using the+-- environment variable hieBiosMainIs_libdir.+getLibDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--dynlibdir@ option+-- (where dynamic libraries are installed). This can be overridden at runtime+-- using the environment variable hieBiosMainIs_dynlibdir.+getDynLibDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--datadir@ option (where+-- architecture-independent data files are installed). This can be overridden at+-- runtime using the environment variable hieBiosMainIs_datadir.+getDataDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--libexedir@ option+-- (where executables that are not expected to be invoked directly by the user+-- are installed). This can be overridden at runtime using the environment+-- variable hieBiosMainIs_libexedir.+getLibexecDir :: IO FilePath++-- |The location of the directory specified by Cabal's @--sysconfdir@ option+-- (where configuration files are installed). This can be overridden at runtime+-- using the environment variable hieBiosMainIs_sysconfdir.+getSysconfDir :: IO FilePath+++++bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath+bindir     = "/home/hugin/.cabal/bin"+libdir     = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.12.2-5327/hieBiosMainIs-0.1.0.0-inplace-hieBiosMainIs"+dynlibdir  = "/home/hugin/.cabal/lib/x86_64-linux-ghc-9.12.2-5327"+datadir    = "/home/hugin/.cabal/share/x86_64-linux-ghc-9.12.2-5327/hieBiosMainIs-0.1.0.0"+libexecdir = "/home/hugin/.cabal/libexec/x86_64-linux-ghc-9.12.2-5327/hieBiosMainIs-0.1.0.0"+sysconfdir = "/home/hugin/.cabal/etc"++getBinDir     = catchIO (getEnv "hieBiosMainIs_bindir")     (\_ -> return bindir)+getLibDir     = catchIO (getEnv "hieBiosMainIs_libdir")     (\_ -> return libdir)+getDynLibDir  = catchIO (getEnv "hieBiosMainIs_dynlibdir")  (\_ -> return dynlibdir)+getDataDir    = catchIO (getEnv "hieBiosMainIs_datadir")    (\_ -> return datadir)+getLibexecDir = catchIO (getEnv "hieBiosMainIs_libexecdir") (\_ -> return libexecdir)+getSysconfDir = catchIO (getEnv "hieBiosMainIs_sysconfdir") (\_ -> return sysconfdir)++++joinFileName :: String -> String -> FilePath+joinFileName ""  fname = fname+joinFileName "." fname = fname+joinFileName dir ""    = dir+joinFileName dir@(c:cs) fname+  | isPathSeparator (lastChar c cs) = dir ++ fname+  | otherwise                       = dir ++ pathSeparator : fname+ where+  -- We do not use Data.List.NonEmpty.last, as that would limit the module to+  -- base >= 4.9.0.0 (GHC >= 8.0.1).+  lastChar x [] = x+  lastChar _ (x:xs) = lastChar x xs++pathSeparator :: Char+pathSeparator = '/'++isPathSeparator :: Char -> Bool+isPathSeparator c = c == '/'
test/testdata/hieBiosMainIs/dist-newstyle/cache/plan.json view
@@ -1,1 +1,1 @@-{"cabal-version":"3.10.2.0","cabal-lib-version":"3.10.2.1","compiler-id":"ghc-9.8.1","os":"linux","arch":"x86_64","install-plan":[{"type":"pre-existing","id":"base-4.19.0.0-c1f2","pkg-name":"base","pkg-version":"4.19.0.0","depends":["ghc-bignum-1.3-d2d5","ghc-prim-0.11.0-b1d6","rts-1.0.2"]},{"type":"pre-existing","id":"ghc-bignum-1.3-d2d5","pkg-name":"ghc-bignum","pkg-version":"1.3","depends":["ghc-prim-0.11.0-b1d6"]},{"type":"pre-existing","id":"ghc-prim-0.11.0-b1d6","pkg-name":"ghc-prim","pkg-version":"0.11.0","depends":["rts-1.0.2"]},{"type":"configured","id":"hieBiosMainIs-0.1.0.0-inplace-hieBiosMainIs","pkg-name":"hieBiosMainIs","pkg-version":"0.1.0.0","flags":{},"style":"local","pkg-src":{"type":"local","path":"/home/zubin/haskell-language-server/test/testdata/hieBiosMainIs/."},"dist-dir":"/home/zubin/haskell-language-server/test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.8.1/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs","build-info":"/home/zubin/haskell-language-server/test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.8.1/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs/build-info.json","depends":["base-4.19.0.0-c1f2"],"exe-depends":[],"component-name":"exe:hieBiosMainIs","bin-file":"/home/zubin/haskell-language-server/test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.8.1/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs/build/hieBiosMainIs/hieBiosMainIs"},{"type":"pre-existing","id":"rts-1.0.2","pkg-name":"rts","pkg-version":"1.0.2","depends":[]}]}+{"cabal-version":"3.16.1.0","cabal-lib-version":"3.16.1.0","compiler-id":"ghc-9.10.3","compiler-abi":"415c","os":"linux","arch":"x86_64","install-plan":[{"type":"pre-existing","id":"base-4.20.2.0-127e","pkg-name":"base","pkg-version":"4.20.2.0","depends":["ghc-internal-9.1003.0-a65c","ghc-prim-0.12.0-d0f9"]},{"type":"pre-existing","id":"ghc-bignum-1.3-9ca9","pkg-name":"ghc-bignum","pkg-version":"1.3","depends":["ghc-prim-0.12.0-d0f9"]},{"type":"pre-existing","id":"ghc-internal-9.1003.0-a65c","pkg-name":"ghc-internal","pkg-version":"9.1003.0","depends":["ghc-bignum-1.3-9ca9","ghc-prim-0.12.0-d0f9","rts-1.0.2"]},{"type":"pre-existing","id":"ghc-prim-0.12.0-d0f9","pkg-name":"ghc-prim","pkg-version":"0.12.0","depends":["rts-1.0.2"]},{"type":"configured","id":"hieBiosMainIs-0.1.0.0-inplace-hieBiosMainIs","pkg-name":"hieBiosMainIs","pkg-version":"0.1.0.0","flags":{},"style":"local","pkg-src":{"type":"local","path":"/home/hugin/Documents/haskell/hls/test/testdata/hieBiosMainIs/."},"dist-dir":"/home/hugin/Documents/haskell/hls/test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.10.3/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs","build-info":"/home/hugin/Documents/haskell/hls/test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.10.3/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs/build-info.json","depends":["base-4.20.2.0-127e"],"exe-depends":[],"component-name":"exe:hieBiosMainIs","bin-file":"/home/hugin/Documents/haskell/hls/test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.10.3/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs/build/hieBiosMainIs/hieBiosMainIs"},{"type":"pre-existing","id":"rts-1.0.2","pkg-name":"rts","pkg-version":"1.0.2","depends":[]}]}
− test/testdata/missingModuleTest/missingModule/dist-newstyle/cache/plan.json 
@@ -1,1 +0,0 @@-{"cabal-version":"3.10.2.0","cabal-lib-version":"3.10.2.1","compiler-id":"ghc-9.8.1","os":"linux","arch":"x86_64","install-plan":[{"type":"pre-existing","id":"base-4.19.0.0-c1f2","pkg-name":"base","pkg-version":"4.19.0.0","depends":["ghc-bignum-1.3-d2d5","ghc-prim-0.11.0-b1d6","rts-1.0.2"]},{"type":"pre-existing","id":"ghc-bignum-1.3-d2d5","pkg-name":"ghc-bignum","pkg-version":"1.3","depends":["ghc-prim-0.11.0-b1d6"]},{"type":"pre-existing","id":"ghc-prim-0.11.0-b1d6","pkg-name":"ghc-prim","pkg-version":"0.11.0","depends":["rts-1.0.2"]},{"type":"configured","id":"missingModule-0.1.0.0-inplace","pkg-name":"missingModule","pkg-version":"0.1.0.0","flags":{},"style":"local","pkg-src":{"type":"local","path":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/missingModule/."},"dist-dir":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/missingModule/dist-newstyle/build/x86_64-linux/ghc-9.8.1/missingModule-0.1.0.0","build-info":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/missingModule/dist-newstyle/build/x86_64-linux/ghc-9.8.1/missingModule-0.1.0.0/build-info.json","depends":["base-4.19.0.0-c1f2"],"exe-depends":[],"component-name":"lib"},{"type":"pre-existing","id":"rts-1.0.2","pkg-name":"rts","pkg-version":"1.0.2","depends":[]}]}
− test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/cache/plan.json 
@@ -1,1 +0,0 @@-{"cabal-version":"3.10.2.0","cabal-lib-version":"3.10.2.1","compiler-id":"ghc-9.8.1","os":"linux","arch":"x86_64","install-plan":[{"type":"pre-existing","id":"base-4.19.0.0-c1f2","pkg-name":"base","pkg-version":"4.19.0.0","depends":["ghc-bignum-1.3-d2d5","ghc-prim-0.11.0-b1d6","rts-1.0.2"]},{"type":"pre-existing","id":"ghc-bignum-1.3-d2d5","pkg-name":"ghc-bignum","pkg-version":"1.3","depends":["ghc-prim-0.11.0-b1d6"]},{"type":"pre-existing","id":"ghc-prim-0.11.0-b1d6","pkg-name":"ghc-prim","pkg-version":"0.11.0","depends":["rts-1.0.2"]},{"type":"configured","id":"noPrefixMatch-0.1.0.0-inplace-testExe","pkg-name":"noPrefixMatch","pkg-version":"0.1.0.0","flags":{},"style":"local","pkg-src":{"type":"local","path":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/noPrefixMatch/."},"dist-dir":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/build/x86_64-linux/ghc-9.8.1/noPrefixMatch-0.1.0.0/x/testExe","build-info":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/build/x86_64-linux/ghc-9.8.1/noPrefixMatch-0.1.0.0/x/testExe/build-info.json","depends":["base-4.19.0.0-c1f2"],"exe-depends":[],"component-name":"exe:testExe","bin-file":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/build/x86_64-linux/ghc-9.8.1/noPrefixMatch-0.1.0.0/x/testExe/build/testExe/testExe"},{"type":"pre-existing","id":"rts-1.0.2","pkg-name":"rts","pkg-version":"1.0.2","depends":[]}]}
test/testdata/schema/ghc910/default-config.golden.json view
@@ -2,7 +2,10 @@     "cabalFormattingProvider": "cabal-gild",     "checkParents": "CheckOnSave",     "checkProject": true,+    "componentsLoading": "multi: needed-only",     "formattingProvider": "ormolu",+    "linkDocTo": "LinkToHackage",+    "linkSourceTo": "LinkToHackage",     "maxCompletions": 40,     "plugin": {         "alternateNumberFormat": {@@ -53,6 +56,9 @@         "explicit-fixity": {             "globalOn": true         },+        "export": {+            "globalOn": true+        },         "fourmolu": {             "config": {                 "external": false,@@ -143,14 +149,16 @@                 "typeVariableToken": "typeParameter",                 "variableToken": "variable"             },-            "globalOn": false+            "globalOn": true         },         "signatureHelp": {             "globalOn": true         },+        "splice": {+            "globalOn": true+        },         "stan": {             "globalOn": false         }-    },-    "sessionLoading": "singleComponent"+    } }
test/testdata/schema/ghc910/vscode-extension-schema.golden.json view
@@ -119,6 +119,12 @@         "scope": "resource",         "type": "boolean"     },+    "haskell.plugin.export.globalOn": {+        "default": true,+        "description": "Enables export plugin",+        "scope": "resource",+        "type": "boolean"+    },     "haskell.plugin.fourmolu.config.external": {         "default": false,         "markdownDescription": "Call out to an external \"fourmolu\" executable, rather than using the bundled library.",@@ -1026,7 +1032,7 @@         "type": "string"     },     "haskell.plugin.semanticTokens.globalOn": {-        "default": false,+        "default": true,         "description": "Enables semanticTokens plugin",         "scope": "resource",         "type": "boolean"@@ -1034,6 +1040,12 @@     "haskell.plugin.signatureHelp.globalOn": {         "default": true,         "description": "Enables signatureHelp plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.splice.globalOn": {+        "default": true,+        "description": "Enables splice plugin",         "scope": "resource",         "type": "boolean"     },
test/testdata/schema/ghc912/default-config.golden.json view
@@ -2,7 +2,10 @@     "cabalFormattingProvider": "cabal-gild",     "checkParents": "CheckOnSave",     "checkProject": true,+    "componentsLoading": "multi: needed-only",     "formattingProvider": "ormolu",+    "linkDocTo": "LinkToHackage",+    "linkSourceTo": "LinkToHackage",     "maxCompletions": 40,     "plugin": {         "alternateNumberFormat": {@@ -53,6 +56,9 @@         "explicit-fixity": {             "globalOn": true         },+        "export": {+            "globalOn": true+        },         "fourmolu": {             "config": {                 "external": false,@@ -150,11 +156,13 @@                 "typeVariableToken": "typeParameter",                 "variableToken": "variable"             },-            "globalOn": false+            "globalOn": true         },         "signatureHelp": {             "globalOn": true+        },+        "splice": {+            "globalOn": true         }-    },-    "sessionLoading": "singleComponent"+    } }
test/testdata/schema/ghc912/vscode-extension-schema.golden.json view
@@ -119,6 +119,12 @@         "scope": "resource",         "type": "boolean"     },+    "haskell.plugin.export.globalOn": {+        "default": true,+        "description": "Enables export plugin",+        "scope": "resource",+        "type": "boolean"+    },     "haskell.plugin.fourmolu.config.external": {         "default": false,         "markdownDescription": "Call out to an external \"fourmolu\" executable, rather than using the bundled library.",@@ -1044,7 +1050,7 @@         "type": "string"     },     "haskell.plugin.semanticTokens.globalOn": {-        "default": false,+        "default": true,         "description": "Enables semanticTokens plugin",         "scope": "resource",         "type": "boolean"@@ -1052,6 +1058,12 @@     "haskell.plugin.signatureHelp.globalOn": {         "default": true,         "description": "Enables signatureHelp plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.splice.globalOn": {+        "default": true,+        "description": "Enables splice plugin",         "scope": "resource",         "type": "boolean"     }
test/testdata/schema/ghc914/default-config.golden.json view
@@ -2,7 +2,10 @@     "cabalFormattingProvider": "cabal-gild",     "checkParents": "CheckOnSave",     "checkProject": true,+    "componentsLoading": "multi: needed-only",     "formattingProvider": "ormolu",+    "linkDocTo": "LinkToHackage",+    "linkSourceTo": "LinkToHackage",     "maxCompletions": 40,     "plugin": {         "alternateNumberFormat": {@@ -31,6 +34,9 @@         "callHierarchy": {             "globalOn": true         },+        "caseSplit": {+            "globalOn": true+        },         "changeTypeSignature": {             "globalOn": true         },@@ -53,6 +59,15 @@         "explicit-fixity": {             "globalOn": true         },+        "export": {+            "globalOn": true+        },+        "fourmolu": {+            "config": {+                "external": false,+                "path": "fourmolu"+            }+        },         "gadt": {             "globalOn": true         },@@ -94,6 +109,11 @@             "completionOn": true,             "hoverOn": true         },+        "ormolu": {+            "config": {+                "external": false+            }+        },         "overloaded-record-dot": {             "globalOn": true         },@@ -132,11 +152,13 @@                 "typeVariableToken": "typeParameter",                 "variableToken": "variable"             },-            "globalOn": false+            "globalOn": true         },         "signatureHelp": {             "globalOn": true+        },+        "splice": {+            "globalOn": true         }-    },-    "sessionLoading": "singleComponent"+    } }
test/testdata/schema/ghc914/vscode-extension-schema.golden.json view
@@ -59,6 +59,12 @@         "scope": "resource",         "type": "boolean"     },+    "haskell.plugin.caseSplit.globalOn": {+        "default": true,+        "description": "Enables caseSplit plugin",+        "scope": "resource",+        "type": "boolean"+    },     "haskell.plugin.changeTypeSignature.globalOn": {         "default": true,         "description": "Enables changeTypeSignature plugin",@@ -119,6 +125,24 @@         "scope": "resource",         "type": "boolean"     },+    "haskell.plugin.export.globalOn": {+        "default": true,+        "description": "Enables export plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.fourmolu.config.external": {+        "default": false,+        "markdownDescription": "Call out to an external \"fourmolu\" executable, rather than using the bundled library.",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.fourmolu.config.path": {+        "default": "fourmolu",+        "markdownDescription": "Set path to executable (for \"external\" mode).",+        "scope": "resource",+        "type": "string"+    },     "haskell.plugin.gadt.globalOn": {         "default": true,         "description": "Enables gadt plugin",@@ -231,6 +255,12 @@         "scope": "resource",         "type": "boolean"     },+    "haskell.plugin.ormolu.config.external": {+        "default": false,+        "markdownDescription": "Call out to an external \"ormolu\" executable, rather than using the bundled library",+        "scope": "resource",+        "type": "boolean"+    },     "haskell.plugin.overloaded-record-dot.globalOn": {         "default": true,         "description": "Enables overloaded-record-dot plugin",@@ -1008,7 +1038,7 @@         "type": "string"     },     "haskell.plugin.semanticTokens.globalOn": {-        "default": false,+        "default": true,         "description": "Enables semanticTokens plugin",         "scope": "resource",         "type": "boolean"@@ -1016,6 +1046,12 @@     "haskell.plugin.signatureHelp.globalOn": {         "default": true,         "description": "Enables signatureHelp plugin",+        "scope": "resource",+        "type": "boolean"+    },+    "haskell.plugin.splice.globalOn": {+        "default": true,+        "description": "Enables splice plugin",         "scope": "resource",         "type": "boolean"     }
test/testdata/schema/ghc96/default-config.golden.json view
@@ -2,7 +2,10 @@     "cabalFormattingProvider": "cabal-gild",     "checkParents": "CheckOnSave",     "checkProject": true,+    "componentsLoading": "multi: needed-only",     "formattingProvider": "ormolu",+    "linkDocTo": "LinkToHackage",+    "linkSourceTo": "LinkToHackage",     "maxCompletions": 40,     "plugin": {         "alternateNumberFormat": {@@ -53,6 +56,9 @@         "explicit-fixity": {             "globalOn": true         },+        "export": {+            "globalOn": true+        },         "fourmolu": {             "config": {                 "external": false,@@ -134,9 +140,6 @@             },             "renameOn": true         },-        "retrie": {-            "globalOn": true-        },         "semanticTokens": {             "config": {                 "classMethodToken": "method",@@ -153,7 +156,7 @@                 "typeVariableToken": "typeParameter",                 "variableToken": "variable"             },-            "globalOn": false+            "globalOn": true         },         "signatureHelp": {             "globalOn": true@@ -164,6 +167,5 @@         "stan": {             "globalOn": false         }-    },-    "sessionLoading": "singleComponent"+    } }
test/testdata/schema/ghc96/vscode-extension-schema.golden.json view
@@ -119,6 +119,12 @@         "scope": "resource",         "type": "boolean"     },+    "haskell.plugin.export.globalOn": {+        "default": true,+        "description": "Enables export plugin",+        "scope": "resource",+        "type": "boolean"+    },     "haskell.plugin.fourmolu.config.external": {         "default": false,         "markdownDescription": "Call out to an external \"fourmolu\" executable, rather than using the bundled library.",@@ -315,12 +321,6 @@         "scope": "resource",         "type": "boolean"     },-    "haskell.plugin.retrie.globalOn": {-        "default": true,-        "description": "Enables retrie plugin",-        "scope": "resource",-        "type": "boolean"-    },     "haskell.plugin.semanticTokens.config.classMethodToken": {         "default": "method",         "description": "LSP semantic token type to use for typeclass methods",@@ -1050,7 +1050,7 @@         "type": "string"     },     "haskell.plugin.semanticTokens.globalOn": {-        "default": false,+        "default": true,         "description": "Enables semanticTokens plugin",         "scope": "resource",         "type": "boolean"
test/testdata/schema/ghc98/default-config.golden.json view
@@ -2,7 +2,10 @@     "cabalFormattingProvider": "cabal-gild",     "checkParents": "CheckOnSave",     "checkProject": true,+    "componentsLoading": "multi: needed-only",     "formattingProvider": "ormolu",+    "linkDocTo": "LinkToHackage",+    "linkSourceTo": "LinkToHackage",     "maxCompletions": 40,     "plugin": {         "alternateNumberFormat": {@@ -53,6 +56,9 @@         "explicit-fixity": {             "globalOn": true         },+        "export": {+            "globalOn": true+        },         "fourmolu": {             "config": {                 "external": false,@@ -134,9 +140,6 @@             },             "renameOn": true         },-        "retrie": {-            "globalOn": true-        },         "semanticTokens": {             "config": {                 "classMethodToken": "method",@@ -153,7 +156,7 @@                 "typeVariableToken": "typeParameter",                 "variableToken": "variable"             },-            "globalOn": false+            "globalOn": true         },         "signatureHelp": {             "globalOn": true@@ -164,6 +167,5 @@         "stan": {             "globalOn": false         }-    },-    "sessionLoading": "singleComponent"+    } }
test/testdata/schema/ghc98/vscode-extension-schema.golden.json view
@@ -119,6 +119,12 @@         "scope": "resource",         "type": "boolean"     },+    "haskell.plugin.export.globalOn": {+        "default": true,+        "description": "Enables export plugin",+        "scope": "resource",+        "type": "boolean"+    },     "haskell.plugin.fourmolu.config.external": {         "default": false,         "markdownDescription": "Call out to an external \"fourmolu\" executable, rather than using the bundled library.",@@ -315,12 +321,6 @@         "scope": "resource",         "type": "boolean"     },-    "haskell.plugin.retrie.globalOn": {-        "default": true,-        "description": "Enables retrie plugin",-        "scope": "resource",-        "type": "boolean"-    },     "haskell.plugin.semanticTokens.config.classMethodToken": {         "default": "method",         "description": "LSP semantic token type to use for typeclass methods",@@ -1050,7 +1050,7 @@         "type": "string"     },     "haskell.plugin.semanticTokens.globalOn": {-        "default": false,+        "default": true,         "description": "Enables semanticTokens plugin",         "scope": "resource",         "type": "boolean"