ghcide 0.5.0 → 0.6.0

raw patch · 30 files changed

+1241/−912 lines, 30 filesdep +heapsizedep +opentelemetrydep +paralleldep −Chartdep −Chart-diagramsdep −diagramsdep ~extradep ~implicit-hie-cradlePVP ok

version bump matches the API change (PVP)

Dependencies added: heapsize, opentelemetry, parallel, shake-bench

Dependencies removed: Chart, Chart-diagrams, diagrams, diagrams-svg

Dependency ranges changed: extra, implicit-hie-cradle

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−1
• README.md +18/−25
• bench/hist/Main.hs +64/−445
• bench/lib/Experiments.hs +12/−8
• bench/lib/Experiments/Types.hs +3/−1
• exe/Arguments.hs +2/−0
• exe/Main.hs +42/−13
• ghcide.cabal +12/−11
• include/ghc-api-version.h +2/−0
• session-loader/Development/IDE/Session.hs +48/−15
• src/Development/IDE.hs +1/−2
• src/Development/IDE/Core/Compile.hs +2/−11
• src/Development/IDE/Core/FileStore.hs +9/−7
• src/Development/IDE/Core/OfInterest.hs +2/−2
• src/Development/IDE/Core/RuleTypes.hs +14/−3
• src/Development/IDE/Core/Rules.hs +11/−14
• src/Development/IDE/Core/Service.hs +1/−0
• src/Development/IDE/Core/Shake.hs +22/−54
• src/Development/IDE/Core/Tracing.hs +179/−0
• src/Development/IDE/GHC/Error.hs +8/−2
• src/Development/IDE/Import/DependencyInformation.hs +9/−10
• src/Development/IDE/LSP/LanguageServer.hs +14/−8
• src/Development/IDE/Plugin/CodeAction.hs +113/−32
• src/Development/IDE/Plugin/Completions.hs +15/−5
• src/Development/IDE/Plugin/Completions/Logic.hs +161/−25
• src/Development/IDE/Plugin/Completions/Types.hs +2/−1
• src/Development/IDE/Types/KnownTargets.hs +24/−0
• src/Development/IDE/Types/Options.hs +10/−4
• src/Development/IDE/Types/Shake.hs +41/−0
• test/exe/Main.hs +385/−213

@@ -1,4 +1,18 @@-### 0.5.0 (2020-10-08)+### 0.6.0 (2020-12-06)+* Completions: extend explicit import list automatically (#930) - (Guru Devanla)+* Completions for identifiers not in explicit import lists (#919) - (Guru Devanla)+* Completions for record fields (#900) - (Guru Devanla)+* Bugfix: add constructors to import lists correctly (#916) - (Potato Hatsue)+* Bugfix: respect qualified identifiers (#938) - (Pepe Iborra)+* Bugfix: partial `pathToId` (#926) - (Samuel Ainsworth)+* Bugfix: import suggestions when there's more than one option (#913) - (Guru Devanla)+* Bugfix: parenthesize operators when exporting (#906) - (Potato Hatsue)+* Opentelemetry traces and heapsize memory analysis (#922) - (Michalis Pardalos / Pepe Iborra)+* Make Filetargets absolute before continue using them (#914) - (fendor)+* Do not enable every "unnecessary" warning by default (#907) - (Alejandro Serrano)+* Update implicit-hie to 0.3.0 (#905) - (Avi Dessauer)++### 0.5.0 (2020-11-07) * Use implicit-hie-0.1.2.0 (#880) - (Javier Neira) * Clarify and downgrade implicit-hie message (#883) - (Avi Dessauer) * Switch back to bytecode (#873) - (wz1000)

@@ -1,7 +1,5 @@ # `ghcide` - A library for building Haskell IDE tooling -Note: `ghcide` was previously called `hie-core`.- Our vision is that you should build an IDE by combining:  ![vscode](https://raw.githubusercontent.com/haskell/ghcide/master/img/vscode2.png)@@ -10,7 +8,7 @@ * `ghcide` (i.e. this library) for defining how to type check, when to type check, and producing diagnostic messages; * A bunch of plugins that haven't yet been written, e.g. [`hie-hlint`](https://github.com/ndmitchell/hlint) and [`hie-ormolu`](https://github.com/tweag/ormolu), to choose which features you want; * [`haskell-lsp`](https://github.com/alanz/haskell-lsp) for sending those messages to a [Language Server Protocol (LSP)](https://microsoft.github.io/language-server-protocol/) server;-* An extension for your editor. We provide a [VS Code extension](https://code.visualstudio.com/api) as `extension` in this directory, although the components work in other LSP editors too (see below for instructions using Emacs).+* An LSP client for your editor.  There are more details about our approach [in this blog post](https://4ta.uk/p/shaking-up-the-ide). @@ -44,6 +42,13 @@  ## Using it +`ghcide` is not an end-user tool, [don't use `ghcide`](https://neilmitchell.blogspot.com/2020/09/dont-use-ghcide-anymore-directly.html) directly (more about the rationale [here](https://github.com/haskell/ghcide/pull/939)).++ [`haskell-language-server`](http://github.com/haskell/haskell-language-server) is an LSP server built on top of `ghcide` with additional features and a user friendly deployment model. To get it, simply install the [Haskell extension](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) in VS Code, or download prebuilt binaries from the [haskell-language-server](https://github.com/haskell/haskell-language-server) project page.+++The instructions below are meant for developers interested in setting up ghcide as an LSP server for testing purposes.+ ### Install `ghcide`  #### With Nix@@ -115,8 +120,7 @@  ### Using with VS Code -You can install the VSCode extension from the [VSCode-marketplace](https://marketplace.visualstudio.com/items?itemName=DigitalAssetHoldingsLLC.ghcide).+The [Haskell](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) extension has a setting for ghcide.  ### Using with Atom @@ -317,13 +321,17 @@  ## Hacking on ghcide -To build and work on `ghcide` itself, you can use Stack or cabal, e.g.,-running `stack test` will execute the test suite.+To build and work on `ghcide` itself, you should use cabal, e.g.,+running `cabal test` will execute the test suite. You can use `stack test` too, but+note that some tests will fail, and none of the maintainers are currently using `stack`.++If you are using Nix, there is a Cachix nix-shell cache for all the supported platforms: `cachix use haskell-ghcide`.+ If you are using Windows, you should disable the `auto.crlf` setting and configure your editor to use LF line endings, directly or making it use the existing `.editor-config`.  If you are chasing down test failures, you can use the tasty-rerun feature by running tests as -    stack --stack-yaml=stack84.yaml test --test-arguments "--rerun"+    cabal test --test-options"--rerun"  This writes a log file called `.tasty-rerun-log` of the failures, and only runs those. See the [tasty-rerun](https://hackage.haskell.org/package/tasty-rerun-1.1.17/docs/Test-Tasty-Ingredients-Rerun.html) documentation for other options.@@ -332,27 +340,12 @@ benchmark between HEAD and master using the benchHist script. This assumes that "master" points to the upstream master. -Run the benchmarks with `stack`:--    export STACK_YAML=...-    stack bench+Run the benchmarks with `cabal bench`. -It should take around 15 minutes and the results will be stored in the `bench-hist` folder. To interpret the results, see the comments in the `bench/hist/Main.hs` module.+It should take around 15 minutes and the results will be stored in the `bench-results` folder. To interpret the results, see the comments in the `bench/hist/Main.hs` module.  More details in [bench/README](bench/README.md) -### Building the extension--For development, you can also the VSCode extension from this repository (see-https://code.visualstudio.com/docs/setup/mac for details on adding-`code` to your `$PATH`):--1. `cd extension/`-2. `npm ci`-3. `npm run vscepackage`-4. `code --install-extension ghcide-0.0.1.vsix`--Now opening a `.hs` file should work with `ghcide`.  ## History and relationship to other Haskell IDE's 

@@ -38,491 +38,110 @@    > cabal bench --benchmark-options "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg"   -}-{-# LANGUAGE ApplicativeDo     #-} {-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DerivingStrategies#-} {-# LANGUAGE TypeFamilies      #-}+{-# OPTIONS -Wno-orphans #-} -import Control.Applicative (Alternative (empty))-import Control.Monad (when, forM, forM_, replicateM)-import Data.Char (toLower) import Data.Foldable (find)-import Data.Maybe (fromMaybe)-import Data.Text (Text)-import qualified Data.Text as T-import Data.Yaml ((.!=), (.:?), FromJSON (..), ToJSON (..), Value (..), decodeFileThrow)+import Data.Yaml (FromJSON (..), decodeFileThrow)+import Development.Benchmark.Rules import Development.Shake-import Development.Shake.Classes (Binary, Hashable, NFData)-import Experiments.Types (getExampleName, exampleToOptions, Example(..))-import GHC.Exts (IsList (..))+import Experiments.Types (Example, exampleToOptions)+import qualified Experiments.Types as E import GHC.Generics (Generic)-import qualified Graphics.Rendering.Chart.Backend.Diagrams as E-import Graphics.Rendering.Chart.Easy ((.=))-import qualified Graphics.Rendering.Chart.Easy as E import Numeric.Natural (Natural)-import System.Directory-import System.FilePath-import qualified Text.ParserCombinators.ReadP as P-import Text.Read (Read (..), get, readMaybe, readP_to_Prec)-import GHC.Stack (HasCallStack)-import Data.List (transpose) + config :: FilePath config = "bench/config.yaml"  -- | Read the config without dependency-readConfigIO :: FilePath -> IO Config+readConfigIO :: FilePath -> IO (Config BuildSystem) readConfigIO = decodeFileThrow -newtype GetExample = GetExample String deriving newtype (Binary, Eq, Hashable, NFData, Show)-newtype GetExamples = GetExamples () deriving newtype (Binary, Eq, Hashable, NFData, Show)-newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show)-newtype GetExperiments = GetExperiments () deriving newtype (Binary, Eq, Hashable, NFData, Show)-newtype GetVersions = GetVersions () deriving newtype (Binary, Eq, Hashable, NFData, Show)-newtype GetParent = GetParent Text deriving newtype (Binary, Eq, Hashable, NFData, Show)-newtype GetCommitId = GetCommitId String deriving newtype (Binary, Eq, Hashable, NFData, Show)-+instance IsExample Example where getExampleName = E.getExampleName type instance RuleResult GetExample = Maybe Example type instance RuleResult GetExamples = [Example]-type instance RuleResult GetSamples = Natural-type instance RuleResult GetExperiments = [Unescaped String]-type instance RuleResult GetVersions = [GitCommit]-type instance RuleResult GetParent = Text-type instance RuleResult GetCommitId = String  main :: IO () main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest} $ do-  want ["all"]--  readConfig <- newCache $ \fp -> need [fp] >> liftIO (readConfigIO fp)--  _ <- addOracle $ \GetSamples {} -> samples <$> readConfig config-  _ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config-  _ <- addOracle $ \GetVersions {} -> versions <$> readConfig config-  _ <- addOracle $ \GetExamples{} -> examples <$> readConfig config-  _ <- addOracle $ \(GetParent name) -> findPrev name . versions <$> readConfig config-  _ <- addOracle $ \(GetExample name) -> find (\e -> getExampleName e == name) . examples <$> readConfig config--  let readVersions = askOracle $ GetVersions ()-      readExperiments = askOracle $ GetExperiments ()-      readExamples = askOracle $ GetExamples ()-      readSamples = askOracle $ GetSamples ()-      getParent = askOracle . GetParent-      getExample = askOracle . GetExample--  configStatic <- liftIO $ readConfigIO config-  ghcideBenchPath <- ghcideBench <$> liftIO (readConfigIO config)-  let build = outputFolder configStatic-      buildSystem = buildTool configStatic--  phony "all" $ do-    Config {..} <- readConfig config--    need $-      [build </> getExampleName e </> "results.csv" | e <- examples ] ++-      [build </> "results.csv"]-        ++ [ build </> getExampleName ex </> escaped (escapeExperiment e) <.> "svg"-             | e <- experiments-             , ex <- examples-           ]-        ++ [ build </> getExampleName ex </> T.unpack (humanName ver) </> escaped (escapeExperiment e) <.> mode <.> "svg"-             | e <- experiments,-               ex <- examples,-               ver <- versions,-               mode <- ["", "diff"]-           ]--  build -/- "*/commitid" %> \out -> do-      alwaysRerun--      let [_,ver,_] = splitDirectories out-      mbEntry <- find ((== T.pack ver) . humanName) <$> readVersions-      let gitThing :: String-          gitThing = maybe ver (T.unpack . gitName) mbEntry-      Stdout commitid <- command [] "git" ["rev-list", "-n", "1", gitThing]-      writeFileChanged out $ init commitid--  priority 10 $ [ build -/- "HEAD/ghcide"-                , build -/- "HEAD/ghc.path"-                ]-    &%> \[out, ghcpath] -> do-      liftIO $ createDirectoryIfMissing True $ dropFileName out-      need =<< getDirectoryFiles "." ["src//*.hs", "exe//*.hs", "ghcide.cabal"]-      cmd_ $ buildGhcide buildSystem (takeDirectory out)-      ghcLoc <- findGhc "." buildSystem-      writeFile' ghcpath ghcLoc--  [ build -/- "*/ghcide",-    build -/- "*/ghc.path"-    ]-    &%> \[out, ghcpath] -> do-      let [b, ver, _] = splitDirectories out-      liftIO $ createDirectoryIfMissing True $ dropFileName out-      commitid <- readFile' $ b </> ver </> "commitid"-      cmd_ $ "git worktree add bench-temp " ++ commitid-      flip actionFinally (cmd_ (s "git worktree remove bench-temp --force")) $ do-        ghcLoc <- findGhc "bench-temp" buildSystem-        cmd_ [Cwd "bench-temp"] $ buildGhcide buildSystem (".." </> takeDirectory out)-        writeFile' ghcpath ghcLoc--  build -/- "*/*/results.csv" %> \out -> do-      experiments <- readExperiments--      let allResultFiles = [takeDirectory out </> escaped (escapeExperiment e) <.> "csv" | e <- experiments]-      allResults <- traverse readFileLines allResultFiles--      let header = head $ head allResults-          results = map tail allResults-      writeFileChanged out $ unlines $ header : concat results--  ghcideBenchResource <- newResource "ghcide-bench" 1--  priority 0 $-    [ build -/- "*/*/*.csv",-      build -/- "*/*/*.benchmark-gcStats",-      build -/- "*/*/*.log"-    ]-      &%> \[outcsv, _outGc, outLog] -> do-        let [_, exampleName, ver, exp] = splitDirectories outcsv-        example <- fromMaybe (error $ "Unknown example " <> exampleName) <$> getExample exampleName-        samples <- readSamples-        liftIO $ createDirectoryIfMissing True $ dropFileName outcsv-        let ghcide = build </> ver </> "ghcide"-            ghcpath = build </> ver </> "ghc.path"-        need [ghcide, ghcpath]-        ghcPath <- readFile' ghcpath-        withResource ghcideBenchResource 1 $ do-          command_-              [ EchoStdout False,-                FileStdout outLog,-                RemEnv "NIX_GHC_LIBDIR",-                RemEnv "GHC_PACKAGE_PATH",-                AddPath [takeDirectory ghcPath, "."] []-              ]-              ghcideBenchPath $-              [ "--timeout=3000",-                "-v",-                "--samples=" <> show samples,-                "--csv=" <> outcsv,-                "--ghcide-options= +RTS -I0.5 -RTS",-                "--ghcide=" <> ghcide,-                "--select",-                unescaped (unescapeExperiment (Escaped $ dropExtension exp))-              ] ++-              exampleToOptions example ++-              [ "--stack" | Stack == buildSystem]-          cmd_ Shell $ "mv *.benchmark-gcStats " <> dropFileName outcsv--  build -/- "results.csv" %> \out -> do-    examples <- map getExampleName <$> readExamples-    let allResultFiles = [build </> e </> "results.csv" | e <- examples]--    allResults <- traverse readFileLines allResultFiles--    let header = head $ head allResults-        results = map tail allResults-        header' = "example, " <> header-        results' = zipWith (\e -> map (\l -> e <> ", " <> l)) examples results--    writeFileChanged out $ unlines $ header' : concat results'--  build -/- "*/results.csv" %> \out -> do-    versions <- map (T.unpack . humanName) <$> readVersions-    let example = takeFileName $ takeDirectory out-        allResultFiles =-          [build </> example </> v </> "results.csv" | v <- versions]--    allResults <- traverse readFileLines allResultFiles--    let header = head $ head allResults-        results = map tail allResults-        header' = "version, " <> header-        results' = zipWith (\v -> map (\l -> v <> ", " <> l)) versions results--    writeFileChanged out $ unlines $ header' : interleave results'--  priority 2 $-    build -/- "*/*/*.diff.svg" %> \out -> do-      let [b, example, ver, exp_] = splitDirectories out-          exp = Escaped $ dropExtension $ dropExtension exp_-      prev <- getParent $ T.pack ver--      runLog <- loadRunLog b example exp ver-      runLogPrev <- loadRunLog b example exp $ T.unpack prev--      let diagram = Diagram Live [runLog, runLogPrev] title-          title = show (unescapeExperiment exp) <> " - live bytes over time compared"-      plotDiagram True diagram out--  priority 1 $-    build -/- "*/*/*.svg" %> \out -> do-      let [b, example, ver, exp] = splitDirectories out-      runLog <- loadRunLog b example (Escaped $ dropExtension exp) ver-      let diagram = Diagram Live [runLog] title-          title = ver <> " live bytes over time"-      plotDiagram True diagram out--  build -/- "*/*.svg" %> \out -> do-    let exp = Escaped $ dropExtension $ takeFileName out-        example = takeFileName $ takeDirectory out-    versions <- readVersions--    runLogs <- forM (filter include versions) $ \v -> do-      loadRunLog build example exp $ T.unpack $ humanName v--    let diagram = Diagram Live runLogs title-        title = show (unescapeExperiment exp) <> " - live bytes over time"-    plotDiagram False diagram out------------------------------------------------------------------------------------buildGhcide :: BuildSystem -> String -> String-buildGhcide Cabal out = unwords-    ["cabal install"-    ,"exe:ghcide"-    ,"--installdir=" ++ out-    ,"--install-method=copy"-    ,"--overwrite-policy=always"-    ,"--ghc-options -rtsopts"-    ]-buildGhcide Stack out =-    "stack --local-bin-path=" <> out-        <> " build ghcide:ghcide --copy-bins --ghc-options -rtsopts"-+  createBuildSystem $ \resource -> do+      configStatic <- liftIO $ readConfigIO config+      let build = outputFolder configStatic+      buildRules build ghcideBuildRules+      benchRules build resource (MkBenchRules (benchGhcide $ samples configStatic) "ghcide")+      csvRules build+      svgRules build+      action $ allTargets build -findGhc :: FilePath -> BuildSystem -> Action FilePath-findGhc _cwd Cabal =-    liftIO $ fromMaybe (error "ghc is not in the PATH") <$> findExecutable "ghc"-findGhc cwd Stack = do-    Stdout ghcLoc <- cmd [Cwd cwd] (s "stack exec which ghc")-    return ghcLoc+ghcideBuildRules :: MkBuildRules BuildSystem+ghcideBuildRules = MkBuildRules findGhcForBuildSystem "ghcide" buildGhcide  -------------------------------------------------------------------------------- -data Config = Config+data Config buildSystem = Config   { experiments :: [Unescaped String],     examples :: [Example],     samples :: Natural,     versions :: [GitCommit],-    -- | Path to the ghcide-bench binary for the experiments-    ghcideBench :: FilePath,     -- | Output folder ('foo' works, 'foo/bar' does not)     outputFolder :: String,-    buildTool :: BuildSystem+    buildTool :: buildSystem   }   deriving (Generic, Show)   deriving anyclass (FromJSON) -data GitCommit = GitCommit-  { -- | A git hash, tag or branch name (e.g. v0.1.0)-    gitName :: Text,-    -- | A human understandable name (e.g. fix-collisions-leak)-    name :: Maybe Text,-    -- | The human understandable name of the parent, if specified explicitly-    parent :: Maybe Text,-    -- | Whether to include this version in the top chart-    include :: Bool-  }-  deriving (Binary, Eq, Hashable, Generic, NFData, Show)--instance FromJSON GitCommit where-  parseJSON (String s) = pure $ GitCommit s Nothing Nothing True-  parseJSON (Object (toList -> [(name, String gitName)])) =-    pure $ GitCommit gitName (Just name) Nothing True-  parseJSON (Object (toList -> [(name, Object props)])) =-    GitCommit-      <$> props .:? "git"  .!= name-      <*> pure (Just name)-      <*> props .:? "parent"-      <*> props .:? "include" .!= True-  parseJSON _ = empty--instance ToJSON GitCommit where-  toJSON GitCommit {..} =-    case name of-      Nothing -> String gitName-      Just n -> Object $ fromList [(n, String gitName)]--humanName :: GitCommit -> Text-humanName GitCommit {..} = fromMaybe gitName name--findPrev :: Text -> [GitCommit] -> Text-findPrev name (x : y : xx)-  | humanName y == name = humanName x-  | otherwise = findPrev name (y : xx)-findPrev name _ = name--data BuildSystem = Cabal | Stack-  deriving (Eq, Read, Show)--instance FromJSON BuildSystem where-    parseJSON x = fromString . map toLower <$> parseJSON x-      where-        fromString "stack" = Stack-        fromString "cabal" = Cabal-        fromString other = error $ "Unknown build system: " <> other--instance ToJSON BuildSystem where-    toJSON = toJSON . show--------------------------------------------------------------------------------------------------------- | A line in the output of -S-data Frame = Frame-  { allocated, copied, live :: !Int,-    user, elapsed, totUser, totElapsed :: !Double,-    generation :: !Int-  }-  deriving (Show)--instance Read Frame where-  readPrec = do-    spaces-    allocated <- readPrec @Int <* spaces-    copied <- readPrec @Int <* spaces-    live <- readPrec @Int <* spaces-    user <- readPrec @Double <* spaces-    elapsed <- readPrec @Double <* spaces-    totUser <- readPrec @Double <* spaces-    totElapsed <- readPrec @Double <* spaces-    _ <- readPrec @Int <* spaces-    _ <- readPrec @Int <* spaces-    "(Gen:  " <- replicateM 7 get-    generation <- readPrec @Int-    ')' <- get-    return Frame {..}-    where-      spaces = readP_to_Prec $ const P.skipSpaces--data TraceMetric = Allocated | Copied | Live | User | Elapsed-  deriving (Generic, Enum, Bounded, Read)+createBuildSystem :: (Resource -> Rules a) -> Rules a+createBuildSystem userRules = do+  readConfig <- newCache $ \fp -> need [fp] >> liftIO (readConfigIO fp) -instance Show TraceMetric where-  show Allocated = "Allocated bytes"-  show Copied = "Copied bytes"-  show Live = "Live bytes"-  show User = "User time"-  show Elapsed = "Elapsed time"+  _ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config+  _ <- addOracle $ \GetVersions {} -> versions <$> readConfig config+  _ <- addOracle $ \GetExamples{} -> examples <$> readConfig config+  _ <- addOracle $ \(GetExample name) -> find (\e -> getExampleName e == name) . examples <$> readConfig config+  _ <- addOracle $ \GetBuildSystem {} -> buildTool <$> readConfig config -frameMetric :: TraceMetric -> Frame -> Double-frameMetric Allocated = fromIntegral . allocated-frameMetric Copied = fromIntegral . copied-frameMetric Live = fromIntegral . live-frameMetric Elapsed = elapsed-frameMetric User = user+  benchResource <- newResource "ghcide-bench" 1 -data Diagram = Diagram-  { traceMetric :: TraceMetric,-    runLogs :: [RunLog],-    title :: String-  }-  deriving (Generic)+  userRules benchResource --- | A file path containing the output of -S for a given run-data RunLog = RunLog-  { runVersion :: !String,-    _runExample :: !String,-    _runExperiment :: !String,-    runFrames :: ![Frame],-    runSuccess :: !Bool-  }+-------------------------------------------------------------------------------- -loadRunLog :: HasCallStack => FilePath -> String -> Escaped FilePath -> FilePath -> Action RunLog-loadRunLog buildF example exp ver = do-  let log_fp = buildF </> example </> ver </> escaped exp <.> "benchmark-gcStats"-      csv_fp = replaceExtension log_fp "csv"-  log <- readFileLines log_fp-  csv <- readFileLines csv_fp-  let frames =-        [ f-          | l <- log,-            Just f <- [readMaybe l],-            -- filter out gen 0 events as there are too many-            generation f == 1+buildGhcide :: BuildSystem -> [CmdOption] -> FilePath -> Action ()+buildGhcide Cabal args out = do+    command_ args "cabal"+        ["install"+        ,"exe:ghcide"+        ,"--installdir=" ++ out+        ,"--install-method=copy"+        ,"--overwrite-policy=always"+        ,"--ghc-options=-rtsopts"         ]-      success = case map (T.split (== ',') . T.pack) csv of-          [_header, _name:s:_] | Just s <- readMaybe (T.unpack s) -> s-          _ -> error $ "Cannot parse: " <> csv_fp-  return $ RunLog ver example (dropExtension $ escaped exp) frames success -plotDiagram :: Bool -> Diagram -> FilePath -> Action ()-plotDiagram includeFailed t@Diagram {traceMetric, runLogs} out = do-  let extract = frameMetric traceMetric-  liftIO $ E.toFile E.def out $ do-    E.layout_title .= title t-    E.setColors myColors-    forM_ runLogs $ \rl ->-      when (includeFailed || runSuccess rl) $ E.plot $ do-        lplot <- E.line-            (runVersion rl ++ if runSuccess rl then "" else " (FAILED)")-            [ [ (totElapsed f, extract f)-                | f <- runFrames rl-                ]-            ]-        return (lplot E.& E.plot_lines_style . E.line_width E.*~ 2)--s :: String -> String-s = id--(-/-) :: FilePattern -> FilePattern -> FilePattern-a -/- b = a <> "/" <> b--newtype Escaped a = Escaped {escaped :: a}--newtype Unescaped a = Unescaped {unescaped :: a}-  deriving newtype (Show, FromJSON, ToJSON, Eq, NFData, Binary, Hashable)--escapeExperiment :: Unescaped String -> Escaped String-escapeExperiment = Escaped . map f . unescaped-  where-    f ' ' = '_'-    f other = other--unescapeExperiment :: Escaped String -> Unescaped String-unescapeExperiment = Unescaped . map f . escaped-  where-    f '_' = ' '-    f other = other+buildGhcide Stack args out =+    command_ args "stack"+        ["--local-bin-path=" <> out+        ,"build"+        ,"ghcide:ghcide"+        ,"--copy-bins"+        ,"--ghc-options=-rtsopts"+        ] -interleave :: [[a]] -> [a]-interleave = concat . transpose+benchGhcide+  :: Natural -> BuildSystem -> [CmdOption] -> BenchProject Example -> Action ()+benchGhcide samples buildSystem args BenchProject{..} =+  command_ args "ghcide-bench" $+    [ "--timeout=3000",+        "-v",+        "--samples=" <> show samples,+        "--csv="     <> outcsv,+        "--ghcide="  <> exePath,+        "--select",+        unescaped (unescapeExperiment experiment)+    ] +++    exampleToOptions example +++    [ "--stack" | Stack == buildSystem+    ] +++    exeExtraArgs -myColors :: [E.AlphaColour Double]-myColors = map E.opaque-  [ E.blue-  , E.green-  , E.red-  , E.orange-  , E.yellow-  , E.violet-  , E.black-  , E.gold-  , E.brown-  , E.hotpink-  , E.aliceblue-  , E.aqua-  , E.beige-  , E.bisque-  , E.blueviolet-  , E.burlywood-  , E.cadetblue-  , E.chartreuse-  , E.coral-  , E.crimson-  , E.darkblue-  , E.darkgray-  , E.darkgreen-  , E.darkkhaki-  , E.darkmagenta-  , E.deeppink-  , E.dodgerblue-  , E.firebrick-  , E.forestgreen-  , E.fuchsia-  , E.greenyellow-  , E.lightsalmon-  , E.seagreen-  , E.olive-  , E.sandybrown-  , E.sienna-  , E.peru-  ]

@@ -1,4 +1,3 @@-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ImplicitParams #-}@@ -40,7 +39,7 @@ import Options.Applicative import System.Directory import System.Environment.Blank (getEnv)-import System.FilePath ((</>))+import System.FilePath ((</>), (<.>)) import System.Process import System.Time.Extra import Text.ParserCombinators.ReadP (readP_to_S)@@ -129,7 +128,6 @@ examplesPath :: FilePath examplesPath = "bench/example" - defConfig :: Config Success defConfig = execParserPure defaultPrefs (info configP fullDesc) [] @@ -147,6 +145,7 @@          <|> pure Normal         )     <*> optional (strOption (long "shake-profiling" <> metavar "PATH"))+    <*> optional (strOption (long "ot-profiling" <> metavar "DIR" <> help "Enable OpenTelemetry and write eventlog for each benchmark in DIR"))     <*> strOption (long "csv" <> metavar "PATH" <> value "results.csv" <> showDefault)     <*> flag Cabal Stack (long "stack" <> help "Use stack (by default cabal is used)")     <*> many (strOption (long "ghcide-options" <> help "additional options for ghcide"))@@ -212,6 +211,10 @@   let benchmarks = [ b{samples = fromMaybe (samples b) (repetitions ?config) }                    | b <- allBenchmarks                    , select b ]++  whenJust (otMemoryProfiling ?config) $ \eventlogDir ->+      createDirectoryIfMissing True eventlogDir+   results <- forM benchmarks $ \b@Bench{name} ->                 let run = runSessionWithConfig conf (cmd name dir) lspTestCaps dir                 in (b,) <$> runBench run b@@ -269,23 +272,24 @@   outputRow $ (map . map) (const '-') paddedHeaders   forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row   where-    gcStats name = escapeSpaces (name <> ".benchmark-gcStats")     cmd name dir =       unwords $         [ ghcide ?config,           "--lsp",           "--test",           "--cwd",-          dir,-          "+RTS",-          "-S" <> gcStats name,-          "-RTS"+          dir         ]+          ++ case otMemoryProfiling ?config of+            Just dir -> ["-l", "-ol" ++ (dir </> map (\c -> if c == ' ' then '-' else c) name <.> "eventlog")]+            Nothing -> []+          ++ [ "-RTS" ]           ++ ghcideOptions ?config           ++ concat             [ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config]             ]           ++ ["--verbose" | verbose ?config]+          ++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]]     lspTestCaps =       fullCaps {_window = Just $ WindowClientCapabilities $ Just True}     conf =

@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-}-module Experiments.Types where+{-# LANGUAGE OverloadedStrings #-}+module Experiments.Types (module Experiments.Types ) where  import Data.Aeson import Data.Version@@ -18,6 +19,7 @@   { verbosity :: !Verbosity,     -- For some reason, the Shake profile files are truncated and won't load     shakeProfiling :: !(Maybe FilePath),+    otMemoryProfiling :: !(Maybe FilePath),     outputCSV :: !FilePath,     buildTool :: !CabalStack,     ghcideOptions :: ![String],

@@ -12,6 +12,7 @@     ,argFiles :: [FilePath]     ,argsVersion :: Bool     ,argsShakeProfiling :: Maybe FilePath+    ,argsOTMemoryProfiling :: Bool     ,argsTesting :: Bool     ,argsThreads :: Int     ,argsVerbose :: Bool@@ -32,6 +33,7 @@       <*> many (argument str (metavar "FILES/DIRS..."))       <*> switch (long "version" <> help "Show ghcide and GHC versions")       <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")+      <*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect")       <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")       <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault)       <*> switch (long "verbose" <> help "Include internal events in logging output")

@@ -31,7 +31,7 @@ import Development.IDE.Plugin.Completions as Completions import Development.IDE.Plugin.CodeAction as CodeAction import Development.IDE.Plugin.Test as Test-import Development.IDE.Session+import Development.IDE.Session (loadSession) import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types@@ -50,6 +50,10 @@ import qualified Data.Aeson as J  import HIE.Bios.Cradle+import Development.IDE (action)+import Text.Printf+import Development.IDE.Core.Tracing+import Development.IDE.Types.Shake (Key(Key))  ghcideVersion :: IO String ghcideVersion = do@@ -104,16 +108,17 @@             sessionLoader <- loadSession $ fromMaybe dir rootPath             config <- fromMaybe defaultLspConfig <$> getConfig             let options = (defaultIdeOptions sessionLoader)-                    { optReportProgress = clientSupportsProgress caps-                    , optShakeProfiling = argsShakeProfiling-                    , optTesting        = IdeTesting argsTesting-                    , optThreads        = argsThreads-                    , optCheckParents   = checkParents config-                    , optCheckProject   = checkProject config+                    { optReportProgress    = clientSupportsProgress caps+                    , optShakeProfiling    = argsShakeProfiling+                    , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling+                    , optTesting           = IdeTesting argsTesting+                    , optThreads           = argsThreads+                    , optCheckParents      = checkParents config+                    , optCheckProject      = checkProject config                     }                 logLevel = if argsVerbose then minBound else Info             debouncer <- newAsyncDebouncer-            initialise caps (mainRule >> pluginRules plugins)+            initialise caps (mainRule >> pluginRules plugins >> action kick)                 getLspId event wProg wIndefProg (logger logLevel) debouncer options vfs     else do         -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error@@ -138,21 +143,45 @@         putStrLn "\nStep 3/4: Initializing the IDE"         vfs <- makeVFSHandle         debouncer <- newAsyncDebouncer-        let logLevel = if argsVerbose then minBound else Info-            dummyWithProg _ _ f = f (const (pure ()))+        let dummyWithProg _ _ f = f (const (pure ()))         sessionLoader <- loadSession dir-        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger logLevel) debouncer (defaultIdeOptions sessionLoader)  vfs+        let options = (defaultIdeOptions sessionLoader)+                    { optShakeProfiling    = argsShakeProfiling+                    -- , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling+                    , optTesting           = IdeTesting argsTesting+                    , optThreads           = argsThreads+                    }+            logLevel = if argsVerbose then minBound else Info+        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger logLevel) debouncer options vfs          putStrLn "\nStep 4/4: Type checking the files"         setFilesOfInterest ide $ HashMap.fromList $ map ((, OnDisk) . toNormalizedFilePath') files         results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files)+        _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' files)+        _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' files)         let (worked, failed) = partition fst $ zip (map isJust results) files         when (failed /= []) $             putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed -        let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"-        putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"+        let nfiles xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"+        putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)"++        when argsOTMemoryProfiling $ do+            let valuesRef = state $ shakeExtras ide+            values <- readVar valuesRef+            let consoleObserver Nothing = return $ \size -> printf "Total: %.2fMB\n" (fromIntegral @Int @Double size / 1e6)+                consoleObserver (Just k) = return $ \size -> printf "  - %s: %.2fKB\n" (show k) (fromIntegral @Int @Double size / 1e3)++            printf "# Shake value store contents(%d):\n" (length values)+            let keys = nub+                     $ Key GhcSession : Key GhcSessionDeps+                     : [ k | (_,k) <- HashMap.keys values, k /= Key GhcSessionIO]+                     ++ [Key GhcSessionIO]+            measureMemory (logger logLevel) [keys] consoleObserver valuesRef+         unless (null failed) (exitWith $ ExitFailure (length failed))++{-# ANN main ("HLint: ignore Use nubOrd" :: String) #-}  expandFiles :: [FilePath] -> IO [FilePath] expandFiles = concatMapM $ \x -> do

@@ -2,7 +2,7 @@ build-type:         Simple category:           Development name:               ghcide-version:            0.5.0+version:            0.6.0 license:            Apache-2.0 license-file:       LICENSE author:             Digital Asset and Ghcide contributors@@ -57,6 +57,7 @@         hie-compat,         mtl,         network-uri,+        parallel,         prettyprinter-ansi-terminal,         prettyprinter-ansi-terminal,         prettyprinter,@@ -73,7 +74,9 @@         transformers,         unordered-containers >= 0.2.10.0,         utf8-string,-        hslogger+        hslogger,+        opentelemetry >=0.6.1,+        heapsize ==0.3.*     if flag(ghc-lib)       build-depends:         ghc-lib >= 8.8,@@ -90,7 +93,7 @@         ghc-paths,         cryptohash-sha1 >=0.11.100 && <0.12,         hie-bios >= 0.7.1 && < 0.8.0,-        implicit-hie-cradle >= 0.2.0.1 && < 0.3,+        implicit-hie-cradle >= 0.3.0.2 && < 0.4,         base16-bytestring >=0.1.1 && <0.2     if os(windows)       build-depends:@@ -134,6 +137,7 @@         Development.IDE.Core.RuleTypes         Development.IDE.Core.Service         Development.IDE.Core.Shake+        Development.IDE.Core.Tracing         Development.IDE.GHC.Compat         Development.IDE.GHC.Error         Development.IDE.GHC.Orphans@@ -149,9 +153,11 @@         Development.IDE.Spans.LocalBindings         Development.IDE.Types.Diagnostics         Development.IDE.Types.Exports+        Development.IDE.Types.KnownTargets         Development.IDE.Types.Location         Development.IDE.Types.Logger         Development.IDE.Types.Options+        Development.IDE.Types.Shake         Development.IDE.Plugin         Development.IDE.Plugin.Completions         Development.IDE.Plugin.CodeAction@@ -202,7 +208,6 @@     hs-source-dirs: bench/hist bench/lib     other-modules: Experiments.Types     build-tool-depends:-        ghcide:ghcide,         ghcide:ghcide-bench     default-extensions:         BangPatterns@@ -212,7 +217,6 @@         GeneralizedNewtypeDeriving         LambdaCase         NamedFieldPuns-        OverloadedStrings         RecordWildCards         ScopedTypeVariables         StandaloneDeriving@@ -223,12 +227,8 @@     build-depends:         aeson,         base == 4.*,-        Chart,-        Chart-diagrams,-        diagrams,-        diagrams-svg,+        shake-bench == 0.1.*,         directory,-        extra >= 1.7.2,         filepath,         shake,         text,@@ -262,6 +262,7 @@         hashable,         haskell-lsp,         haskell-lsp-types,+        heapsize,         hie-bios,         ghcide,         lens,@@ -385,7 +386,7 @@         text     hs-source-dirs: bench/lib bench/exe     include-dirs: include-    ghc-options: -threaded -Wall -Wno-name-shadowing+    ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts     main-is: Main.hs     other-modules:         Experiments

@@ -3,8 +3,10 @@  #ifdef GHC_LIB #define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z)+#define GHC_API_VERSION VERSION_ghc_lib #else #define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z)+#define GHC_API_VERSION VERSION_ghc #endif  #endif

@@ -3,7 +3,12 @@ {-| The logic for setting up a ghcide session by tapping into hie-bios. -}-module Development.IDE.Session (loadSession) where+module Development.IDE.Session+  (SessionLoadingOptions(..)+  ,defaultLoadingOptions+  ,loadSession+  ,loadSessionWithOptions+  ) where  -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses -- the real GHC library and the types are incompatible. Furthermore, when@@ -31,7 +36,6 @@ import Data.Maybe import Data.Time.Clock import Data.Version-import Development.IDE.Core.OfInterest import Development.IDE.Core.Shake import Development.IDE.Core.RuleTypes import Development.IDE.GHC.Compat hiding (Target, TargetModule, TargetFile)@@ -45,7 +49,7 @@ import Development.IDE.Types.Options import Development.Shake (Action) import GHC.Check-import HIE.Bios+import qualified HIE.Bios as HieBios import HIE.Bios.Environment hiding (getCacheDir) import HIE.Bios.Types import Hie.Implicit.Cradle (loadImplicitHieCradle)@@ -65,7 +69,28 @@ import NameCache import Packages import Control.Exception (evaluate)+import Data.Void ++data CacheDirs = CacheDirs+  { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath}++data SessionLoadingOptions = SessionLoadingOptions+  { findCradle :: FilePath -> IO (Maybe FilePath)+  , loadCradle :: FilePath -> IO (HieBios.Cradle Void)+  -- | Given the project name and a set of command line flags,+  --   return the path for storing generated GHC artifacts,+  --   or 'Nothing' to respect the cradle setting+  , getCacheDirs :: String -> [String] -> IO CacheDirs+  }++defaultLoadingOptions :: SessionLoadingOptions+defaultLoadingOptions = SessionLoadingOptions+    {findCradle = HieBios.findCradle+    ,loadCradle = HieBios.loadCradle+    ,getCacheDirs = getCacheDirsDefault+    }+ -- | Given a root directory, return a Shake 'Action' which setups an -- 'IdeGhcSession' given a file. -- Some of the many things this does:@@ -80,7 +105,10 @@ -- components mapping to the same hie.yaml file are mapped to the same -- HscEnv which is updated as new components are discovered. loadSession :: FilePath -> IO (Action IdeGhcSession)-loadSession dir = do+loadSession = loadSessionWithOptions defaultLoadingOptions++loadSessionWithOptions :: SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession)+loadSessionWithOptions SessionLoadingOptions{..} dir = do   -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file   hscEnvs <- newVar Map.empty :: IO (Var HieMap)   -- Mapping from a Filepath to HscEnv@@ -166,7 +194,10 @@                   let (df2, uids) = removeInplacePackages inplace rawComponentDynFlags                   let prefix = show rawComponentUnitId                   -- See Note [Avoiding bad interface files]-                  processed_df <- setCacheDir logger prefix (sort $ map show uids) opts df2+                  let hscComponents = sort $ map show uids+                      cacheDirOpts = hscComponents ++ componentOptions opts+                  cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts+                  processed_df <- setCacheDirs logger cacheDirs df2                   -- The final component information, mostly the same but the DynFlags don't                   -- contain any packages which are also loaded                   -- into the same component.@@ -245,7 +276,7 @@            -- Invalidate all the existing GhcSession build nodes by restarting the Shake session           invalidateShakeCache-          restartShakeSession [kick]+          restartShakeSession []            -- Typecheck all files in the project on startup           unless (null cs || not checkProject) $ do@@ -496,14 +527,13 @@ -- | Set the cache-directory based on the ComponentOptions and a list of -- internal packages. -- For the exact reason, see Note [Avoiding bad interface files].-setCacheDir :: MonadIO m => Logger -> String -> [String] -> ComponentOptions -> DynFlags -> m DynFlags-setCacheDir logger prefix hscComponents comps dflags = do-    cacheDir <- liftIO $ getCacheDir prefix (hscComponents ++ componentOptions comps)+setCacheDirs :: MonadIO m => Logger -> CacheDirs -> DynFlags -> m DynFlags+setCacheDirs logger CacheDirs{..} dflags = do     liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack cacheDir     pure $ dflags-          & setHiDir cacheDir-          & setHieDir cacheDir-          & setODir cacheDir+          & maybe id setHiDir hiCacheDir+          & maybe id setHieDir hieCacheDir+          & maybe id setODir oCacheDir   renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic@@ -618,7 +648,8 @@ -- | Throws if package flags are unsatisfiable setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [GHC.Target]) setOptions (ComponentOptions theOpts compRoot _) dflags = do-    (dflags', targets) <- addCmdOpts theOpts dflags+    (dflags', targets') <- addCmdOpts theOpts dflags+    let targets = makeTargetsAbsolute compRoot targets'     let dflags'' =           disableWarningsAsErrors $           -- disabled, generated directly by ghcide instead@@ -665,8 +696,10 @@     -- override user settings to avoid conflicts leading to recompilation     d { objectDir = Just f} -getCacheDir :: String -> [String] -> IO FilePath-getCacheDir prefix opts = getXdgDirectory XdgCache (cacheDir </> prefix ++ "-" ++ opts_hash)+getCacheDirsDefault :: String -> [String] -> IO CacheDirs+getCacheDirsDefault prefix opts = do+    dir <- Just <$> getXdgDirectory XdgCache (cacheDir </> prefix ++ "-" ++ opts_hash)+    return $ CacheDirs dir dir dir     where         -- Create a unique folder per set of different GHC options, assuming that each different set of         -- GHC options will create incompatible interface files.

@@ -8,8 +8,7 @@  import Development.IDE.Core.RuleTypes as X import Development.IDE.Core.Rules as X-  (GhcSessionIO(..)-  ,getAtPoint+  (getAtPoint   ,getDefinition   ,getParsedModule   ,getTypeDefinition

@@ -136,7 +136,6 @@         modSummary' <- initPlugins hsc modSummary         (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->             tcRnModule hsc keep_lbls $ enableTopLevelWarnings-                                     $ enableUnnecessaryAndDeprecationWarnings                                      $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}         let errorPipeline = unDefer . hideDiag dflags . tagDiag             diags = map errorPipeline warnings@@ -332,18 +331,10 @@   warn2err = T.intercalate ": error:" . T.splitOn ": warning:"  hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)-hideDiag originalFlags (Reason warning, (nfp, sh, fd))+hideDiag originalFlags (Reason warning, (nfp, _sh, fd))   | not (wopt warning originalFlags)-  = if null (_tags fd)-       then (Reason warning, (nfp, HideDiag, fd))-            -- keep the diagnostic if it has an associated tag-       else (Reason warning, (nfp, sh, fd{_severity = Just DsInfo}))+  = (Reason warning, (nfp, HideDiag, fd)) hideDiag _originalFlags t = t--enableUnnecessaryAndDeprecationWarnings :: ParsedModule -> ParsedModule-enableUnnecessaryAndDeprecationWarnings =-  (update_pm_mod_summary . update_hspp_opts)-  (foldr (.) id [(`wopt_set` flag) | flag <- unnecessaryDeprecationWarningFlags])  -- | Warnings which lead to a diagnostic tag unnecessaryDeprecationWarningFlags :: [WarningFlag]

@@ -36,7 +36,7 @@ import qualified Data.ByteString.Char8 as BS import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location-import Development.IDE.Core.OfInterest (getFilesOfInterest, kick)+import Development.IDE.Core.OfInterest (getFilesOfInterest) import Development.IDE.Core.RuleTypes import Development.IDE.Types.Options import qualified Data.Rope.UTF16 as Rope@@ -226,7 +226,7 @@     VFSHandle{..} <- getIdeGlobalState state     when (isJust setVirtualFileContents) $         fail "setFileModified can't be called on this type of VFSHandle"-    shakeRestart state [kick]+    shakeRestart state []     when checkParents $       typecheckParents state nfp @@ -239,10 +239,12 @@     revs <- transitiveReverseDependencies nfp <$> useNoFile_ GetModuleGraph     logger <- logger <$> getShakeExtras     let log = L.logInfo logger . T.pack-    liftIO $ do-      (log $ "Typechecking reverse dependencies for" ++ show nfp ++ ": " ++ show revs)-        `catch` \(e :: SomeException) -> log (show e)-    () <$ uses GetModIface revs+    case revs of+      Nothing -> liftIO $ log $ "Could not identify reverse dependencies for " ++ show nfp+      Just rs -> do+        liftIO $ (log $ "Typechecking reverse dependencies for " ++ show nfp ++ ": " ++ show revs)+          `catch` \(e :: SomeException) -> log (show e)+        () <$ uses GetModIface rs  -- | Note that some buffer somewhere has been modified, but don't say what. --   Only valid if the virtual file system was initialised by LSP, as that@@ -252,4 +254,4 @@     VFSHandle{..} <- getIdeGlobalState state     when (isJust setVirtualFileContents) $         fail "setSomethingModified can't be called on this type of VFSHandle"-    void $ shakeRestart state [kick]+    void $ shakeRestart state []

@@ -88,8 +88,8 @@  -- | Typecheck all the files of interest. --   Could be improved-kick :: DelayedAction ()-kick = mkDelayedAction "kick" Debug $ do+kick :: Action ()+kick = do     files <- HashMap.keys <$> getFilesOfInterest     ShakeExtras{progressUpdate} <- getShakeExtras     liftIO $ progressUpdate KickStarted

@@ -18,7 +18,7 @@ import           Development.IDE.Import.DependencyInformation import Development.IDE.GHC.Compat hiding (HieFileResult) import Development.IDE.GHC.Util-import Development.IDE.Core.Shake (KnownTargets)+import Development.IDE.Types.KnownTargets import           Data.Hashable import           Data.Typeable import qualified Data.Set as S@@ -36,6 +36,7 @@ import Language.Haskell.LSP.Types (NormalizedFilePath) import TcRnMonad (TcGblEnv) import qualified Data.ByteString.Char8 as BS+import Development.IDE.Types.Options (IdeGhcSession)  data LinkableType = ObjectLinkable | BCOLinkable   deriving (Eq,Ord,Show)@@ -138,10 +139,10 @@   -- Lazyness can't cause leaks here because the lifetime of `refMap` will be the same   -- as that of `hieAst`   }- + instance NFData HieAstResult where     rnf (HAR m hf _rm) = rnf m `seq` rwhnf hf- + instance Show HieAstResult where     show = show . hieModule @@ -335,3 +336,13 @@ instance Binary   GetClientSettings  type instance RuleResult GetClientSettings = Hashed (Maybe Value)++-- A local rule type to get caching. We want to use newCache, but it has+-- thread killed exception issues, so we lift it to a full rule.+-- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547+type instance RuleResult GhcSessionIO = IdeGhcSession++data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic)+instance Hashable GhcSessionIO+instance NFData   GhcSessionIO+instance Binary   GhcSessionIO

@@ -624,16 +624,6 @@   where     go (mod, time) = LM time mod [] --- A local rule type to get caching. We want to use newCache, but it has--- thread killed exception issues, so we lift it to a full rule.--- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547-type instance RuleResult GhcSessionIO = IdeGhcSession--data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic)-instance Hashable GhcSessionIO-instance NFData   GhcSessionIO-instance Binary   GhcSessionIO- loadGhcSession :: Rules () loadGhcSession = do     -- This function should always be rerun because it tracks changes@@ -905,13 +895,20 @@ needsCompilationRule :: Rules () needsCompilationRule = defineEarlyCutoff $ \NeedsCompilation file -> do   ((ms,_),_) <- useWithStale_ GetModSummaryWithoutTimestamps file-  -- A file needs object code if it uses TH or any file that depends on it uses TH+  -- A file needs object code if it uses TemplateHaskell or any file that depends on it uses TemplateHaskell   res <-     if uses_th_qq ms     then pure True-    -- Treat as False if some reverse dependency header fails to parse-    else anyM (fmap (fromMaybe False) . use NeedsCompilation) . maybe [] (immediateReverseDependencies file)-           =<< useNoFile GetModuleGraph+    else do+      graph <- useNoFile GetModuleGraph+      case graph of+          -- Treat as False if some reverse dependency header fails to parse+          Nothing -> pure False+          Just depinfo -> case immediateReverseDependencies file depinfo of+            -- If we fail to get immediate reverse dependencies, fail with an error message+            Nothing -> fail $ "Failed to get the immediate reverse dependencies of " ++ show file+            Just revdeps -> anyM (fmap (fromMaybe False) . use NeedsCompilation) revdeps+   pure (Just $ BS.pack $ show $ hash res, ([], Just res))   where     uses_th_qq (ms_hspp_opts -> dflags) =

@@ -56,6 +56,7 @@         toDiags         wProg         wIndefProg+        caps         logger         debouncer         (optShakeProfiling options)

@@ -1,8 +1,7 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DerivingStrategies #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification  #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-}@@ -70,7 +69,6 @@ import           Development.Shake.Database import           Development.Shake.Classes import           Development.Shake.Rule-import           Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HMap import qualified Data.Map.Strict as Map import qualified Data.ByteString.Char8 as BS@@ -78,17 +76,18 @@ import           Data.Maybe import           Data.Map.Strict (Map) import           Data.List.Extra (partition, takeEnd)-import           Data.HashSet (HashSet) import qualified Data.Set as Set import qualified Data.Text as T import Data.Tuple.Extra import Data.Unique import Development.IDE.Core.Debouncer-import Development.IDE.GHC.Compat (ModuleName, NameCacheUpdater(..), upNameCache )+import Development.IDE.GHC.Compat (NameCacheUpdater(..), upNameCache ) import Development.IDE.GHC.Orphans () import Development.IDE.Core.PositionMapping import Development.IDE.Types.Action import Development.IDE.Types.Logger hiding (Priority)+import Development.IDE.Types.KnownTargets+import Development.IDE.Types.Shake import qualified Development.IDE.Types.Logger as Logger import Language.Haskell.LSP.Diagnostics import qualified Data.SortedList as SL@@ -119,13 +118,15 @@ import Control.Monad.Trans.Maybe import Data.Traversable import Data.Hashable+import Development.IDE.Core.Tracing  import Data.IORef import NameCache import UniqSupply import PrelInfo import Data.Int (Int64)-import qualified Data.HashSet as HSet+import Language.Haskell.LSP.Types.Capabilities+import OpenTelemetry.Eventlog  -- information we stash inside the shakeExtra field data ShakeExtras = ShakeExtras@@ -164,18 +165,9 @@     ,exportsMap :: Var ExportsMap     -- | A work queue for actions added via 'runInShakeSession'     ,actionQueue :: ActionQueue+    ,clientCapabilities :: ClientCapabilities     } --- | A mapping of module name to known files-type KnownTargets = HashMap Target [NormalizedFilePath]--data Target = TargetModule ModuleName | TargetFile NormalizedFilePath-  deriving ( Eq, Generic, Show )-  deriving anyclass (Hashable, NFData)--toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath-toKnownFiles = HSet.fromList . concat . HMap.elems- type WithProgressFunc = forall a.     T.Text -> LSP.ProgressCancellable -> ((LSP.Progress -> IO ()) -> IO a) -> IO a type WithIndefiniteProgressFunc = forall a.@@ -226,22 +218,6 @@ getIdeGlobalState = getIdeGlobalExtras . shakeExtras  --- | The state of the all values.-type Values = HMap.HashMap (NormalizedFilePath, Key) (Value Dynamic)---- | Key type-data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k--instance Show Key where-  show (Key k) = show k--instance Eq Key where-    Key k1 == Key k2 | Just k2' <- cast k2 = k1 == k2'-                     | otherwise = False--instance Hashable Key where-    hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key)- newtype GlobalIdeOptions = GlobalIdeOptions IdeOptions instance IsIdeGlobal GlobalIdeOptions @@ -255,21 +231,6 @@     GlobalIdeOptions x <- getIdeGlobalExtras ide     return x -data Value v-    = Succeeded TextDocumentVersion v-    | Stale TextDocumentVersion v-    | Failed-    deriving (Functor, Generic, Show)--instance NFData v => NFData (Value v)---- | Convert a Value to a Maybe. This will only return `Just` for--- up2date results not for stale values.-currentValue :: Value v -> Maybe v-currentValue (Succeeded _ v) = Just v-currentValue (Stale _ _) = Nothing-currentValue Failed = Nothing- -- | Return the most recent, potentially stale, value and a PositionMapping -- for the version of that value. lastValueIO :: ShakeExtras -> NormalizedFilePath -> Value v -> IO (Maybe (v, PositionMapping))@@ -401,6 +362,7 @@           -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler           -> WithProgressFunc           -> WithIndefiniteProgressFunc+          -> ClientCapabilities           -> Logger           -> Debouncer NormalizedUri           -> Maybe FilePath@@ -409,7 +371,7 @@           -> ShakeOptions           -> Rules ()           -> IO IdeState-shakeOpen getLspId eventer withProgress withIndefiniteProgress logger debouncer+shakeOpen getLspId eventer withProgress withIndefiniteProgress clientCapabilities logger debouncer   shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) opts rules = mdo      inProgress <- newVar HMap.empty@@ -443,6 +405,11 @@     initSession <- newSession shakeExtras shakeDb []     shakeSession <- newMVar initSession     let ideState = IdeState{..}++    IdeOptions{ optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled } <- getIdeOptionsIO shakeExtras+    when otProfilingEnabled $+        startTelemetry logger $ state shakeExtras+     return ideState     where         -- The progress thread is a state machine with two states:@@ -616,11 +583,12 @@     let         -- A daemon-like action used to inject additional work         -- Runs actions from the work queue sequentially-        pumpActionThread = do+        pumpActionThread otSpan = do             d <- liftIO $ atomically $ popQueue actionQueue-            void $ parallel [run d, pumpActionThread]+            void $ parallel [run otSpan d, pumpActionThread otSpan] -        run d  = do+        -- TODO figure out how to thread the otSpan into defineEarlyCutoff+        run _otSpan d  = do             start <- liftIO offsetTime             getAction d             liftIO $ atomically $ doneQueue d actionQueue@@ -631,8 +599,8 @@                 logPriority logger (actionPriority d) msg                 notifyTestingLogMessage extras msg -        workRun restore = do-          let acts' = pumpActionThread : map run (reenqueued ++ acts)+        workRun restore = withSpan "Shake session" $ \otSpan -> do+          let acts' = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts)           res <- try @SomeException (restore $ shakeRunDatabase shakeDb acts')           let res' = case res of                       Left e -> "exception: " <> displayException e@@ -862,7 +830,7 @@     :: IdeRule k v     => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))     -> Rules ()-defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do+defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file $ do     extras@ShakeExtras{state, inProgress} <- getShakeExtras     -- don't do progress for GetFileExists, as there are lots of non-nodes for just that one key     (if show key == "GetFileExists" then id else withProgressVar inProgress file) $ do

@@ -0,0 +1,179 @@+{-# LANGUAGE DataKinds #-}+module Development.IDE.Core.Tracing+    ( otTracedHandler+    , otTracedAction+    , startTelemetry+    , measureMemory+    , getInstrumentCached+    )+where++import           Control.Concurrent.Async       (Async, async)+import           Control.Concurrent.Extra       (Var, modifyVar_, newVar,+                                                 readVar, threadDelay)+import           Control.Exception              (evaluate)+import           Control.Exception.Safe         (catch, SomeException)+import           Control.Monad                  (forM_, forever, (>=>))+import           Control.Monad.Extra            (whenJust)+import           Control.Seq                    (r0, seqList, seqTuple2, using)+import           Data.Dynamic                   (Dynamic)+import qualified Data.HashMap.Strict            as HMap+import           Data.IORef                     (modifyIORef', newIORef,+                                                 readIORef, writeIORef)+import           Data.List                      (nub)+import           Data.String                    (IsString (fromString))+import           Development.IDE.Core.RuleTypes (GhcSession (GhcSession),+                                                 GhcSessionDeps (GhcSessionDeps),+                                                 GhcSessionIO (GhcSessionIO))+import           Development.IDE.Types.Logger   (logInfo, Logger, logDebug)+import           Development.IDE.Types.Shake    (Key (..), Value, Values)+import           Development.Shake              (Action, actionBracket, liftIO)+import           Foreign.Storable               (Storable (sizeOf))+import           HeapSize                       (recursiveSize, runHeapsize)+import           Language.Haskell.LSP.Types     (NormalizedFilePath,+                                                 fromNormalizedFilePath)+import           Numeric.Natural                (Natural)+import           OpenTelemetry.Eventlog         (addEvent, beginSpan, endSpan,+                                                 mkValueObserver, observe,+                                                 setTag, withSpan, withSpan_)++-- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span.+otTracedHandler+    :: String -- ^ Message type+    -> String -- ^ Message label+    -> IO a+    -> IO a+otTracedHandler requestType label act =+  let !name =+        if null label+          then requestType+          else requestType <> ":" <> show label+   -- Add an event so all requests can be quickly seen in the viewer without searching+   in withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> act)++-- | Trace a Shake action using opentelemetry.+otTracedAction+    :: Show k+    => k -- ^ The Action's Key+    -> NormalizedFilePath -- ^ Path to the file the action was run for+    -> Action a -- ^ The action+    -> Action a+otTracedAction key file act = actionBracket+    (do+        sp <- beginSpan (fromString (show key))+        setTag sp "File" (fromString $ fromNormalizedFilePath file)+        return sp+    )+    endSpan+    (const act)++startTelemetry :: Logger -> Var Values -> IO ()+startTelemetry logger stateRef = do+    instrumentFor <- getInstrumentCached+    mapCountInstrument <- mkValueObserver "values map count"++    _ <- regularly (1 * seconds) $+        withSpan_ "Measure length" $+        readVar stateRef+        >>= observe mapCountInstrument . length++    _ <- regularly (1 * seconds) $ do+        values <- readVar stateRef+        let keys = nub+                     $ Key GhcSession : Key GhcSessionDeps+                     : [ k | (_,k) <- HMap.keys values+                           -- do GhcSessionIO last since it closes over stateRef itself+                           , k /= Key GhcSessionIO]+                     ++ [Key GhcSessionIO]+        !groupedForSharing <- evaluate (keys `using` seqList r0)+        measureMemory logger [groupedForSharing] instrumentFor stateRef+          `catch` \(e::SomeException) ->+            logInfo logger ("MEMORY PROFILING ERROR: " <> fromString (show e))+    return ()+  where+        seconds = 1000000++        regularly :: Int -> IO () -> IO (Async ())+        regularly delay act = async $ forever (act >> threadDelay delay)++{-# ANN startTelemetry ("HLint: ignore Use nubOrd" :: String) #-}++type OurValueObserver = Int -> IO ()++getInstrumentCached :: IO (Maybe Key -> IO OurValueObserver)+getInstrumentCached = do+    instrumentMap <- newVar HMap.empty+    mapBytesInstrument <- mkValueObserver "value map size_bytes"++    let instrumentFor k = do+          mb_inst <- HMap.lookup k <$> readVar instrumentMap+          case mb_inst of+            Nothing -> do+                instrument <- mkValueObserver (fromString (show k ++ " size_bytes"))+                modifyVar_ instrumentMap (return . HMap.insert k instrument)+                return $ observe instrument+            Just v -> return $ observe v+    return $ maybe (return $ observe mapBytesInstrument) instrumentFor++whenNothing :: IO () -> IO (Maybe a) -> IO ()+whenNothing act mb = mb >>= f+  where f Nothing = act+        f Just{}  = return ()++measureMemory+    :: Logger+    -> [[Key]]     -- ^ Grouping of keys for the sharing-aware analysis+    -> (Maybe Key -> IO OurValueObserver)+    -> Var Values+    -> IO ()+measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" $ do+    values <- readVar stateRef+    valuesSizeRef <- newIORef $ Just 0+    let !groupsOfGroupedValues = groupValues values+    logDebug logger "STARTING MEMORY PROFILING"+    forM_ groupsOfGroupedValues $ \groupedValues -> do+        keepGoing <- readIORef valuesSizeRef+        whenJust keepGoing $ \_ ->+          whenNothing (writeIORef valuesSizeRef Nothing) $+          repeatUntilJust 3 $ do+          -- logDebug logger (fromString $ show $ map fst groupedValues)+          runHeapsize 25000000 $+              forM_ groupedValues $ \(k,v) -> withSpan ("Measure " <> (fromString $ show k)) $ \sp -> do+              acc <- liftIO $ newIORef 0+              observe <- liftIO $ instrumentFor $ Just k+              mapM_ (recursiveSize >=> \x -> liftIO (modifyIORef' acc (+ x))) v+              size <- liftIO $ readIORef acc+              let !byteSize = sizeOf (undefined :: Word) * size+              setTag sp "size" (fromString (show byteSize ++ " bytes"))+              () <- liftIO $ observe byteSize+              liftIO $ modifyIORef' valuesSizeRef (fmap (+ byteSize))++    mbValuesSize <- readIORef valuesSizeRef+    case mbValuesSize of+        Just valuesSize -> do+            observe <- instrumentFor Nothing+            observe valuesSize+            logDebug logger "MEMORY PROFILING COMPLETED"+        Nothing ->+            logInfo logger "Memory profiling could not be completed: increase the size of your nursery (+RTS -Ax) and try again"++    where+        groupValues :: Values -> [ [(Key, [Value Dynamic])] ]+        groupValues values =+            let !groupedValues =+                    [ [ (k, vv)+                      | k <- groupKeys+                      , let vv = [ v | ((_,k'), v) <- HMap.toList values , k == k']+                      ]+                    | groupKeys <- groups+                    ]+                -- force the spine of the nested lists+            in groupedValues `using` seqList (seqList (seqTuple2 r0 (seqList r0)))++repeatUntilJust :: Monad m => Natural -> m (Maybe a) -> m (Maybe a)+repeatUntilJust 0 _ = return Nothing+repeatUntilJust nattempts action = do+    res <- action+    case res of+        Nothing -> repeatUntilJust (nattempts-1) action+        Just{}  -> return res

@@ -56,10 +56,16 @@ -- | Produce a GHC-style error from a source span and a message. diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic] diagFromErrMsg diagSource dflags e =-    [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $-      ErrUtils.formatErrDoc dflags $ ErrUtils.errMsgDoc e+    [ diagFromText diagSource sev (errMsgSpan e)+      $ T.pack $ formatErrorWithQual dflags e     | Just sev <- [toDSeverity $ errMsgSeverity e]] +formatErrorWithQual :: DynFlags -> ErrMsg -> String+formatErrorWithQual dflags e =+    Out.showSDoc dflags+    $ Out.withPprStyle (Out.mkErrStyle dflags $ errMsgContext e)+    $ ErrUtils.formatErrDoc dflags+    $ ErrUtils.errMsgDoc e  diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic] diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList

@@ -317,23 +317,23 @@ partitionSCC []                  = ([], [])  -- | Transitive reverse dependencies of a file-transitiveReverseDependencies :: NormalizedFilePath -> DependencyInformation -> [NormalizedFilePath]-transitiveReverseDependencies file DependencyInformation{..} =-  let FilePathId cur_id = pathToId depPathIdMap file-  in map (idToPath depPathIdMap . FilePathId) (IntSet.toList (go cur_id IntSet.empty))+transitiveReverseDependencies :: NormalizedFilePath -> DependencyInformation -> Maybe [NormalizedFilePath]+transitiveReverseDependencies file DependencyInformation{..} = do+    FilePathId cur_id <- lookupPathToId depPathIdMap file+    return $ map (idToPath depPathIdMap . FilePathId) (IntSet.toList (go cur_id IntSet.empty))   where     go :: Int -> IntSet -> IntSet     go k i =-      let outwards = fromMaybe IntSet.empty (IntMap.lookup k depReverseModuleDeps  )+      let outwards = fromMaybe IntSet.empty (IntMap.lookup k depReverseModuleDeps)           res = IntSet.union i outwards           new = IntSet.difference i outwards       in IntSet.foldr go res new  -- | Immediate reverse dependencies of a file-immediateReverseDependencies :: NormalizedFilePath -> DependencyInformation -> [NormalizedFilePath]-immediateReverseDependencies file DependencyInformation{..} =-  let FilePathId cur_id = pathToId depPathIdMap file-  in map (idToPath depPathIdMap . FilePathId) (maybe mempty IntSet.toList (IntMap.lookup cur_id depReverseModuleDeps))+immediateReverseDependencies :: NormalizedFilePath -> DependencyInformation -> Maybe [NormalizedFilePath]+immediateReverseDependencies file DependencyInformation{..} = do+  FilePathId cur_id <- lookupPathToId depPathIdMap file+  return $ map (idToPath depPathIdMap . FilePathId) (maybe mempty IntSet.toList (IntMap.lookup cur_id depReverseModuleDeps))  transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies transitiveDeps DependencyInformation{..} file = do@@ -401,4 +401,3 @@  instance Show NamedModuleDep where   show NamedModuleDep{..} = show nmdFilePath-

@@ -36,6 +36,7 @@ import Development.IDE.LSP.Outline import Development.IDE.Types.Logger import Development.IDE.Core.FileStore+import Development.IDE.Core.Tracing import Language.Haskell.LSP.Core (LspFuncs(..)) import Language.Haskell.LSP.Messages @@ -79,14 +80,16 @@     -- The set of requests that have been cancelled and are also in pendingRequests     cancelledRequests <- newTVarIO Set.empty -    let withResponse wrap f = Just $ \r@RequestMessage{_id} -> do+    let withResponse wrap f = Just $ \r@RequestMessage{_id, _method} -> do             atomically $ modifyTVar pendingRequests (Set.insert _id)             writeChan clientMsgChan $ Response r wrap f-    let withNotification old f = Just $ \r -> writeChan clientMsgChan $ Notification r (\lsp ide x -> f lsp ide x >> whenJust old ($ r))-    let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do+    let withNotification old f = Just $ \r@NotificationMessage{_method} ->+            writeChan clientMsgChan $ Notification r (\lsp ide x -> f lsp ide x >> whenJust old ($ r))+    let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id, _method} -> do             atomically $ modifyTVar pendingRequests (Set.insert _id)             writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f-    let withInitialize f = Just $ \r -> writeChan clientMsgChan $ InitialParams r (\lsp ide x -> f lsp ide x)+    let withInitialize f = Just $ \r ->+            writeChan clientMsgChan $ InitialParams r (\lsp ide x -> f lsp ide x)     let cancelRequest reqId = atomically $ do             queued <- readTVar pendingRequests             -- We want to avoid that the list of cancelled requests@@ -144,18 +147,20 @@                 -- We dispatch notifications synchronously and requests asynchronously                 -- This is to ensure that all file edits and config changes are applied before a request is handled                 case msg of-                    Notification x@NotificationMessage{_params} act -> do+                    Notification x@NotificationMessage{_params, _method} act -> otTracedHandler "Notification" (show _method) $ do                         catch (act lspFuncs ide _params) $ \(e :: SomeException) ->                             logError (ideLogger ide) $ T.pack $                                 "Unexpected exception on notification, please report!\n" ++                                 "Message: " ++ show x ++ "\n" ++                                 "Exception: " ++ show e-                    Response x@RequestMessage{_id, _params} wrap act -> void $ async $+                    Response x@RequestMessage{_id, _method, _params} wrap act -> void $ async $+                        otTracedHandler "Request" (show _method) $                         checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $                             \case                               Left e  -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)                               Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)-                    ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act -> void $ async $+                    ResponseAndRequest x@RequestMessage{_id, _method, _params} wrap wrapNewReq act -> void $ async $+                        otTracedHandler "Request" (show _method) $                         checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $                             \(res, newReq) -> do                                 case res of@@ -164,7 +169,8 @@                                 whenJust newReq $ \(rm, newReqParams) -> do                                     reqId <- getNextReqId                                     sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams-                    InitialParams x@RequestMessage{_id, _params} act -> do+                    InitialParams x@RequestMessage{_id, _method, _params} act ->+                        otTracedHandler "Initialize" (show _method) $                         catch (act lspFuncs ide _params) $ \(e :: SomeException) ->                             logError (ideLogger ide) $ T.pack $                                 "Unexpected exception on InitializeRequest handler, please report!\n" ++

@@ -2,7 +2,7 @@ -- SPDX-License-Identifier: Apache-2.0  {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP                   #-} #include "ghc-api-version.h"  -- | Go to the definition of a variable.@@ -19,6 +19,7 @@     -- * For testing     , blockCommandId     , typeSignatureCommandId+    , matchRegExMultipleImports     ) where  import Control.Monad (join, guard)@@ -29,7 +30,6 @@ import Development.IDE.Core.Service import Development.IDE.Core.Shake import Development.IDE.GHC.Error-import Development.IDE.GHC.Util import Development.IDE.LSP.Server import Development.IDE.Plugin.CodeAction.PositionIndexed import Development.IDE.Plugin.CodeAction.RuleTypes@@ -50,8 +50,6 @@ import Data.List.Extra import qualified Data.Text as T import Data.Tuple.Extra ((&&&))-import HscTypes-import Parser import Text.Regex.TDFA (mrAfter, (=~), (=~~)) import Outputable (ppr, showSDocUnsafe) import GHC.LanguageExtensions.Type (Extension)@@ -98,10 +96,9 @@     pkgExports <- runAction "CodeAction:PackageExports" state $ (useNoFile_ . PackageExports) `traverse` env     localExports <- readVar (exportsMap $ shakeExtras state)     let exportsMap = localExports <> fromMaybe mempty pkgExports-    let dflags = hsc_dflags . hscEnv <$> env     pure . Right $         [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing-        | x <- xs, (title, tedit) <- suggestAction dflags exportsMap ideOptions parsedModule text x+        | x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text x         , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing         ] <> caRemoveRedundantImports parsedModule text diag xs uri @@ -152,18 +149,17 @@     = return (Right Null, Nothing)  suggestAction-  :: Maybe DynFlags-  -> ExportsMap+  :: ExportsMap   -> IdeOptions   -> Maybe ParsedModule   -> Maybe T.Text   -> Diagnostic   -> [(T.Text, [TextEdit])]-suggestAction dflags packageExports ideOptions parsedModule text diag = concat+suggestAction packageExports ideOptions parsedModule text diag = concat    -- Order these suggestions by priority     [ suggestAddExtension diag             -- Highest priority     , suggestSignature True diag-    , suggestExtendImport dflags text diag+    , suggestExtendImport packageExports text diag     , suggestFillTypeWildcard diag     , suggestFixConstructorImport text diag     , suggestModuleTypo diag@@ -377,6 +373,14 @@         _ -> False     needsComma _ _ = False +    opLetter :: String+    opLetter = ":!#$%&*+./<=>?@\\^|-~"++    parenthesizeIfNeeds :: Bool -> T.Text -> T.Text+    parenthesizeIfNeeds needsTypeKeyword x+      | T.head x `elem` opLetter = (if needsTypeKeyword then "type " else "") <> "(" <> x <>")"+      | otherwise = x+     getLocatedRange :: Located a -> Maybe Range     getLocatedRange = srcSpanToRange . getLoc @@ -386,9 +390,9 @@        in loc >= Just l && loc <= Just r      printExport :: ExportsAs -> T.Text -> T.Text-    printExport ExportName x = x+    printExport ExportName x = parenthesizeIfNeeds False x     printExport ExportPattern x = "pattern " <> x-    printExport ExportAll x = x <> "(..)"+    printExport ExportAll x = parenthesizeIfNeeds True x <> "(..)"      isTopLevel :: Range -> Bool     isTopLevel l = (_character . _start) l == 0@@ -634,22 +638,37 @@ indentation :: T.Text -> Int indentation = T.length . T.takeWhile isSpace -suggestExtendImport :: Maybe DynFlags -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestExtendImport (Just dflags) contents Diagnostic{_range=_range,..}+suggestExtendImport :: ExportsMap -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestExtendImport exportsMap contents Diagnostic{_range=_range,..}     | Just [binding, mod, srcspan] <-       matchRegexUnifySpaces _message       "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$"     , Just c <- contents-    , POk _ (L _ name) <- runParser dflags (T.unpack binding) parseIdentifier-    = let range = case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of-            [s] -> let x = realSrcSpanToRange s-                   in x{_end = (_end x){_character = succ (_character (_end x))}}-            _ -> error "bug in srcspan parser"-          importLine = textInRange range c-        in [("Add " <> binding <> " to the import list of " <> mod-        , [TextEdit range (addBindingToImportList (T.pack $ printRdrName name) importLine)])]+    = suggestions c binding mod srcspan+    | Just (binding, mod_srcspan) <-+      matchRegExMultipleImports _message+    , Just c <- contents+    = mod_srcspan >>= (\(x, y) -> suggestions c binding x y)      | otherwise = []-suggestExtendImport Nothing _ _ = []+    where+        suggestions c binding mod srcspan+          |  range <- case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of+                [s] -> let x = realSrcSpanToRange s+                   in x{_end = (_end x){_character = succ (_character (_end x))}}+                _ -> error "bug in srcspan parser",+            importLine <- textInRange range c,+            Just ident <- lookupExportMap binding mod,+            Just result <- addBindingToImportList ident importLine+            = [("Add " <> renderImport ident <> " to the import list of " <> mod, [TextEdit range result])]+          | otherwise = []+        renderImport IdentInfo {parent, rendered}+          | Just p <- parent = p <> "(" <> rendered <> ")"+          | otherwise        = rendered+        lookupExportMap binding mod +          | Just match <- Map.lookup binding (getExportsMap exportsMap)+          , [(ident, _)] <- filter (\(_,m) -> mod == m) (Set.toList match)+           = Just ident+          | otherwise = Nothing  suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] suggestFixConstructorImport _ Diagnostic{_range=_range,..}@@ -1090,16 +1109,40 @@ --       import (qualified) A (..) .. --   Places the new binding first, preserving whitespace. --   Copes with multi-line import lists-addBindingToImportList :: T.Text -> T.Text -> T.Text-addBindingToImportList binding importLine = case T.breakOn "(" importLine of+addBindingToImportList :: IdentInfo -> T.Text -> Maybe T.Text+addBindingToImportList IdentInfo {parent = _parent, ..} importLine =+  case T.breakOn "(" importLine of     (pre, T.uncons -> Just (_, rest)) ->-      case T.uncons (T.dropWhile isSpace rest) of-        Just (')', _) -> T.concat [pre, "(", binding, rest]-        _             -> T.concat [pre, "(", binding, ", ", rest]-    _ ->-      error-        $  "importLine does not have the expected structure: "-        <> T.unpack importLine+      case _parent of+        -- the binding is not a constructor, add it to the head of import list+        Nothing -> Just $ T.concat [pre, "(", rendered, addCommaIfNeeds rest]+        Just parent -> case T.breakOn parent rest of+          -- the binding is a constructor, and current import list contains its parent+          -- `rest'` could be 1. `,...)`+          --               or 2. `(),...)`+          --               or 3. `(ConsA),...)`+          --               or 4. `)`+          (leading, T.stripPrefix parent -> Just rest') -> case T.uncons (T.stripStart rest') of+            -- case 1: no children and parentheses, e.g. `import A(Foo,...)` --> `import A(Foo(Cons), ...)`+            Just (',', rest'') -> Just $ T.concat [pre, "(", leading, parent, "(", rendered, ")", addCommaIfNeeds rest'']+            -- case 2: no children but parentheses, e.g. `import A(Foo(),...)` --> `import A(Foo(Cons), ...)`+            Just ('(', T.uncons -> Just (')', rest'')) -> Just $ T.concat [pre, "(", leading, parent, "(", rendered, ")", rest'']+            -- case 3: children with parentheses, e.g. `import A(Foo(ConsA),...)` --> `import A(Foo(Cons, ConsA), ...)`+            Just ('(', T.breakOn ")" -> (children, rest''))+              | not (T.null children),+                -- ignore A(Foo({-...-}), ...)+                not $ "{-" `T.isPrefixOf` T.stripStart children+              -> Just $ T.concat [pre, "(", leading, parent, "(", rendered, ", ", children, rest'']+            -- case 4: no trailing, e.g. `import A(..., Foo)` --> `import A(..., Foo(Cons))`+            Just (')', _) -> Just $ T.concat [pre, "(", leading, parent, "(", rendered, ")", rest']+            _ -> Nothing+          -- current import list does not contain the parent, e.g. `import A(...)` --> `import A(Foo(Cons), ...)`+          _ -> Just $ T.concat [pre, "(", parent, "(", rendered, ")", addCommaIfNeeds rest]+    _ -> Nothing+  where+    addCommaIfNeeds r = case T.uncons (T.stripStart r) of+      Just (')', _) -> r+      _ -> ", " <> r  -- | 'matchRegex' combined with 'unifySpaces' matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text]@@ -1127,3 +1170,41 @@  unifySpaces :: T.Text -> T.Text unifySpaces    = T.unwords . T.words++-- functions to help parse multiple import suggestions++-- | Returns the first match if found+regexSingleMatch :: T.Text -> T.Text -> Maybe T.Text+regexSingleMatch msg regex = case matchRegexUnifySpaces msg regex of+    Just (h:_) -> Just h+    _ -> Nothing++-- | Parses tuples like (‘Data.Map’, (app/ModuleB.hs:2:1-18)) and+-- | return (Data.Map, app/ModuleB.hs:2:1-18)+regExPair :: (T.Text, T.Text) -> Maybe (T.Text, T.Text)+regExPair (modname, srcpair) = do+  x <- regexSingleMatch modname "‘([^’]*)’"+  y <- regexSingleMatch srcpair "\\((.*)\\)"+  return (x, y)++-- | Process a list of (module_name, filename:src_span) values+-- | Eg. [(Data.Map, app/ModuleB.hs:2:1-18), (Data.HashMap.Strict, app/ModuleB.hs:3:1-29)]+regExImports :: T.Text -> Maybe [(T.Text, T.Text)]+regExImports msg = result+  where+    parts = T.words msg+    isPrefix = not . T.isPrefixOf "("+    (mod, srcspan) = partition isPrefix  parts+    -- check we have matching pairs like (Data.Map, (app/src.hs:1:2-18))+    result = if length mod == length srcspan then+               regExPair `traverse` zip mod srcspan+             else Nothing++matchRegExMultipleImports :: T.Text -> Maybe (T.Text, [(T.Text, T.Text)])+matchRegExMultipleImports message = do+  let pat = T.pack "Perhaps you want to add ‘([^’]*)’ to one of these import lists: *(‘.*\\))$"+  (binding, imports) <- case matchRegexUnifySpaces message pat of+                            Just [x, xs] -> Just (x, xs)+                            _ -> Nothing+  imps <- regExImports imports+  return (binding, imps)

@@ -12,7 +12,7 @@ import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Core as LSP import qualified Language.Haskell.LSP.VFS as VFS-import Language.Haskell.LSP.Types.Capabilities+ import Development.Shake.Classes import Development.Shake import GHC.Generics@@ -71,7 +71,8 @@         case (ms, sess) of             (Just (ms,imps), Just sess) -> do               let env = hscEnv sess-              res <- liftIO $ tcRnImportDecls env imps+              -- We do this to be able to provide completions of items that are not restricted to the explicit list+              res <- liftIO $ tcRnImportDecls env (dropListFromImportDecl <$> imps)               case res of                   (_, Just rdrEnv) -> do                       cdata <- liftIO $ cacheDataProducer env (ms_mod ms) rdrEnv imps parsedDeps@@ -80,6 +81,16 @@                       return ([], Nothing)             _ -> return ([], Nothing) +-- Drop any explicit imports in ImportDecl if not hidden+dropListFromImportDecl :: GenLocated SrcSpan (ImportDecl GhcPs) -> GenLocated SrcSpan (ImportDecl GhcPs)+dropListFromImportDecl iDecl = let+    f d@ImportDecl {ideclHiding} = case ideclHiding of+        Just (False, _) -> d {ideclHiding=Nothing}+        -- if hiding or Nothing just return d+        _ -> d+    f x = x+    in f <$> iDecl+ -- | Produce completions info for a file type instance RuleResult ProduceCompletions = CachedCompletions type instance RuleResult LocalCompletions = CachedCompletions@@ -130,9 +141,8 @@               (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})                 -> return (Completions $ List [])               (Just pfix', _) -> do-                  -- TODO pass the real capabilities here (or remove the logic for snippets)-                let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing-                Completions . List <$> getCompletions ideOpts cci' parsedMod bindMap pfix' fakeClientCapabilities (WithSnippets True)+                let clientCaps = clientCapabilities $ shakeExtras ide+                Completions . List <$> getCompletions ideOpts cci' parsedMod bindMap pfix' clientCaps (WithSnippets True)               _ -> return (Completions $ List [])           _ -> return (Completions $ List [])       _ -> return (Completions $ List [])

@@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-}+ #include "ghc-api-version.h"+#if MIN_GHC_API_VERSION (8,8,4)+{-# LANGUAGE GADTs#-}+#endif -- Mostly taken from "haskell-ide-engine" module Development.IDE.Plugin.Completions.Logic (   CachedCompletions@@ -10,11 +14,12 @@ ) where  import Control.Applicative-import Data.Char (isUpper)+import Data.Char (isAlphaNum, isUpper) import Data.Generics import Data.List.Extra as List hiding (stripPrefix) import qualified Data.Map  as Map-import Data.Maybe (fromMaybe, mapMaybe)++import Data.Maybe (listToMaybe, fromMaybe, mapMaybe) import qualified Data.Text as T import qualified Text.Fuzzy as Fuzzy @@ -45,7 +50,12 @@ import Development.IDE.GHC.Util import Outputable (Outputable) import qualified Data.Set as Set+import ConLike +import GhcPlugins (+    flLabel,+    unpackFS)+ -- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs  -- | A context of a declaration in the program@@ -137,21 +147,44 @@ showModName :: ModuleName -> T.Text showModName = T.pack . moduleNameString +-- mkCompl :: IdeOptions -> CompItem -> CompletionItem+-- mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs} =+--   CompletionItem label kind (List []) ((colon <>) <$> typeText)+--     (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')+--     Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)+--     Nothing Nothing Nothing Nothing Nothing+ mkCompl :: IdeOptions -> CompItem -> CompletionItem-mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs} =-  CompletionItem label kind (List []) ((colon <>) <$> typeText)-    (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')-    Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)-    Nothing Nothing Nothing Nothing Nothing+mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs, additionalTextEdits} =+  CompletionItem {_label = label,+                  _kind = kind,+                  _tags = List [],+                  _detail = (colon <>) <$> typeText,+                  _documentation = documentation,+                  _deprecated = Nothing,+                  _preselect = Nothing,+                  _sortText = Nothing,+                  _filterText = Nothing,+                  _insertText = Just insertText,+                  _insertTextFormat = Just Snippet,+                  _textEdit = Nothing,+                  _additionalTextEdits = List <$> additionalTextEdits,+                  _commitCharacters = Nothing,+                  _command = Nothing,+                  _xdata = Nothing}+   where kind = Just compKind         docs' = imported : spanDocToMarkdown docs         imported = case importedFrom of           Left pos -> "*Defined at '" <> ppr pos <> "'*\n'"           Right mod -> "*Defined in '" <> mod <> "'*\n"         colon = if optNewColonConvention then ": " else ":: "+        documentation = Just $ CompletionDocMarkup $+                        MarkupContent MkMarkdown $+                        T.intercalate sectionSeparator docs' -mkNameCompItem :: Name -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> CompItem-mkNameCompItem origName origMod thingType isInfix docs = CI{..}+mkNameCompItem :: Name -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem+mkNameCompItem origName origMod thingType isInfix docs !imp = CI{..}   where     compKind = occNameToComKind typeText $ occName origName     importedFrom = Right $ showModName origMod@@ -167,7 +200,7 @@     typeText           | Just t <- thingType = Just . stripForall $ T.pack (showGhc t)           | otherwise = Nothing-+    additionalTextEdits = imp >>= extendImportList (showGhc origName)      stripForall :: T.Text -> T.Text     stripForall t@@ -229,11 +262,37 @@     Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)     Nothing Nothing Nothing Nothing Nothing +extendImportList :: String -> LImportDecl GhcPs -> Maybe [TextEdit]+extendImportList name lDecl = let+    f (Just range) ImportDecl {ideclHiding} = case ideclHiding of+        Just (False, x)+          | Set.notMember name (Set.fromList [show y| y <- unLoc x])+          -> let+            start_pos = _end range+            new_start_pos = start_pos {_character = _character start_pos - 1}+            -- use to same start_pos to handle situation where we do not have latest edits due to caching of Rules+            new_range = Range new_start_pos new_start_pos+            -- we cannot wrap mapM_ inside (mapM_) but we need to wrap (<$)+            alpha = all isAlphaNum $ filter (\c -> c /= '_') name+            result = if alpha then name ++ ", "+                else "(" ++ name ++ "), "+            in Just [TextEdit new_range (T.pack result)]+          | otherwise -> Nothing+        _ -> Nothing  -- hiding import list and no list+    f _ _ = Nothing+    src_span = srcSpanToRange . getLoc $ lDecl+    in f src_span . unLoc $ lDecl++ cacheDataProducer :: HscEnv -> Module -> GlobalRdrEnv -> [LImportDecl GhcPs] -> [ParsedModule] -> IO CachedCompletions cacheDataProducer packageState curMod rdrEnv limports deps = do   let dflags = hsc_dflags packageState       curModName = moduleName curMod +      importMap = Map.fromList [+          (getLoc imp, imp)+          | imp <- limports ]+       iDeclToModName :: ImportDecl name -> ModuleName       iDeclToModName = unLoc . ideclName @@ -259,28 +318,41 @@        getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls)       getComplsForOne (GRE n _ True _) =-        (\x -> ([x],mempty)) <$> toCompItem curMod curModName n+          (, mempty) <$> toCompItem curMod curModName n Nothing       getComplsForOne (GRE n _ False prov) =         flip foldMapM (map is_decl prov) $ \spec -> do-          compItem <- toCompItem curMod (is_mod spec) n+          let originalImportDecl = Map.lookup (is_dloc spec) importMap+          compItem <- toCompItem curMod (is_mod spec) n originalImportDecl           let unqual                 | is_qual spec = []-                | otherwise = [compItem]+                | otherwise = compItem               qual-                | is_qual spec = Map.singleton asMod [compItem]-                | otherwise = Map.fromList [(asMod,[compItem]),(origMod,[compItem])]+                | is_qual spec = Map.singleton asMod compItem+                | otherwise = Map.fromList [(asMod,compItem),(origMod,compItem)]               asMod = showModName (is_as spec)               origMod = showModName (is_mod spec)           return (unqual,QualCompls qual) -      toCompItem :: Module -> ModuleName -> Name -> IO CompItem-      toCompItem m mn n = do+      toCompItem :: Module -> ModuleName -> Name -> Maybe (LImportDecl GhcPs) -> IO [CompItem]+      toCompItem m mn n imp' = do         docs <- getDocumentationTryGhc packageState curMod deps n         ty <- catchSrcErrors (hsc_dflags packageState) "completion" $ do                 name' <- lookupName packageState m n                 return $ name' >>= safeTyThingType-        return $ mkNameCompItem n mn (either (const Nothing) id ty) Nothing docs+        -- use the same pass to also capture any Record snippets that we can collect+        record_ty <- catchSrcErrors (hsc_dflags packageState) "record-completion" $ do+                name' <- lookupName packageState m n+                return $ name' >>= safeTyThingForRecord +        let recordCompls = case either (const Nothing) id record_ty of+                Just (ctxStr, flds) -> case flds of+                    [] -> []+                    _ -> [mkRecordSnippetCompItem ctxStr flds (ppr mn) docs imp']+                Nothing -> []++        return $ [mkNameCompItem n mn (either (const Nothing) id ty) Nothing docs imp'] +++                 recordCompls+   (unquals,quals) <- getCompls rdrElts    return $ CC@@ -290,6 +362,7 @@     , importableModules = moduleNames     } + -- | Produces completions from the top level declarations of a module. localCompletionsForParsedModule :: ParsedModule -> CachedCompletions localCompletionsForParsedModule pm@ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls, hsmodName}} =@@ -323,9 +396,14 @@                 | L _ (TypeSig _ ids typ) <- tcdSigs                 , id <- ids]             TyClD _ x ->-                [mkComp id cl Nothing-                | id <- listify (\(_ :: Located(IdP GhcPs)) -> True) x-                , let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)]+                let generalCompls = [mkComp id cl Nothing+                        | id <- listify (\(_ :: Located(IdP GhcPs)) -> True) x+                        , let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)]+                    -- here we only have to look at the outermost type+                    recordCompls = findRecordCompl pm thisModName x+                in+                   -- the constructors and snippets will be duplicated here giving the user 2 choices.+                   generalCompls ++ recordCompls             ForD _ ForeignImport{fd_name,fd_sig_ty} ->                 [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)]             ForD _ ForeignExport{fd_name,fd_sig_ty} ->@@ -335,13 +413,39 @@         ]      mkComp n ctyp ty =-        CI ctyp pn (Right thisModName) ty pn Nothing doc (ctyp `elem` [CiStruct, CiClass])+        CI ctyp pn (Right thisModName) ty pn Nothing doc (ctyp `elem` [CiStruct, CiClass]) Nothing       where         pn = ppr n         doc = SpanDocText (getDocumentation [pm] n) (SpanDocUris Nothing Nothing)      thisModName = ppr hsmodName +findRecordCompl :: ParsedModule -> T.Text -> TyClDecl GhcPs -> [CompItem]+findRecordCompl pmod mn DataDecl {tcdLName, tcdDataDefn} = result+    where+        result = [mkRecordSnippetCompItem (T.pack . showGhc . unLoc $ con_name) field_labels mn doc Nothing+                 | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn+                 , Just  con_details <- [getFlds con_args]+                 , let field_names = mapMaybe extract con_details+                 , let field_labels = T.pack . showGhc . unLoc <$> field_names+                 , (not . List.null) field_labels+                 ]+        doc = SpanDocText (getDocumentation [pmod] tcdLName) (SpanDocUris Nothing Nothing)++        getFlds :: HsConDetails arg (Located [LConDeclField GhcPs]) -> Maybe [ConDeclField GhcPs]+        getFlds conArg = case conArg of+                             RecCon rec -> Just $ unLoc <$> unLoc rec+                             PrefixCon _ -> Just []+                             _ -> Nothing++        extract ConDeclField{..}+             -- TODO: Why is cd_fld_names a list?+            | Just fld_name <- rdrNameFieldOcc . unLoc <$> listToMaybe cd_fld_names = Just fld_name+            | otherwise = Nothing+        -- XConDeclField+        extract _ = Nothing+findRecordCompl _ _ _ = []+ ppr :: Outputable a => a -> T.Text ppr = T.pack . prettyPrint @@ -353,7 +457,9 @@   | otherwise = x { _insertTextFormat = Just PlainText                   , _insertText       = Nothing                   }-  where supported = Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)+  where+    supported =+      Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)  -- | Returns the cached completions for the given module and position. getCompletions@@ -413,7 +519,7 @@           endLoc = upperRange oldPos           localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc           localBindsToCompItem :: Name -> Maybe Type -> CompItem-          localBindsToCompItem name typ = CI ctyp pn thisModName ty pn Nothing emptySpanDoc (not $ isValOcc occ)+          localBindsToCompItem name typ = CI ctyp pn thisModName ty pn Nothing emptySpanDoc (not $ isValOcc occ) Nothing             where               occ = nameOccName name               ctyp = occNameToComKind Nothing occ@@ -466,7 +572,6 @@           in filtModNameCompls ++ map (toggleSnippets caps withSnippets                                          . mkCompl ideOpts . stripAutoGenerated) uniqueFiltCompls                                ++ filtKeywordCompls-   return result  @@ -600,3 +705,34 @@   , "$c"   , "$m"   ]+++safeTyThingForRecord :: TyThing -> Maybe (T.Text, [T.Text])+safeTyThingForRecord (AnId _) = Nothing+safeTyThingForRecord (AConLike dc) =+    let ctxStr =   T.pack . showGhc . occName . conLikeName $ dc+        field_names = T.pack . unpackFS . flLabel <$> conLikeFieldLabels dc+    in+        Just (ctxStr, field_names)+safeTyThingForRecord _ = Nothing++mkRecordSnippetCompItem :: T.Text -> [T.Text] -> T.Text -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem+mkRecordSnippetCompItem ctxStr compl mn docs imp = r+  where+      r  = CI {+            compKind = CiSnippet+          , insertText = buildSnippet+          , importedFrom = importedFrom+          , typeText = Nothing+          , label = ctxStr+          , isInfix = Nothing+          , docs = docs+          , isTypeCompl = False+          , additionalTextEdits = imp >>= extendImportList (T.unpack ctxStr)+          }++      placeholder_pairs = zip compl ([1..]::[Int])+      snippet_parts = map (\(x, i) -> x <> "=${" <> T.pack (show i) <> ":_" <> x <> "}") placeholder_pairs+      snippet = T.intercalate (T.pack ", ") snippet_parts+      buildSnippet = ctxStr <> " {" <> snippet <> "}"+      importedFrom = Right mn

@@ -8,7 +8,7 @@ import SrcLoc  import Development.IDE.Spans.Common-import Language.Haskell.LSP.Types (CompletionItemKind)+import Language.Haskell.LSP.Types (TextEdit, CompletionItemKind)  -- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs @@ -25,6 +25,7 @@                                    -- in the context of an infix notation.   , docs         :: SpanDoc        -- ^ Available documentation.   , isTypeCompl  :: Bool+  , additionalTextEdits :: Maybe [TextEdit]   }   deriving (Eq, Show) 

@@ -0,0 +1,24 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+module Development.IDE.Types.KnownTargets (KnownTargets, Target(..), toKnownFiles) where++import Data.HashMap.Strict+import Development.IDE.Types.Location+import Development.IDE.GHC.Compat (ModuleName)+import Development.IDE.GHC.Orphans ()+import Data.Hashable+import GHC.Generics+import Control.DeepSeq+import Data.HashSet+import qualified Data.HashSet as HSet+import qualified Data.HashMap.Strict as HMap++-- | A mapping of module name to known files+type KnownTargets = HashMap Target [NormalizedFilePath]++data Target = TargetModule ModuleName | TargetFile NormalizedFilePath+  deriving ( Eq, Generic, Show )+  deriving anyclass (Hashable, NFData)++toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath+toKnownFiles = HSet.fromList . concat . HMap.elems

@@ -15,6 +15,7 @@   , IdeReportProgress(..)   , IdeDefer(..)   , IdeTesting(..)+  , IdeOTMemoryProfiling(..)   , clientSupportsProgress   , IdePkgLocationOptions(..)   , defaultIdeOptions@@ -68,6 +69,9 @@   -- meaning we keep everything in memory but the daml CLI compiler uses this for incremental builds.   , optShakeProfiling :: Maybe FilePath     -- ^ Set to 'Just' to create a directory of profiling reports.+  , optOTMemoryProfiling :: IdeOTMemoryProfiling+    -- ^ Whether to record profiling information with OpenTelemetry. You must+    --   also enable the -l RTS flag for this to have any effect   , optTesting :: IdeTesting     -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants   , optReportProgress :: IdeReportProgress@@ -95,7 +99,7 @@     --   that the parsed module contains the result of Opt_KeepRawTokenStream,     --   which might be necessary for hlint.   , optCustomDynFlags :: DynFlags -> DynFlags-    -- ^ If given, it will be called right after setting up a new cradle,+    -- ^ Will be called right after setting up a new cradle,     --   allowing to customize the Ghc options used   } @@ -134,9 +138,10 @@     -- ^ New parse tree emitted by the preprocessor.   } -newtype IdeReportProgress = IdeReportProgress Bool-newtype IdeDefer          = IdeDefer          Bool-newtype IdeTesting        = IdeTesting        Bool+newtype IdeReportProgress    = IdeReportProgress Bool+newtype IdeDefer             = IdeDefer          Bool+newtype IdeTesting           = IdeTesting        Bool+newtype IdeOTMemoryProfiling = IdeOTMemoryProfiling    Bool  clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress clientSupportsProgress caps = IdeReportProgress $ Just True ==@@ -151,6 +156,7 @@     ,optThreads = 0     ,optShakeFiles = Nothing     ,optShakeProfiling = Nothing+    ,optOTMemoryProfiling = IdeOTMemoryProfiling False     ,optReportProgress = IdeReportProgress False     ,optLanguageSyntax = "haskell"     ,optNewColonConvention = False

@@ -0,0 +1,41 @@+{-# LANGUAGE ExistentialQuantification #-}+module Development.IDE.Types.Shake (Value(..), Values, Key(..), currentValue) where++import Control.DeepSeq+import Data.Dynamic+import Data.Hashable+import Data.HashMap.Strict+import Data.Typeable+import GHC.Generics+import Language.Haskell.LSP.Types++data Value v+    = Succeeded TextDocumentVersion v+    | Stale TextDocumentVersion v+    | Failed+    deriving (Functor, Generic, Show)++instance NFData v => NFData (Value v)++-- | Convert a Value to a Maybe. This will only return `Just` for+-- up2date results not for stale values.+currentValue :: Value v -> Maybe v+currentValue (Succeeded _ v) = Just v+currentValue (Stale _ _) = Nothing+currentValue Failed = Nothing++-- | The state of the all values.+type Values = HashMap (NormalizedFilePath, Key) (Value Dynamic)++-- | Key type+data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k++instance Show Key where+  show (Key k) = show k++instance Eq Key where+    Key k1 == Key k2 | Just k2' <- cast k2 = k1 == k2'+                     | otherwise = False++instance Hashable Key where+    hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key)

@@ -11,7 +11,7 @@ module Main (main) where  import Control.Applicative.Combinators-import Control.Exception (bracket, catch)+import Control.Exception (catch) import qualified Control.Lens as Lens import Control.Monad import Control.Monad.IO.Class (liftIO)@@ -41,7 +41,7 @@ import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message) import Language.Haskell.LSP.VFS (applyChange) import Network.URI-import System.Environment.Blank (getEnv, setEnv, unsetEnv)+import System.Environment.Blank (getEnv, setEnv) import System.FilePath import System.IO.Extra hiding (withTempDir) import qualified System.IO.Extra@@ -57,7 +57,7 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck import System.Time.Extra-import Development.IDE.Plugin.CodeAction (typeSignatureCommandId, blockCommandId)+import Development.IDE.Plugin.CodeAction (typeSignatureCommandId, blockCommandId, matchRegExMultipleImports) import Development.IDE.Plugin.Test (TestRequest(BlockSeconds,GetInterfaceFilesDir))  main :: IO ()@@ -97,6 +97,7 @@     , rootUriTests     , asyncTests     , clientSettingsTest+    , codeActionHelperFunctionTests     ]  initializeResponseTests :: TestTree@@ -286,7 +287,8 @@       _ <- createDoc "ModuleA.hs" "haskell" contentA       expectDiagnostics [("ModuleB.hs", [])]   , ignoreInWindowsBecause "Broken in windows" $ testSessionWait "add missing module (non workspace)" $ do-      tmpDir <- liftIO getTemporaryDirectory+      -- need to canonicalize in Mac Os+      tmpDir <- liftIO $ canonicalizePath =<< getTemporaryDirectory       let contentB = T.unlines             [ "module ModuleB where"             , "import ModuleA ()"@@ -330,22 +332,15 @@       _ <- createDoc "ModuleA.hs" "haskell" contentA       _ <- createDoc "ModuleB.hs" "haskell" contentB       _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot-      expectDiagnosticsWithTags-        [ ( "ModuleA.hs"-          , [(DsInfo, (1, 0), "The import of 'ModuleB'", Just DtUnnecessary)]-          )-        , ( "ModuleB.hs"-          , [(DsInfo, (1, 0), "The import of 'ModuleA'", Just DtUnnecessary)]-          )-        ]+      expectDiagnostics []   , testSessionWait "correct reference used with hs-boot" $ do       let contentB = T.unlines             [ "module ModuleB where"-            , "import {-# SOURCE #-} ModuleA"+            , "import {-# SOURCE #-} ModuleA()"             ]       let contentA = T.unlines             [ "module ModuleA where"-            , "import ModuleB"+            , "import ModuleB()"             , "x = 5"             ]       let contentAboot = T.unlines@@ -386,11 +381,7 @@             ]       _ <- createDoc "ModuleA.hs" "haskell" contentA       _ <- createDoc "ModuleB.hs" "haskell" contentB-      expectDiagnosticsWithTags-        [ ( "ModuleB.hs"-          , [(DsInfo, (2, 0), "The import of 'ModuleA' is redundant", Just DtUnnecessary)]-          )-        ]+      expectDiagnostics []   , testSessionWait "package imports" $ do       let thisDataListContent = T.unlines             [ "module Data.List where"@@ -528,7 +519,7 @@             ]           )         ]-  , testCase "typecheck-all-parents-of-interest" $ withoutStackEnv $ runWithExtraFiles "recomp" $ \dir -> do+  , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do     let bPath = dir </> "B.hs"         pPath = dir </> "P.hs" @@ -537,11 +528,8 @@      bdoc <- createDoc bPath "haskell" bSource     _pdoc <- createDoc pPath "haskell" pSource-    expectDiagnosticsWithTags-      [("P.hs", [(DsWarning,(4,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded-      ,("P.hs", [(DsInfo,(2,0), "The import of", Just DtUnnecessary)])-      ,("P.hs", [(DsInfo,(4,0), "Defined but not used", Just DtUnnecessary)])-      ]+    expectDiagnostics+      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded      -- Change y from Int to B which introduces a type error in A (imported from P)     changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $@@ -573,6 +561,13 @@   , exportUnusedTests   ] +codeActionHelperFunctionTests :: TestTree+codeActionHelperFunctionTests = testGroup "code action helpers"+    [+    extendImportTestsRegEx+    ]++ codeLensesTests :: TestTree codeLensesTests = testGroup "code lenses"   [ addSigLensesTests@@ -967,139 +962,207 @@ extendImportTests :: TestTree extendImportTests = testGroup "extend import actions"   [ testSession "extend single line import with value" $ template-      (T.unlines+      [("ModuleA.hs", T.unlines             [ "module ModuleA where"             , "stuffA :: Double"             , "stuffA = 0.00750"             , "stuffB :: Integer"             , "stuffB = 123"-            ])-      (T.unlines+            ])]+      ("ModuleB.hs", T.unlines             [ "module ModuleB where"             , "import ModuleA as A (stuffB)"             , "main = print (stuffA, stuffB)"             ])       (Range (Position 3 17) (Position 3 18))-      "Add stuffA to the import list of ModuleA"+      ["Add stuffA to the import list of ModuleA"]       (T.unlines             [ "module ModuleB where"             , "import ModuleA as A (stuffA, stuffB)"             , "main = print (stuffA, stuffB)"             ])   , testSession "extend single line import with operator" $ template-      (T.unlines+      [("ModuleA.hs", T.unlines             [ "module ModuleA where"             , "(.*) :: Integer -> Integer -> Integer"             , "x .* y = x * y"             , "stuffB :: Integer"             , "stuffB = 123"-            ])-      (T.unlines+            ])]+      ("ModuleB.hs", T.unlines             [ "module ModuleB where"             , "import ModuleA as A (stuffB)"             , "main = print (stuffB .* stuffB)"             ])       (Range (Position 3 17) (Position 3 18))-      "Add .* to the import list of ModuleA"+      ["Add (.*) to the import list of ModuleA"]       (T.unlines             [ "module ModuleB where"             , "import ModuleA as A ((.*), stuffB)"             , "main = print (stuffB .* stuffB)"             ])   , testSession "extend single line import with type" $ template-      (T.unlines+      [("ModuleA.hs", T.unlines             [ "module ModuleA where"             , "type A = Double"-            ])-      (T.unlines+            ])]+      ("ModuleB.hs", T.unlines             [ "module ModuleB where"             , "import ModuleA ()"             , "b :: A"             , "b = 0"             ])       (Range (Position 2 5) (Position 2 5))-      "Add A to the import list of ModuleA"+      ["Add A to the import list of ModuleA"]       (T.unlines             [ "module ModuleB where"             , "import ModuleA (A)"             , "b :: A"             , "b = 0"             ])-  ,  (`xfail` "known broken") $ testSession "extend single line import with constructor" $ template-      (T.unlines+  , testSession "extend single line import with constructor" $ template+      [("ModuleA.hs", T.unlines             [ "module ModuleA where"             , "data A = Constructor"-            ])-      (T.unlines+            ])]+      ("ModuleB.hs", T.unlines             [ "module ModuleB where"             , "import ModuleA (A)"             , "b :: A"             , "b = Constructor"             ])       (Range (Position 2 5) (Position 2 5))-      "Add Constructor to the import list of ModuleA"+      ["Add A(Constructor) to the import list of ModuleA"]       (T.unlines             [ "module ModuleB where"             , "import ModuleA (A(Constructor))"             , "b :: A"             , "b = Constructor"+            ])  +  , testSession "extend single line import with mixed constructors" $ template+      [("ModuleA.hs", T.unlines+            [ "module ModuleA where"+            , "data A = ConstructorFoo | ConstructorBar"+            , "a = 1"+            ])]+      ("ModuleB.hs", T.unlines+            [ "module ModuleB where"+            , "import ModuleA (A(ConstructorBar), a)"+            , "b :: A"+            , "b = ConstructorFoo"             ])-  , testSession "extend single line qualified import with value" $ template+      (Range (Position 2 5) (Position 2 5))+      ["Add A(ConstructorFoo) to the import list of ModuleA"]       (T.unlines+            [ "module ModuleB where"+            , "import ModuleA (A(ConstructorFoo, ConstructorBar), a)"+            , "b :: A"+            , "b = ConstructorFoo"+            ])+  , testSession "extend single line qualified import with value" $ template+      [("ModuleA.hs", T.unlines             [ "module ModuleA where"             , "stuffA :: Double"             , "stuffA = 0.00750"             , "stuffB :: Integer"             , "stuffB = 123"-            ])-      (T.unlines+            ])]+      ("ModuleB.hs", T.unlines             [ "module ModuleB where"             , "import qualified ModuleA as A (stuffB)"             , "main = print (A.stuffA, A.stuffB)"             ])       (Range (Position 3 17) (Position 3 18))-      "Add stuffA to the import list of ModuleA"+      ["Add stuffA to the import list of ModuleA"]       (T.unlines             [ "module ModuleB where"             , "import qualified ModuleA as A (stuffA, stuffB)"             , "main = print (A.stuffA, A.stuffB)"             ])   , testSession "extend multi line import with value" $ template-      (T.unlines+      [("ModuleA.hs", T.unlines             [ "module ModuleA where"             , "stuffA :: Double"             , "stuffA = 0.00750"             , "stuffB :: Integer"             , "stuffB = 123"-            ])-      (T.unlines+            ])]+      ("ModuleB.hs", T.unlines             [ "module ModuleB where"             , "import ModuleA (stuffB"             , "               )"             , "main = print (stuffA, stuffB)"             ])       (Range (Position 3 17) (Position 3 18))-      "Add stuffA to the import list of ModuleA"+      ["Add stuffA to the import list of ModuleA"]       (T.unlines             [ "module ModuleB where"             , "import ModuleA (stuffA, stuffB"             , "               )"             , "main = print (stuffA, stuffB)"             ])+  , testSession "extend import list with multiple choices" $ template+      [("ModuleA.hs", T.unlines+            --  this is just a dummy module to help the arguments needed for this test+            [  "module ModuleA (bar) where"+             , "bar = 10"+               ]),+      ("ModuleB.hs", T.unlines+            --  this is just a dummy module to help the arguments needed for this test+            [  "module ModuleB (bar) where"+             , "bar = 10"+               ])]+      ("ModuleC.hs", T.unlines+            [ "module ModuleC where"+            , "import ModuleB ()"+            , "import ModuleA ()"+            , "foo = bar"+            ])+      (Range (Position 3 17) (Position 3 18))+      ["Add bar to the import list of ModuleA",+       "Add bar to the import list of ModuleB"]+      (T.unlines+            [ "module ModuleC where"+            , "import ModuleB ()"+            , "import ModuleA (bar)"+            , "foo = bar"+            ])   ]   where-    template contentA contentB range expectedAction expectedContentB = do-      _docA <- createDoc "ModuleA.hs" "haskell" contentA-      docB <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- waitForDiagnostics-      CACodeAction action@CodeAction { _title = actionTitle } : _-                  <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>-                     getCodeActions docB range-      liftIO $ expectedAction @=? actionTitle+    template setUpModules moduleUnderTest range expectedActions expectedContentB = do+      mapM_ (\x -> createDoc (fst x) "haskell" (snd x)) setUpModules+      docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest)+      _  <- waitForDiagnostics+      void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)+      codeActions <- filter (\(CACodeAction CodeAction{_title=x}) -> T.isPrefixOf "Add" x)+          <$>  getCodeActions docB range+      let expectedTitles = (\(CACodeAction CodeAction{_title=x}) ->x) <$> codeActions+      liftIO $ expectedActions @=? expectedTitles++      -- Get the first action and execute the first action+      let CACodeAction action :  _+                  = sortOn (\(CACodeAction CodeAction{_title=x}) -> x) codeActions       executeCodeAction action       contentAfterAction <- documentContents docB       liftIO $ expectedContentB @=? contentAfterAction +extendImportTestsRegEx :: TestTree+extendImportTestsRegEx = testGroup "regex parsing"+    [+      testCase "parse invalid multiple imports" $ template "foo bar foo" Nothing+    , testCase "parse malformed import list" $ template+                  "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n    \8216Data.Map\8217)"+                  Nothing+    , testCase "parse multiple imports" $ template+                 "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n    \8216Data.Map\8217 (app/testlsp.hs:7:1-18)\n    \8216Data.HashMap.Strict\8217 (app/testlsp.hs:8:1-29)"+                 $ Just ("fromList",[("Data.Map","app/testlsp.hs:7:1-18"),("Data.HashMap.Strict","app/testlsp.hs:8:1-29")])+    ]+    where+        template message expected = do+            liftIO $ matchRegExMultipleImports message @=? expected+++ suggestImportTests :: TestTree suggestImportTests = testGroup "suggest import actions"   [ testGroup "Dont want suggestion"@@ -1636,6 +1699,19 @@   , check "replace _ with foo _"           "_" "n" "n"           "(foo _)" "n" "n"+  , testSession "replace _toException with E.toException" $ do+      let mkDoc x = T.unlines+            [ "module Testing where"+            , "import qualified Control.Exception as E"+            , "ioToSome :: E.IOException -> E.SomeException"+            , "ioToSome = " <> x ]+      doc <- createDoc "Test.hs" "haskell" $ mkDoc "_toException"+      _ <- waitForDiagnostics+      actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBound))+      chosen <- liftIO $ pickActionWithTitle "replace _toException with E.toException" actions+      executeCodeAction chosen+      modifiedCode <- documentContents doc+      liftIO $ mkDoc "E.toException" @=? modifiedCode   ]  addInstanceConstraintTests :: TestTree@@ -2074,6 +2150,84 @@               [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"               , "module A (f) where"               , "a `f` b = ()"])+   , testSession "function operator" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A () where"+              , "(<|) = ($)"])+        (R 2 0 2 9)+        "Export ‘<|’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A ((<|)) where"+              , "(<|) = ($)"])+    , testSession "type synonym operator" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A () where"+              , "type (:<) = ()"])+        (R 3 0 3 13)+        "Export ‘:<’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A ((:<)) where"+              , "type (:<) = ()"])+    , testSession "type family operator" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeFamilies #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A () where"+              , "type family (:<)"])+        (R 4 0 4 15)+        "Export ‘:<’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeFamilies #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A (type (:<)(..)) where"+              , "type family (:<)"])+    , testSession "typeclass operator" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A () where"+              , "class (:<) a"])+        (R 3 0 3 11)+        "Export ‘:<’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A (type (:<)(..)) where"+              , "class (:<) a"])+    , testSession "newtype operator" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A () where"+              , "newtype (:<) = Foo ()"])+        (R 3 0 3 20)+        "Export ‘:<’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A (type (:<)(..)) where"+              , "newtype (:<) = Foo ()"])+    , testSession "data type operator" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A () where"+              , "data (:<) = Foo ()"])+        (R 3 0 3 17)+        "Export ‘:<’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A (type (:<)(..)) where"+              , "data (:<) = Foo ()"])     ]   ]     where@@ -2094,7 +2248,7 @@ addSigLensesTests = let   missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}"   notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"-  moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"+  moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where\nimport qualified Data.Complex as C"   other = T.unlines ["f :: Integer -> Integer", "f x = 3"]   before  withMissing def     = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]@@ -2119,6 +2273,7 @@       , sigSession enableWarnings "a >>>> b = a + b"        "(>>>>) :: Num a => a -> a -> a"       , sigSession enableWarnings "a `haha` b = a b"        "haha :: (t1 -> t2) -> t1 -> t2"       , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a"+      , sigSession enableWarnings "qualifiedSigTest= C.realPart" "qualifiedSigTest :: C.Complex a -> a"       ]       | (title, enableWarnings) <-         [("with warnings enabled", True)@@ -2270,7 +2425,7 @@   outL45 = Position 49  3  ;  outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]   innL48 = Position 52  5  ;  innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]   holeL60 = Position 59 7  ;  hleInfo = [ExpectHoverText ["_ ::"]]-  cccL17 = Position 17 11  ;  docLink = [ExpectHoverText ["[Documentation](file:///"]]+  cccL17 = Position 17 16  ;  docLink = [ExpectHoverText ["[Documentation](file:///"]]   imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3]   reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 0 3 14]   in@@ -2316,7 +2471,7 @@   , test  broken broken outL45     outSig        "top-level signature             #310"   , test  broken broken innL48     innSig        "inner     signature             #310"   , test  no     yes    holeL60    hleInfo       "hole without internal name      #847"-  , test  no     yes    cccL17     docLink       "Haddock html links"+  , test  no     skip   cccL17     docLink       "Haddock html links"   , testM yes    yes    imported   importedSig   "Imported symbol"   , testM yes    yes    reexported reexportedSig "Imported symbol (reexported)"   ]@@ -2324,6 +2479,7 @@         yes    = Just -- test should run and pass         broken = Just . (`xfail` "known broken")         no = const Nothing -- don't run this test at all+        skip = const Nothing -- unreliable, don't run  checkFileCompiles :: FilePath -> Session () -> TestTree checkFileCompiles fp diag =@@ -2333,40 +2489,25 @@  pluginSimpleTests :: TestTree pluginSimpleTests =-  ignoreInWindowsForGHC88And810 $ testSessionWait "simple plugin" $ do-    let content =-          T.unlines-            [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"-            , "{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-}"-            , "module Testing where"-            , "import Data.Proxy"-            , "import GHC.TypeLits"-            -- This function fails without plugins being initialized.-            , "f :: forall n. KnownNat n => Proxy n -> Integer"-            , "f _ = natVal (Proxy :: Proxy n) + natVal (Proxy :: Proxy (n+2))"-            , "foo :: Int -> Int -> Int"-            , "foo a _b = a + c"-            ]-    _ <- createDoc "Testing.hs" "haskell" content+  ignoreTest8101 "GHC #18070" $+  ignoreInWindowsForGHC88And810 $+  testSessionWithExtraFiles "plugin" "simple plugin" $ \dir -> do+    _ <- openDoc (dir </> "KnownNat.hs") "haskell"+    liftIO $ writeFile (dir</>"hie.yaml")+      "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}"+     expectDiagnostics-      [ ( "Testing.hs",-          [(DsError, (8, 15), "Variable not in scope: c")]+      [ ( "KnownNat.hs",+          [(DsError, (9, 15), "Variable not in scope: c")]           )       ]  pluginParsedResultTests :: TestTree pluginParsedResultTests =-  ignoreInWindowsForGHC88And810 $ testSessionWait "parsedResultAction plugin" $ do-    let content =-          T.unlines-            [ "{-# LANGUAGE DuplicateRecordFields, TypeApplications, FlexibleContexts, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}"-            , "{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}"-            , "module Testing (Company(..), display) where"-            , "data Company = Company {name :: String}"-            , "display :: Company -> String"-            , "display c = c.name"-            ]-    _ <- createDoc "Testing.hs" "haskell" content+  ignoreTest8101 "GHC #18070" $+  ignoreInWindowsForGHC88And810 $+  testSessionWithExtraFiles "plugin" "parsedResultAction plugin" $ \dir -> do+    _ <- openDoc (dir</> "RecordDot.hs") "haskell"     expectNoMoreDiagnostics 2  cppTests :: TestTree@@ -2526,7 +2667,7 @@         _ <- createDoc "A.hs" "haskell" sourceA         _ <- createDoc "B.hs" "haskell" sourceB         expectDiagnostics [ ( "B.hs", [(DsWarning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ]-    , ignoreInWindowsForGHC88 $ testCase "findsTHnewNameConstructor" $ withoutStackEnv $ runWithExtraFiles "THNewName" $ \dir -> do+    , ignoreInWindowsForGHC88 $ testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do      -- This test defines a TH value with the meaning "data A = A" in A.hs     -- Loads and export the template in B.hs@@ -2541,7 +2682,7 @@  -- | test that TH is reevaluated on typecheck thReloadingTest :: TestTree-thReloadingTest = testCase "reloading-th-test" $ withoutStackEnv $ runWithExtraFiles "TH" $ \dir -> do+thReloadingTest = testCase "reloading-th-test" $ runWithExtraFiles "TH" $ \dir -> do      let aPath = dir </> "THA.hs"         bPath = dir </> "THB.hs"@@ -2575,7 +2716,7 @@     closeDoc cdoc  thLinkingTest :: TestTree-thLinkingTest = testCase "th-linking-test" $ withoutStackEnv $ runWithExtraFiles "TH" $ \dir -> do+thLinkingTest = testCase "th-linking-test" $ runWithExtraFiles "TH" $ \dir -> do      let aPath = dir </> "THA.hs"         bPath = dir </> "THB.hs"@@ -2610,15 +2751,16 @@     , testGroup "other" otherCompletionTests     ] -completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, Bool, Bool)] -> TestTree+completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe (List TextEdit))] -> TestTree completionTest name src pos expected = testSessionWait name $ do     docId <- createDoc "A.hs" "haskell" (T.unlines src)     _ <- waitForDiagnostics     compls <- getCompletions docId pos-    let compls' = [ (_label, _kind) | CompletionItem{..} <- compls]+    let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls]     liftIO $ do-        compls' @?= [ (l, Just k) | (l,k,_,_) <- expected]-        forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,expectedSig, expectedDocs)) -> do+        let emptyToMaybe x = if T.null x then Nothing else Just x+        compls' @?= [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected]+        forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs, _)) -> do             when expectedSig $                 assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail)             when expectedDocs $@@ -2630,42 +2772,43 @@         "variable"         ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]         (Position 0 8)-        [("xxx", CiFunction, True, True),-         ("XxxCon", CiConstructor, False, True)+        [("xxx", CiFunction, "xxx", True, True, Nothing),+         ("XxxCon", CiConstructor, "XxxCon", False, True, Nothing)         ],     completionTest         "constructor"         ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]         (Position 0 8)-        [("xxx", CiFunction, True, True),-         ("XxxCon", CiConstructor, False, True)+        [("xxx", CiFunction, "xxx", True, True, Nothing),+         ("XxxCon", CiConstructor, "XxxCon", False, True, Nothing)         ],     completionTest         "class method"         ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"]         (Position 0 8)-        [("xxx", CiFunction, True, True)],+        [("xxx", CiFunction, "xxx", True, True, Nothing)],     completionTest         "type"         ["bar :: Xx", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]         (Position 0 9)-        [("Xxx", CiStruct, False, True)],+        [("Xxx", CiStruct, "Xxx", False, True, Nothing)],     completionTest         "class"         ["bar :: Xx", "xxx = ()", "-- | haddock", "class Xxx a"]         (Position 0 9)-        [("Xxx", CiClass, False, True)],+        [("Xxx", CiClass, "Xxx", False, True, Nothing)],     completionTest         "records"         ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ]         (Position 1 19)-        [("_personName", CiFunction, False, True),-         ("_personAge", CiFunction, False, True)],+        [("_personName", CiFunction, "_personName", False, True, Nothing),+         ("_personAge", CiFunction, "_personAge", False, True, Nothing)],     completionTest         "recordsConstructor"         ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ]         (Position 1 19)-        [("XyRecord", CiConstructor, False, True)]+        [("XyRecord", CiConstructor, "XyRecord", False, True, Nothing),+         ("XyRecord", CiSnippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)]     ]  localCompletionTests :: [TestTree]@@ -2674,8 +2817,8 @@         "argument"         ["bar (Just abcdef) abcdefg = abcd"]         (Position 0 32)-        [("abcdef", CiFunction, True, False),-         ("abcdefg", CiFunction , True, False)+        [("abcdef", CiFunction, "abcdef", True, False, Nothing),+         ("abcdefg", CiFunction , "abcdefg", True, False, Nothing)         ],     completionTest         "let"@@ -2684,8 +2827,8 @@         ,"        in abcd"         ]         (Position 2 15)-        [("abcdef", CiFunction, True, False),-         ("abcdefg", CiFunction , True, False)+        [("abcdef", CiFunction, "abcdef", True, False, Nothing),+         ("abcdefg", CiFunction , "abcdefg", True, False, Nothing)         ],     completionTest         "where"@@ -2694,8 +2837,8 @@         ,"        abcdefg = let abcd = undefined in undefined"         ]         (Position 0 10)-        [("abcdef", CiFunction, True, False),-         ("abcdefg", CiFunction , True, False)+        [("abcdef", CiFunction, "abcdef", True, False, Nothing),+         ("abcdefg", CiFunction , "abcdefg", True, False, Nothing)         ],     completionTest         "do/1"@@ -2706,7 +2849,7 @@         ,"  pure ()"         ]         (Position 2 6)-        [("abcdef", CiFunction, True, False)+        [("abcdef", CiFunction, "abcdef", True, False, Nothing)         ],     completionTest         "do/2"@@ -2720,12 +2863,12 @@         ,"    abcdefghij = undefined"         ]         (Position 5 8)-        [("abcde", CiFunction, True, False)-        ,("abcdefghij", CiFunction, True, False)-        ,("abcdef", CiFunction, True, False)-        ,("abcdefg", CiFunction, True, False)-        ,("abcdefgh", CiFunction, True, False)-        ,("abcdefghi", CiFunction, True, False)+        [("abcde", CiFunction, "abcde", True, False, Nothing)+        ,("abcdefghij", CiFunction, "abcdefghij", True, False, Nothing)+        ,("abcdef", CiFunction, "abcdef", True, False, Nothing)+        ,("abcdefg", CiFunction, "abcdefg", True, False, Nothing)+        ,("abcdefgh", CiFunction, "abcdefgh", True, False, Nothing)+        ,("abcdefghi", CiFunction, "abcdefghi", True, False, Nothing)         ]     ] @@ -2735,32 +2878,80 @@       "variable"       ["module A where", "f = hea"]       (Position 1 7)-      [("head", CiFunction, True, True)],+      [("head", CiFunction, "head ${1:[a]}", True, True, Nothing)],     completionTest       "constructor"       ["module A where", "f = Tru"]       (Position 1 7)-      [ ("True", CiConstructor, True, True),-        ("truncate", CiFunction, True, True)+      [ ("True", CiConstructor, "True ", True, True, Nothing),+        ("truncate", CiFunction, "truncate ${1:a}", True, True, Nothing)       ],     completionTest       "type"       ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]       (Position 2 7)-      [ ("Bounded", CiClass, True, True),-        ("Bool", CiStruct, True, True)+      [ ("Bounded", CiClass, "Bounded ${1:*}", True, True, Nothing),+        ("Bool", CiStruct, "Bool ", True, True, Nothing)       ],     completionTest       "qualified"       ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]       (Position 2 15)-      [ ("head", CiFunction, True, True)+      [ ("head", CiFunction, "head ${1:[a]}", True, True, Nothing)       ],     completionTest       "duplicate import"       ["module A where", "import Data.List", "import Data.List", "f = perm"]       (Position 3 8)-      [ ("permutations", CiFunction, False, False)+      [ ("permutations", CiFunction, "permutations ${1:[a]}", False, False, Nothing)+      ],+    completionTest+      "show imports not in list - simple"+      ["{-# LANGUAGE NoImplicitPrelude #-}",+       "module A where", "import Control.Monad (msum)", "f = joi"]+      (Position 3 6)+      [("join", CiFunction, "join ${1:m (m a)}", False, False,+        Just (List [TextEdit {_range = Range {_start = Position {_line = 2, _character = 26}, _end = Position {_line = 2, _character = 26}}, _newText = "join, "}]))],+    completionTest+      "show imports not in list - multi-line"+      ["{-# LANGUAGE NoImplicitPrelude #-}",+       "module A where", "import Control.Monad (\n    msum)", "f = joi"]+      (Position 4 6)+      [("join", CiFunction, "join ${1:m (m a)}", False, False,+        Just (List [TextEdit {_range = Range {_start = Position {_line = 3, _character = 8}, _end = Position {_line = 3, _character = 8}}, _newText = "join, "}]))],+    completionTest+      "show imports not in list - names with _"+      ["{-# LANGUAGE NoImplicitPrelude #-}",+       "module A where", "import qualified Control.Monad as M (msum)", "f = M.mapM_"]+      (Position 3 11)+      [("mapM_", CiFunction, "mapM_ ${1:a -> m b} ${2:t a}", False, False,+        Just (List [TextEdit {_range = Range {_start = Position {_line = 2, _character = 41}, _end = Position {_line = 2, _character = 41}}, _newText = "mapM_, "}]))],+    completionTest+      "show imports not in list - initial empty list"+      ["{-# LANGUAGE NoImplicitPrelude #-}",+       "module A where", "import qualified Control.Monad as M ()", "f = M.joi"]+      (Position 3 10)+      [("join", CiFunction, "join ${1:m (m a)}", False, False,+        Just (List [TextEdit {_range = Range {_start = Position {_line = 2, _character = 37}, _end = Position {_line = 2, _character = 37}}, _newText = "join, "}]))],+    completionTest+       "dont show hidden items"+       [ "{-# LANGUAGE NoImplicitPrelude #-}",+         "module A where",+         "import Control.Monad hiding (join)",+         "f = joi"+       ]+       (Position 3 6)+       [],+    completionTest+      "record snippet on import"+      ["module A where", "import Text.Printf (FormatParse(FormatParse))", "FormatParse"]+      (Position 2 10)+      [("FormatParse", CiStruct, "FormatParse ", False, False,+       Just (List [TextEdit {_range = Range {_start = Position {_line = 1, _character = 44}, _end = Position {_line = 1, _character = 44}}, _newText = "FormatParse, "}])),+       ("FormatParse", CiConstructor, "FormatParse ${1:String} ${2:Char} ${3:String}", False, False,+       Just (List [TextEdit {_range = Range {_start = Position {_line = 1, _character = 44}, _end = Position {_line = 1, _character = 44}}, _newText = "FormatParse, "}])),+       ("FormatParse", CiSnippet, "FormatParse {fpModifiers=${1:_fpModifiers}, fpChar=${2:_fpChar}, fpRest=${3:_fpRest}}", False, False,+       Just (List [TextEdit {_range = Range {_start = Position {_line = 1, _character = 44}, _end = Position {_line = 1, _character = 44}}, _newText = "FormatParse, "}]))       ]   ] @@ -2770,7 +2961,7 @@       "keyword"       ["module A where", "f = newty"]       (Position 1 9)-      [("newtype", CiKeyword, False, False)],+      [("newtype", CiKeyword, "", False, False, Nothing)],     completionTest       "type context"       [ "{-# OPTIONS_GHC -Wunused-binds #-}",@@ -2782,7 +2973,7 @@       -- This should be sufficient to detect that we are in a       -- type context and only show the completion to the type.       (Position 3 11)-      [("Integer", CiStruct, True, True)]+      [("Integer", CiStruct, "Integer ", True, True, Nothing)]   ]  highlightTests :: TestTree@@ -2790,57 +2981,58 @@   [ testSessionWait "value" $ do     doc <- createDoc "A.hs" "haskell" source     _ <- waitForDiagnostics-    highlights <- getHighlights doc (Position 2 2)+    highlights <- getHighlights doc (Position 3 2)     liftIO $ highlights @?=-            [ DocumentHighlight (R 1 0 1 3) (Just HkRead)-            , DocumentHighlight (R 2 0 2 3) (Just HkWrite)-            , DocumentHighlight (R 3 6 3 9) (Just HkRead)-            , DocumentHighlight (R 4 22 4 25) (Just HkRead)+            [ DocumentHighlight (R 2 0 2 3) (Just HkRead)+            , DocumentHighlight (R 3 0 3 3) (Just HkWrite)+            , DocumentHighlight (R 4 6 4 9) (Just HkRead)+            , DocumentHighlight (R 5 22 5 25) (Just HkRead)             ]   , testSessionWait "type" $ do     doc <- createDoc "A.hs" "haskell" source     _ <- waitForDiagnostics-    highlights <- getHighlights doc (Position 1 8)+    highlights <- getHighlights doc (Position 2 8)     liftIO $ highlights @?=-            [ DocumentHighlight (R 1 7 1 10) (Just HkRead)-            , DocumentHighlight (R 2 11 2 14) (Just HkRead)+            [ DocumentHighlight (R 2 7 2 10) (Just HkRead)+            , DocumentHighlight (R 3 11 3 14) (Just HkRead)             ]   , testSessionWait "local" $ do     doc <- createDoc "A.hs" "haskell" source     _ <- waitForDiagnostics-    highlights <- getHighlights doc (Position 5 5)+    highlights <- getHighlights doc (Position 6 5)     liftIO $ highlights @?=-            [ DocumentHighlight (R 5 4 5 7) (Just HkWrite)-            , DocumentHighlight (R 5 10 5 13) (Just HkRead)-            , DocumentHighlight (R 6 12 6 15) (Just HkRead)+            [ DocumentHighlight (R 6 4 6 7) (Just HkWrite)+            , DocumentHighlight (R 6 10 6 13) (Just HkRead)+            , DocumentHighlight (R 7 12 7 15) (Just HkRead)             ]   , testSessionWait "record" $ do     doc <- createDoc "A.hs" "haskell" recsource     _ <- waitForDiagnostics-    highlights <- getHighlights doc (Position 3 15)+    highlights <- getHighlights doc (Position 4 15)     liftIO $ highlights @?=       -- Span is just the .. on 8.10, but Rec{..} before #if MIN_GHC_API_VERSION(8,10,0)-            [ DocumentHighlight (R 3 8 3 10) (Just HkWrite)+            [ DocumentHighlight (R 4 8 4 10) (Just HkWrite) #else-            [ DocumentHighlight (R 3 4 3 11) (Just HkWrite)+            [ DocumentHighlight (R 4 4 4 11) (Just HkWrite) #endif-            , DocumentHighlight (R 3 14 3 20) (Just HkRead)+            , DocumentHighlight (R 4 14 4 20) (Just HkRead)             ]-    highlights <- getHighlights doc (Position 2 17)+    highlights <- getHighlights doc (Position 3 17)     liftIO $ highlights @?=-            [ DocumentHighlight (R 2 17 2 23) (Just HkWrite)+            [ DocumentHighlight (R 3 17 3 23) (Just HkWrite)       -- Span is just the .. on 8.10, but Rec{..} before #if MIN_GHC_API_VERSION(8,10,0)-            , DocumentHighlight (R 3 8 3 10) (Just HkRead)+            , DocumentHighlight (R 4 8 4 10) (Just HkRead) #else-            , DocumentHighlight (R 3 4 3 11) (Just HkRead)+            , DocumentHighlight (R 4 4 4 11) (Just HkRead) #endif             ]   ]   where     source = T.unlines-      ["module Highlight where"+      ["{-# OPTIONS_GHC -Wunused-binds #-}"+      ,"module Highlight () where"       ,"foo :: Int"       ,"foo = 3 :: Int"       ,"bar = foo"@@ -2850,7 +3042,8 @@       ]     recsource = T.unlines       ["{-# LANGUAGE RecordWildCards #-}"-      ,"module Highlight where"+      ,"{-# OPTIONS_GHC -Wunused-binds #-}"+      ,"module Highlight () where"       ,"data Rec = Rec { field1 :: Int, field2 :: Char }"       ,"foo Rec{..} = field2 + field1"       ]@@ -3036,12 +3229,10 @@ xfail :: TestTree -> String -> TestTree xfail = flip expectFailBecause -expectFailCabal :: String -> TestTree -> TestTree-#ifdef STACK-expectFailCabal _ = id-#else-expectFailCabal = expectFailBecause-#endif+ignoreTest8101 :: String -> TestTree -> TestTree+ignoreTest8101+  | GHC_API_VERSION == ("8.10.1" :: String) = ignoreTestBecause+  | otherwise = const id  ignoreInWindowsBecause :: String -> TestTree -> TestTree ignoreInWindowsBecause = if isWindows then ignoreTestBecause else (\_ x -> x)@@ -3141,6 +3332,7 @@     ,testGroup "ignore-fatal" [ignoreFatalWarning]     ,testGroup "loading" [loadCradleOnlyonce]     ,testGroup "multi"   [simpleMultiTest, simpleMultiTest2]+    ,testGroup "sub-directory"   [simpleSubDirectoryTest]     ]  loadCradleOnlyonce :: TestTree@@ -3210,33 +3402,26 @@ cradleLoadedMethod :: T.Text cradleLoadedMethod = "ghcide/cradle/loaded" --- Stack sets this which trips up cabal in the multi-component tests.--- However, our plugin tests rely on those env vars so we unset it locally.-withoutStackEnv :: IO a -> IO a-withoutStackEnv s =-  bracket-    (mapM getEnv vars >>= \prevState -> mapM_ unsetEnv vars >> pure prevState)-    (\prevState -> mapM_ (\(var, value) -> restore var value) (zip vars prevState))-    (const s)-  where vars =-          [ "GHC_PACKAGE_PATH"-          , "GHC_ENVIRONMENT"-          , "HASKELL_DIST_DIR"-          , "HASKELL_PACKAGE_SANDBOX"-          , "HASKELL_PACKAGE_SANDBOXES"-          ]-        restore var Nothing = unsetEnv var-        restore var (Just val) = setEnv var val True- ignoreFatalWarning :: TestTree-ignoreFatalWarning = testCase "ignore-fatal-warning" $ withoutStackEnv $ runWithExtraFiles "ignore-fatal" $ \dir -> do+ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do     let srcPath = dir </> "IgnoreFatal.hs"     src <- liftIO $ readFileUtf8 srcPath     _ <- createDoc srcPath "haskell" src     expectNoMoreDiagnostics 5 +simpleSubDirectoryTest :: TestTree+simpleSubDirectoryTest =+  testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do+    let mainPath = dir </> "a/src/Main.hs"+    mainSource <- liftIO $ readFileUtf8 mainPath+    _mdoc <- createDoc mainPath "haskell" mainSource+    expectDiagnosticsWithTags+      [("a/src/Main.hs", [(DsWarning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded+      ]+    expectNoMoreDiagnostics 0.5+ simpleMultiTest :: TestTree-simpleMultiTest = testCase "simple-multi-test" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do+simpleMultiTest = testCase "simple-multi-test" $ runWithExtraFiles "multi" $ \dir -> do     let aPath = dir </> "a/A.hs"         bPath = dir </> "b/B.hs"     aSource <- liftIO $ readFileUtf8 aPath@@ -3252,7 +3437,7 @@  -- Like simpleMultiTest but open the files in the other order simpleMultiTest2 :: TestTree-simpleMultiTest2 = testCase "simple-multi-test2" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do+simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \dir -> do     let aPath = dir </> "a/A.hs"         bPath = dir </> "b/B.hs"     bSource <- liftIO $ readFileUtf8 bPath@@ -3277,7 +3462,7 @@     ]  bootTests :: TestTree-bootTests = testCase "boot-def-test" $ withoutStackEnv $ runWithExtraFiles "boot" $ \dir -> do+bootTests = testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do   let cPath = dir </> "C.hs"   cSource <- liftIO $ readFileUtf8 cPath @@ -3294,7 +3479,7 @@  -- | test that TH reevaluates across interfaces ifaceTHTest :: TestTree-ifaceTHTest = testCase "iface-th-test" $ withoutStackEnv $ runWithExtraFiles "TH" $ \dir -> do+ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do     let aPath = dir </> "THA.hs"         bPath = dir </> "THB.hs"         cPath = dir </> "THC.hs"@@ -3316,7 +3501,7 @@     closeDoc cdoc  ifaceErrorTest :: TestTree-ifaceErrorTest = testCase "iface-error-test-1" $ withoutStackEnv $ runWithExtraFiles "recomp" $ \dir -> do+ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do     let bPath = dir </> "B.hs"         pPath = dir </> "P.hs" @@ -3324,11 +3509,8 @@     pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int      bdoc <- createDoc bPath "haskell" bSource-    expectDiagnosticsWithTags-      [("P.hs", [(DsWarning,(4,0), "Top-level binding", Nothing)]) -- So what we know P has been loaded-      ,("P.hs", [(DsInfo,(2,0), "The import of", Just DtUnnecessary)])-      ,("P.hs", [(DsInfo,(4,0), "Defined but not used", Just DtUnnecessary)])-      ]+    expectDiagnostics+      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So what we know P has been loaded      -- Change y from Int to B     changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]@@ -3359,16 +3541,14 @@     -- This is clearly inconsistent, and the expected outcome a bit surprising:     --   - The diagnostic for A has already been received. Ghcide does not repeat diagnostics     --   - P is being typechecked with the last successful artifacts for A.-    expectDiagnosticsWithTags-      [("P.hs", [(DsWarning,(4,0), "Top-level binding", Nothing)])-      ,("P.hs", [(DsWarning,(6,0), "Top-level binding", Nothing)])-      ,("P.hs", [(DsInfo,(4,0), "Defined but not used", Just DtUnnecessary)])-      ,("P.hs", [(DsInfo,(6,0), "Defined but not used", Just DtUnnecessary)])+    expectDiagnostics+      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])+      ,("P.hs", [(DsWarning,(6,0), "Top-level binding")])       ]     expectNoMoreDiagnostics 2  ifaceErrorTest2 :: TestTree-ifaceErrorTest2 = testCase "iface-error-test-2" $ withoutStackEnv $ runWithExtraFiles "recomp" $ \dir -> do+ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \dir -> do     let bPath = dir </> "B.hs"         pPath = dir </> "P.hs" @@ -3377,11 +3557,8 @@      bdoc <- createDoc bPath "haskell" bSource     pdoc <- createDoc pPath "haskell" pSource-    expectDiagnosticsWithTags-      [("P.hs", [(DsWarning,(4,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded-      ,("P.hs", [(DsInfo,(2,0), "The import of", Just DtUnnecessary)])-      ,("P.hs", [(DsInfo,(4,0), "Defined but not used", Just DtUnnecessary)])-      ]+    expectDiagnostics+      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded      -- Change y from Int to B     changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]@@ -3393,20 +3570,18 @@     -- foo = y :: Bool     -- HOWEVER, in A...     -- x = y  :: Int-    expectDiagnosticsWithTags+    expectDiagnostics     -- As in the other test, P is being typechecked with the last successful artifacts for A     -- (ot thanks to -fdeferred-type-errors)-      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'", Nothing)])-      ,("P.hs", [(DsWarning, (4, 0), "Top-level binding", Nothing)])-      ,("P.hs", [(DsInfo, (4,0), "Defined but not used", Just DtUnnecessary)])-      ,("P.hs", [(DsWarning, (6, 0), "Top-level binding", Nothing)])-      ,("P.hs", [(DsInfo, (6,0), "Defined but not used", Just DtUnnecessary)])+      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])+      ,("P.hs", [(DsWarning, (4, 0), "Top-level binding")])+      ,("P.hs", [(DsWarning, (6, 0), "Top-level binding")])       ]      expectNoMoreDiagnostics 2  ifaceErrorTest3 :: TestTree-ifaceErrorTest3 = testCase "iface-error-test-3" $ withoutStackEnv $ runWithExtraFiles "recomp" $ \dir -> do+ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \dir -> do     let bPath = dir </> "B.hs"         pPath = dir </> "P.hs" @@ -3423,11 +3598,9 @@      -- In this example the interface file for A should not exist (modulo the cache folder)     -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors-    expectDiagnosticsWithTags-      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'", Nothing)])-      ,("P.hs", [(DsWarning,(4,0), "Top-level binding", Nothing)])-      ,("P.hs", [(DsInfo,(2,0), "The import of", Just DtUnnecessary)])-      ,("P.hs", [(DsInfo,(4,0), "Defined but not used", Just DtUnnecessary)])+    expectDiagnostics+      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])+      ,("P.hs", [(DsWarning,(4,0), "Top-level binding")])       ]     expectNoMoreDiagnostics 2 @@ -3477,21 +3650,20 @@          setEnv "HOME" "/homeless-shelter" False -        (ec, _, _) <- withoutStackEnv $ readCreateProcessWithExitCode cmd ""+        (ec, _, _) <- readCreateProcessWithExitCode cmd ""          ec @=? ExitSuccess   ]  benchmarkTests :: TestTree--- These tests require stack and will fail with cabal test benchmarkTests =     let ?config = Bench.defConfig             { Bench.verbosity = Bench.Quiet             , Bench.repetitions = Just 3-            , Bench.buildTool = Bench.Stack+            , Bench.buildTool = Bench.Cabal             } in     withResource Bench.setup Bench.cleanUp $ \getResource -> testGroup "benchmark experiments"-    [ expectFailCabal "Requires stack" $ testCase (Bench.name e) $ do+    [ testCase (Bench.name e) $ do         Bench.SetupResult{Bench.benchDir} <- getResource         res <- Bench.runBench (runInDir benchDir) e         assertBool "did not successfully complete 5 repetitions" $ Bench.success res@@ -3501,7 +3673,7 @@  -- | checks if we use InitializeParams.rootUri for loading session rootUriTests :: TestTree-rootUriTests = testCase "use rootUri" . withoutStackEnv . runTest "dirA" "dirB" $ \dir -> do+rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do   let bPath = dir </> "dirB/Foo.hs"   liftIO $ copyTestDataFiles dir "rootUri"   bSource <- liftIO $ readFileUtf8 bPath