packages feed

haskell-language-server 2.8.0.0 → 2.9.0.0

raw patch · 276 files changed

+5082/−2564 lines, 276 filesdep +binarydep −ghcide-benchdep ~Diffdep ~basedep ~extranew-component:exe:ghcide-benchPVP ok

version bump matches the API change (PVP)

Dependencies added: binary

Dependencies removed: ghcide-bench

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

API changes (from Hackage documentation)

Files

ChangeLog.md view
@@ -1,5 +1,117 @@ # Changelog for haskell-language-server +## 2.9.0.0++- Bindists for GHC 9.10.1 by @wz1000, @jhrcek, @michaelpj+- More hls-graph reliability improvements by @soulomoon+- Refactoring of test suite runners by @soulomoon+- Fixes in multiple home units support by @wz1000++### Pull Requests++- Fix quadratic memory usage in GetLocatedImports+  ([#4318](https://github.com/haskell/haskell-language-server/pull/4318)) by @mpickering+- Bump stack configs + CI to 9.6.5 and 9.8.2+  ([#4316](https://github.com/haskell/haskell-language-server/pull/4316)) by @jhrcek+- Add support for Fourmolu 0.16+  ([#4314](https://github.com/haskell/haskell-language-server/pull/4314)) by @ brandonchinn178+- Code action to remove redundant record field import (fixes #4220)+  ([#4308](https://github.com/haskell/haskell-language-server/pull/4308)) by @battermann+- Use restricted monad for plugins (#4057)+  ([#4304](https://github.com/haskell/haskell-language-server/pull/4304)) by @awjchen+- 4301 we need to implement utility to wait for all runnning keys in hls graph done+  ([#4302](https://github.com/haskell/haskell-language-server/pull/4302)) by @soulomoon+- Call useWithStale instead of useWithStaleFast when calling ParseCabalFields+  ([#4294](https://github.com/haskell/haskell-language-server/pull/4294)) by @VeryMilkyJoe+- test: add test documenting #806+  ([#4292](https://github.com/haskell/haskell-language-server/pull/4292)) by @develop7+- ghcide: drop ghc-check and ghc-paths dependency+  ([#4291](https://github.com/haskell/haskell-language-server/pull/4291)) by @wz1000+- Limit number of valid hole fits to 10+  ([#4288](https://github.com/haskell/haskell-language-server/pull/4288)) by @akshaymankar+- Add common stanza to completion data+  ([#4286](https://github.com/haskell/haskell-language-server/pull/4286)) by @VeryMilkyJoe+- FindImports: ThisPkg means some home unit, not "this" unit+  ([#4284](https://github.com/haskell/haskell-language-server/pull/4284)) by @wz1000+- Remove redudant absolutization in session loader+  ([#4280](https://github.com/haskell/haskell-language-server/pull/4280)) by @soulomoon+- Bump to new lsp versions+  ([#4279](https://github.com/haskell/haskell-language-server/pull/4279)) by @michaelpj+- Put more test code into pre-commit+  ([#4275](https://github.com/haskell/haskell-language-server/pull/4275)) by @soulomoon+- Delete library ghcide test utils+  ([#4274](https://github.com/haskell/haskell-language-server/pull/4274)) by @soulomoon+- Delete testUtil from ghcide-tests+  ([#4272](https://github.com/haskell/haskell-language-server/pull/4272)) by @soulomoon+- CI change, only run bench on performance label+  ([#4271](https://github.com/haskell/haskell-language-server/pull/4271)) by @soulomoon+- Migrate WatchedFileTests+  ([#4269](https://github.com/haskell/haskell-language-server/pull/4269)) by @soulomoon+- Migrate UnitTests+  ([#4268](https://github.com/haskell/haskell-language-server/pull/4268)) by @soulomoon+- Migrate SafeTests+  ([#4267](https://github.com/haskell/haskell-language-server/pull/4267)) by @soulomoon+- Migrate SymlinkTests+  ([#4266](https://github.com/haskell/haskell-language-server/pull/4266)) by @soulomoon+- Remove unused and outdated CHANGELOG files+  ([#4264](https://github.com/haskell/haskell-language-server/pull/4264)) by @fendor+- Enable cabal flaky test+  ([#4263](https://github.com/haskell/haskell-language-server/pull/4263)) by @soulomoon+- Migrate RootUriTests+  ([#4261](https://github.com/haskell/haskell-language-server/pull/4261)) by @soulomoon+- Migrate PreprocessorTests+  ([#4260](https://github.com/haskell/haskell-language-server/pull/4260)) by @soulomoon+- Migrate PluginSimpleTests+  ([#4259](https://github.com/haskell/haskell-language-server/pull/4259)) by @soulomoon+- Migrate ClientSettingsTests+  ([#4258](https://github.com/haskell/haskell-language-server/pull/4258)) by @soulomoon+- Unify critical session running in hls+  ([#4256](https://github.com/haskell/haskell-language-server/pull/4256)) by @soulomoon+- Bump cachix/cachix-action from 14 to 15+  ([#4255](https://github.com/haskell/haskell-language-server/pull/4255)) by @dependabot[bot]+- Bump haskell-actions/setup from 2.7.2 to 2.7.3+  ([#4254](https://github.com/haskell/haskell-language-server/pull/4254)) by @dependabot[bot]+- Bump haskell-actions/setup from 2.7.2 to 2.7.3 in /.github/actions/setup-build+  ([#4253](https://github.com/haskell/haskell-language-server/pull/4253)) by @dependabot[bot]+- Shorter file names completion+  ([#4252](https://github.com/haskell/haskell-language-server/pull/4252)) by @VenInf+- Fix progress start delay+  ([#4249](https://github.com/haskell/haskell-language-server/pull/4249)) by @michaelpj+- Bump cachix/install-nix-action from 26 to 27+  ([#4245](https://github.com/haskell/haskell-language-server/pull/4245)) by @dependabot[bot]+- Bump haskell-actions/setup from 2.7.1 to 2.7.2+  ([#4244](https://github.com/haskell/haskell-language-server/pull/4244)) by @dependabot[bot]+- Bump haskell-actions/setup from 2.7.1 to 2.7.2 in /.github/actions/setup-build+  ([#4243](https://github.com/haskell/haskell-language-server/pull/4243)) by @dependabot[bot]+- Enable test for #717+  ([#4241](https://github.com/haskell/haskell-language-server/pull/4241)) by @soulomoon+- Remove Pepe from CODEOWNERS+  ([#4239](https://github.com/haskell/haskell-language-server/pull/4239)) by @michaelpj+- Fix resultBuilt(dirty mechanism) in hls-graph+  ([#4238](https://github.com/haskell/haskell-language-server/pull/4238)) by @soulomoon+- Support for 9.10+  ([#4233](https://github.com/haskell/haskell-language-server/pull/4233)) by @wz1000+- Refactor hls-test-util and reduce getCurrentDirectory after initilization+  ([#4231](https://github.com/haskell/haskell-language-server/pull/4231)) by @soulomoon+- [Migrate BootTests] part of #4173 Migrate ghcide tests to hls test utils+  ([#4227](https://github.com/haskell/haskell-language-server/pull/4227)) by @soulomoon+- Actually enable pedantic flag in ci flags job+  ([#4224](https://github.com/haskell/haskell-language-server/pull/4224)) by @jhrcek+- Cleanup cabal files, ghc compat code, fix ghc warnings+  ([#4222](https://github.com/haskell/haskell-language-server/pull/4222)) by @jhrcek+- Another attempt at using the lsp API for some progress reporting+  ([#4218](https://github.com/haskell/haskell-language-server/pull/4218)) by @michaelpj+- [Migrate diagnosticTests] part of #4173 Migrate ghcide tests to hls test utils+  ([#4207](https://github.com/haskell/haskell-language-server/pull/4207)) by @soulomoon+- Prepare release 2.8.0.0+  ([#4191](https://github.com/haskell/haskell-language-server/pull/4191)) by @wz1000+- Stabilize the build system by correctly house keeping the dirtykeys and rule values [flaky test #4185 #4093]+  ([#4190](https://github.com/haskell/haskell-language-server/pull/4190)) by @soulomoon+- hls-cabal-plugin: refactor context search to use `readFields`+  ([#4186](https://github.com/haskell/haskell-language-server/pull/4186)) by @fendor+- 3944 extend the properties api to better support nested configuration+  ([#3952](https://github.com/haskell/haskell-language-server/pull/3952)) by @soulomoon+ ## 2.8.0.0  - Bindists for GHC 9.6.5
bench/Main.hs view
@@ -163,6 +163,7 @@    buildRules build hlsBuildRules   benchRules build (MkBenchRules (askOracle $ GetSamples ()) benchHls warmupHls "haskell-language-server" (parallelism configStatic))+  addGetParentOracle   csvRules build   svgRules build   heapProfileRules build
exe/Wrapper.hs view
@@ -48,9 +48,9 @@ import           Ide.Plugin.Config                  (Config) import           Ide.Types                          (IdePlugins (IdePlugins)) import           Language.LSP.Protocol.Message      (Method (Method_Initialize),-                                                     ResponseError,                                                      SMethod (SMethod_Exit, SMethod_WindowShowMessageRequest),-                                                     TRequestMessage)+                                                     TRequestMessage,+                                                     TResponseError) import           Language.LSP.Protocol.Types        (MessageActionItem (MessageActionItem),                                                      MessageType (MessageType_Error),                                                      ShowMessageRequestParams (ShowMessageRequestParams),@@ -269,7 +269,8 @@ -- to shut down the LSP. launchErrorLSP :: Recorder (WithPriority (Doc ())) -> T.Text -> IO () launchErrorLSP recorder errorMsg = do-  let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) (IdePlugins [])+  cwd <- getCurrentDirectory+  let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) cwd (IdePlugins [])    inH <- Main.argsHandleIn defaultArguments @@ -282,7 +283,7 @@         -- Forcefully exit         let exit = void $ tryPutMVar clientMsgVar () -        let doInitialize :: LSP.LanguageContextEnv Config -> TRequestMessage Method_Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv Config, ()))+        let doInitialize :: LSP.LanguageContextEnv Config -> TRequestMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) (LSP.LanguageContextEnv Config, ()))             doInitialize env _ = do                let restartTitle = "Try to restart"
+ ghcide-bench/exe/Main.hs view
@@ -0,0 +1,59 @@+{- An automated benchmark built around the simple experiment described in:++  > https://neilmitchell.blogspot.com/2020/05/fixing-space-leaks-in-ghcide.html++  As an example project, it unpacks Cabal-3.2.0.0 in the local filesystem and+  loads the module 'Distribution.Simple'. The rationale for this choice is:++    - It's convenient to download with `cabal unpack Cabal-3.2.0.0`+    - It has very few dependencies, and all are already needed to build ghcide+    - Distribution.Simple has 235 transitive module dependencies, so non trivial++  The experiments are sequences of lsp commands scripted using lsp-test.+  A more refined approach would be to record and replay real IDE interactions,+  once the replay functionality is available in lsp-test.+  A more declarative approach would be to reuse ide-debug-driver:++  > https://github.com/digital-asset/daml/blob/master/compiler/damlc/ide-debug-driver/README.md++  The result of an experiment is a total duration in seconds after a preset+  number of iterations. There is ample room for improvement:+     - Statistical analysis to detect outliers and auto infer the number of iterations needed+     - GC stats analysis (currently -S is printed as part of the experiment)+     - Analysis of performance over the commit history of the project++  How to run:+     1. `cabal exec cabal run ghcide-bench -- -- ghcide-bench-options`+     1. `stack build ghcide:ghcide-bench && stack exec ghcide-bench -- -- ghcide-bench-options`++  Note that the package database influences the response times of certain actions,+  e.g. code actions, and therefore the two methods above do not necessarily+  produce the same results.++ -}++{-# LANGUAGE ImplicitParams #-}++import           Control.Exception.Safe+import           Control.Monad+import           Experiments+import           Options.Applicative+import           System.IO++optsP :: Parser (Config, Bool)+optsP = (,) <$> configP <*> switch (long "no-clean")++main :: IO ()+main = do+  hSetBuffering stdout LineBuffering+  hSetBuffering stderr LineBuffering+  (config, noClean) <- execParser $ info (optsP <**> helper) fullDesc+  let ?config = config++  hPrint stderr config++  output "starting test"++  SetupResult{..} <- setup++  runBenchmarks experiments `finally` unless noClean cleanUp
+ ghcide-bench/src/Experiments.hs view
@@ -0,0 +1,882 @@+{-# LANGUAGE DataKinds          #-}+{-# LANGUAGE GADTs              #-}+{-# LANGUAGE ImplicitParams     #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-}++module Experiments+( Bench(..)+, BenchRun(..)+, Config(..)+, Verbosity(..)+, CabalStack(..)+, SetupResult(..)+, Example(..)+, experiments+, configP+, defConfig+, output+, setup+, runBench+, exampleToOptions+) where+import           Control.Applicative.Combinators    (skipManyTill)+import           Control.Concurrent.Async           (withAsync)+import           Control.Exception.Safe             (IOException, handleAny,+                                                     try)+import           Control.Lens                       (_Just, (&), (.~), (^.),+                                                     (^?))+import           Control.Lens.Extras                (is)+import           Control.Monad.Extra                (allM, forM, forM_, forever,+                                                     unless, void, when,+                                                     whenJust, (&&^))+import           Control.Monad.IO.Class+import           Data.Aeson                         (Value (Null),+                                                     eitherDecodeStrict',+                                                     toJSON)+import qualified Data.Aeson                         as A+import qualified Data.ByteString                    as BS+import qualified Data.ByteString.Lazy               as BSL+import           Data.Either                        (fromRight)+import           Data.List+import           Data.Maybe+import           Data.Proxy+import           Data.Text                          (Text)+import qualified Data.Text                          as T+import           Data.Version+import           Development.IDE.Plugin.Test+import           Development.IDE.Test.Diagnostic+import           Development.Shake                  (CmdOption (Cwd), cmd_)+import           Experiments.Types+import           Language.LSP.Protocol.Capabilities+import qualified Language.LSP.Protocol.Lens         as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types        hiding (Null,+                                                     SemanticTokenAbsolute (..))+import qualified Language.LSP.Protocol.Types        as LSP+import           Language.LSP.Test+import           Numeric.Natural+import           Options.Applicative+import           System.Directory+import           System.Environment.Blank           (getEnv)+import           System.FilePath                    ((<.>), (</>))+import           System.IO+import           System.Process+import           System.Time.Extra+import           Text.ParserCombinators.ReadP       (readP_to_S)+import           Text.Printf++charEdit :: Position -> TextDocumentContentChangeEvent+charEdit p =+    TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial+        { _range = Range p p+        , _rangeLength = Nothing+        , _text = "a"+        }++headerEdit :: TextDocumentContentChangeEvent+headerEdit =+    TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial+        { _range = Range (Position 0 0) (Position 0 0)+        , _rangeLength = Nothing+        , _text = "-- header comment \n"+        }++data DocumentPositions = DocumentPositions {+    -- | A position that can be used to generate non null goto-def and completion responses+    identifierP    :: Maybe Position,+    -- | A position that can be modified without generating a new diagnostic+    stringLiteralP :: !Position,+    -- | The document containing the above positions+    doc            :: !TextDocumentIdentifier+}++allWithIdentifierPos :: MonadFail m => (DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool+allWithIdentifierPos f docs = case applicableDocs of+    -- fail if there are no documents to benchmark+    []    -> fail "None of the example modules have identifier positions"+    docs' -> allM f docs'+  where+    applicableDocs = filter (isJust . identifierP) docs++experiments :: HasConfig => [Bench]+experiments =+    [+      bench "semanticTokens" $ \docs -> do+        liftIO $ putStrLn "Starting semanticTokens"+        r <- forM docs $ \DocumentPositions{..} -> do+            changeDoc doc [charEdit stringLiteralP]+            waitForProgressStart+            waitForProgressDone+            tks <- getSemanticTokens doc+            case tks ^? LSP._L of+                Just _  -> return True+                Nothing -> return False+        return $ and r,+      ---------------------------------------------------------------------------------------+      bench "hover" $ allWithIdentifierPos $ \DocumentPositions{..} ->+        isJust <$> getHover doc (fromJust identifierP),+      ---------------------------------------------------------------------------------------+      bench "hover after edit" $ \docs -> do+        forM_ docs $ \DocumentPositions{..} ->+          changeDoc doc [charEdit stringLiteralP]+        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->+          isJust <$> getHover doc (fromJust identifierP),+      ---------------------------------------------------------------------------------------+      bench+        "hover after cradle edit"+        (\docs -> do+            hieYamlUri <- getDocUri "hie.yaml"+            liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n"+            sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams+             [ FileEvent hieYamlUri FileChangeType_Changed ]+            flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP)+        ),+      ---------------------------------------------------------------------------------------+      bench "edit" $ \docs -> do+        forM_ docs $ \DocumentPositions{..} -> do+          changeDoc doc [charEdit stringLiteralP]+          -- wait for a fresh build start+          waitForProgressStart+        -- wait for the build to be finished+        output "edit: waitForProgressDone"+        waitForProgressDone+        return True,+      ---------------------------------------------------------------------------------------+      bench "edit-header" $ \docs -> do+        forM_ docs $ \DocumentPositions{..} -> do+          changeDoc doc [headerEdit]+          -- wait for a fresh build start+          waitForProgressStart+        -- wait for the build to be finished+        output "edit: waitForProgressDone"+        waitForProgressDone+        return True,+      ---------------------------------------------------------------------------------------+      bench "getDefinition" $ allWithIdentifierPos $ \DocumentPositions{..} ->+        hasDefinitions <$> getDefinitions doc (fromJust identifierP),+      ---------------------------------------------------------------------------------------+      bench "getDefinition after edit" $ \docs -> do+          forM_ docs $ \DocumentPositions{..} ->+            changeDoc doc [charEdit stringLiteralP]+          flip allWithIdentifierPos docs $ \DocumentPositions{..} ->+            hasDefinitions <$> getDefinitions doc (fromJust identifierP),+      ---------------------------------------------------------------------------------------+      bench "documentSymbols" $ allM $ \DocumentPositions{..} -> do+        fmap (either (not . null) (not . null)) . getDocumentSymbols $ doc,+      ---------------------------------------------------------------------------------------+      bench "documentSymbols after edit" $ \docs -> do+        forM_ docs $ \DocumentPositions{..} ->+          changeDoc doc [charEdit stringLiteralP]+        flip allM docs $ \DocumentPositions{..} ->+          either (not . null) (not . null) <$> getDocumentSymbols doc,+      ---------------------------------------------------------------------------------------+      bench "completions" $ \docs -> do+        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->+          not . null <$> getCompletions doc (fromJust identifierP),+      ---------------------------------------------------------------------------------------+      bench "completions after edit" $ \docs -> do+        forM_ docs $ \DocumentPositions{..} ->+          changeDoc doc [charEdit stringLiteralP]+        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->+          not . null <$> getCompletions doc (fromJust identifierP),+      ---------------------------------------------------------------------------------------+      bench+        "code actions"+        ( \docs -> do+            unless (any (isJust . identifierP) docs) $+                error "None of the example modules is suitable for this experiment"+            not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do+              forM identifierP $ \p ->+                getCodeActions doc (Range p p))+        ),+      ---------------------------------------------------------------------------------------+      bench+        "code actions after edit"+        ( \docs -> do+            unless (any (isJust . identifierP) docs) $+                error "None of the example modules is suitable for this experiment"+            forM_ docs $ \DocumentPositions{..} -> do+              changeDoc doc [charEdit stringLiteralP]+              waitForProgressStart+            waitForProgressDone+            not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do+              forM identifierP $ \p ->+                getCodeActions doc (Range p p))+        ),+      ---------------------------------------------------------------------------------------+      bench+        "code actions after cradle edit"+        ( \docs -> do+            hieYamlUri <- getDocUri "hie.yaml"+            liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n"+            sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams+             [ FileEvent hieYamlUri FileChangeType_Changed ]+            waitForProgressStart+            waitForProgressStart+            waitForProgressStart -- the Session logic restarts a second time+            waitForProgressDone+            not . all null . catMaybes <$> forM docs (\DocumentPositions{..} -> do+              forM identifierP $ \p ->+                getCodeActions doc (Range p p))+        ),+      ---------------------------------------------------------------------------------------+      bench+        "code lens"+        ( \docs -> not . null <$> forM docs (\DocumentPositions{..} ->+            getCodeLenses doc)+        ),+      ---------------------------------------------------------------------------------------+      bench+        "code lens after edit"+        ( \docs -> do+            forM_ docs $ \DocumentPositions{..} -> do+              changeDoc doc [charEdit stringLiteralP]+              waitForProgressStart+            waitForProgressDone+            not . null <$> forM docs (\DocumentPositions{..} -> do+              getCodeLenses doc)+        ),+      ---------------------------------------------------------------------------------------+      benchWithSetup+        "hole fit suggestions"+        ( mapM_ $ \DocumentPositions{..} -> do+            let edit = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial+                  { _range = Range bottom bottom+                  , _rangeLength = Nothing+                  , _text = t+                  }+                bottom = Position maxBound 0+                t = T.unlines+                    [""+                    ,"holef :: [Int] -> [Int]"+                    ,"holef = _"+                    ,""+                    ,"holeg :: [()] -> [()]"+                    ,"holeg = _"+                    ]+            changeDoc doc [edit]+        )+        (\docs -> do+            forM_ docs $ \DocumentPositions{..} ->+              changeDoc doc [charEdit stringLiteralP]+            void waitForDiagnostics+            waitForProgressDone+            flip allM docs $ \DocumentPositions{..} -> do+                bottom <- pred . length . T.lines <$> documentContents doc+                diags <- getCurrentDiagnostics doc+                case requireDiagnostic diags (DiagnosticSeverity_Error, (fromIntegral bottom, 8), "Found hole", Nothing) of+                    Nothing   -> pure True+                    Just _err -> pure False+        ),+      ---------------------------------------------------------------------------------------+      benchWithSetup+        "eval execute single-line code lens"+        ( mapM_ $ \DocumentPositions{..} -> do+            let edit = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial+                  { _range = Range bottom bottom+                  , _rangeLength = Nothing+                  , _text = t+                  }+                bottom = Position maxBound 0+                t = T.unlines+                    [ ""+                    , "-- >>> 1 + 2"+                    ]+            changeDoc doc [edit]+        )+        ( \docs -> do+            not . null <$> forM docs (\DocumentPositions{..} -> do+              lenses <- getCodeLenses doc+              forM_ lenses $ \case+                CodeLens { _command = Just cmd } -> do+                  executeCommand cmd+                  waitForProgressStart+                  waitForProgressDone+                _ -> return ()+              )+        ),+      ---------------------------------------------------------------------------------------+      benchWithSetup+        "eval execute multi-line code lens"+        ( mapM_ $ \DocumentPositions{..} -> do+            let edit = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial+                  { _range = Range bottom bottom+                  , _rangeLength = Nothing+                  , _text = t+                  }+                bottom = Position maxBound 0+                t = T.unlines+                    [ ""+                    , "data T = A | B | C | D"+                    , "  deriving (Show, Eq, Ord, Bounded, Enum)"+                    , ""+                    , "{-"+                    , ">>> import Data.List (nub)"+                    , ">>> xs = ([minBound..maxBound] ++ [minBound..maxBound] :: [T])"+                    , ">>> nub xs"+                    , "-}"+                    ]+            changeDoc doc [edit]+        )+        ( \docs -> do+            not . null <$> forM docs (\DocumentPositions{..} -> do+              lenses <- getCodeLenses doc+              forM_ lenses $ \case+                CodeLens { _command = Just cmd } -> do+                  executeCommand cmd+                  waitForProgressStart+                  waitForProgressDone+                _ -> return ()+              )+        )+    ]+    where hasDefinitions (InL (Definition (InL _)))  = True+          hasDefinitions (InL (Definition (InR ls))) = not $ null ls+          hasDefinitions (InR (InL ds))              = not $ null ds+          hasDefinitions (InR (InR LSP.Null))        = False+---------------------------------------------------------------------------------------------++examplesPath :: FilePath+examplesPath = "bench/example"++defConfig :: Config+Success defConfig = execParserPure defaultPrefs (info configP fullDesc) []++quiet, verbose :: Config -> Bool+verbose = (== All) . verbosity+quiet   = (== Quiet) . verbosity++type HasConfig = (?config :: Config)++configP :: Parser Config+configP =+  Config+    <$> (flag' All (short 'v' <> long "verbose")+         <|> flag' Quiet (short 'q' <> long "quiet")+         <|> pure Normal+        )+    <*> optional (strOption (long "shake-profiling" <> metavar "PATH"))+    <*> optional (strOption (long "ot-profiling" <> metavar "DIR" <> help "Enable OpenTelemetry and write eventlog for each benchmark in DIR"))+    <*> strOption (long "csv" <> metavar "PATH" <> value "results.csv" <> showDefault)+    <*> flag Cabal Stack (long "stack" <> help "Use stack (by default cabal is used)")+    <*> many (strOption (long "ghcide-options" <> help "additional options for ghcide"))+    <*> many (strOption (short 's' <> long "select" <> help "select which benchmarks to run"))+    <*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count"))+    <*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide")+    <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response")+    <*> ( Example+               <$> exampleName+               <*> (ExampleHackage <$> packageP)+               <*> (some moduleOption <|> pure ["src/Distribution/Simple.hs"])+               <*> pure []+      <|> Example+               <$> exampleName+               <*> pathOrScriptP+               <*> some moduleOption+               <*> pure [])+    <*> switch (long "lsp-config" <> help "Read an LSP config payload from standard input")+  where+      moduleOption = strOption (long "example-module" <> metavar "PATH")+      exampleName = strOption (long "example-name" <> metavar "NAME")++      packageP = ExamplePackage+            <$> strOption (long "example-package-name" <> value "Cabal")+            <*> option versionP (long "example-package-version" <> value (makeVersion [3,6,0,0]))+      pathOrScriptP = ExamplePath   <$> strOption (long "example-path")+                  <|> ExampleScript <$> strOption (long "example-script") <*> many (strOption (long "example-script-args" <> help "arguments for the example generation script"))++versionP :: ReadM Version+versionP = maybeReader $ extract . readP_to_S parseVersion+  where+      extract parses = listToMaybe [ res | (res,"") <- parses]++output :: (MonadIO m, HasConfig) => String -> m ()+output = if quiet ?config then (\_ -> pure ()) else liftIO . putStrLn++---------------------------------------------------------------------------------------++type Experiment = [DocumentPositions] -> Session Bool++data Bench =+  Bench+  { name       :: !String,+    enabled    :: !Bool,+    samples    :: !Natural,+    benchSetup :: [DocumentPositions] -> Session (),+    experiment :: Experiment+  }++select :: HasConfig => Bench -> Bool+select Bench {name, enabled} =+  enabled && (null mm || name `elem` mm)+  where+    mm = matches ?config++benchWithSetup ::+  String ->+  ([DocumentPositions] -> Session ()) ->+  Experiment ->+  Bench+benchWithSetup name benchSetup experiment = Bench {..}+  where+    enabled = True+    samples = 100++bench :: String -> Experiment -> Bench+bench name = benchWithSetup name (const $ pure ())++runBenchmarksFun :: HasConfig => FilePath -> [Bench] -> IO ()+runBenchmarksFun dir allBenchmarks = do+  let benchmarks = [ b{samples = fromMaybe 100 (repetitions ?config) }+                   | b <- allBenchmarks+                   , select b ]++  whenJust (otMemoryProfiling ?config) $ \eventlogDir ->+      createDirectoryIfMissing True eventlogDir++  lspConfig <- if Experiments.Types.lspConfig ?config+    then either error id . eitherDecodeStrict' <$> BS.getContents+    else return mempty++  let conf = defaultConfig+        { logStdErr = verbose ?config,+          logMessages = verbose ?config,+          logColor = False,+          Language.LSP.Test.lspConfig = lspConfig,+          messageTimeout = timeoutLsp ?config+        }+  results <- forM benchmarks $ \b@Bench{name} ->  do+    let p = (proc (ghcide ?config) (allArgs name dir))+                { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }+        run sess = withCreateProcess p $ \(Just inH) (Just outH) (Just errH) pH -> do+                    -- Need to continuously consume to stderr else it gets blocked+                    -- Can't pass NoStream either to std_err+                    hSetBuffering errH NoBuffering+                    hSetBinaryMode errH True+                    let errSinkThread =+                            forever $ hGetLine errH >>= when (verbose ?config). putStrLn+                    withAsync errSinkThread $ \_ -> do+                        runSessionWithHandles' (Just pH) inH outH conf lspTestCaps dir sess+    (b,) <$> runBench run b++  -- output raw data as CSV+  let headers =+        [ "name"+        , "success"+        , "samples"+        , "startup"+        , "setup"+        , "userT"+        , "delayedT"+        , "1stBuildT"+        , "avgPerRespT"+        , "totalT"+        , "rulesBuilt"+        , "rulesChanged"+        , "rulesVisited"+        , "rulesTotal"+        , "ruleEdges"+        , "ghcRebuilds"+        ]+      rows =+        [ [ name,+            show success,+            show samples,+            showMs startup,+            showMs runSetup',+            showMs userWaits,+            showMs delayedWork,+            showMs $ firstResponse+firstResponseDelayed,+            -- Exclude first response as it has a lot of setup time included+            -- Assume that number of requests = number of modules * number of samples+            showMs ((userWaits - firstResponse)/((fromIntegral samples - 1)*modules)),+            showMs runExperiment,+            show rulesBuilt,+            show rulesChanged,+            show rulesVisited,+            show rulesTotal,+            show edgesTotal,+            show rebuildsTotal+          ]+          | (Bench {name, samples}, BenchRun {..}) <- results,+            let runSetup' = if runSetup < 0.01 then 0 else runSetup+                modules = fromIntegral $ length $ exampleModules $ example ?config+        ]+      csv = unlines $ map (intercalate ", ") (headers : rows)+  writeFile (outputCSV ?config) csv++  -- print a nice table+  let pads = map (maximum . map length) (transpose (headers : rowsHuman))+      paddedHeaders = zipWith pad pads headers+      outputRow = putStrLn . intercalate " | "+      rowsHuman =+        [ [ name,+            show success,+            show samples,+            showDuration startup,+            showDuration runSetup',+            showDuration userWaits,+            showDuration delayedWork,+            showDuration firstResponse,+            showDuration runExperiment,+            show rulesBuilt,+            show rulesChanged,+            show rulesVisited,+            show rulesTotal,+            show edgesTotal,+            show rebuildsTotal+          ]+          | (Bench {name, samples}, BenchRun {..}) <- results,+            let runSetup' = if runSetup < 0.01 then 0 else runSetup+        ]+  outputRow paddedHeaders+  outputRow $ (map . map) (const '-') paddedHeaders+  forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row+  where+    ghcideArgs dir =+        [ "--lsp",+          "--test",+          "--cwd",+          dir+        ]+    allArgs name dir =+        ghcideArgs dir+          ++ concat+             [ [ "+RTS"+               , "-l"+               , "-ol" ++ (dir </> map (\c -> if c == ' ' then '-' else c) name <.> "eventlog")+               , "-RTS"+               ]+             | Just dir <- [otMemoryProfiling ?config]+             ]+          ++ ghcideOptions ?config+          ++ concat+            [ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config]+            ]+          ++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]]+    lspTestCaps =+      fullLatestClientCaps+        & (L.window . _Just) .~ WindowClientCapabilities (Just True) Nothing Nothing+        & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just) .~ (ClientCodeActionResolveOptions ["edit"])+        & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ True++showMs :: Seconds -> String+showMs = printf "%.2f"++data BenchRun = BenchRun+  { startup              :: !Seconds,+    runSetup             :: !Seconds,+    runExperiment        :: !Seconds,+    userWaits            :: !Seconds,+    delayedWork          :: !Seconds,+    firstResponse        :: !Seconds,+    firstResponseDelayed :: !Seconds,+    rulesBuilt           :: !Int,+    rulesChanged         :: !Int,+    rulesVisited         :: !Int,+    rulesTotal           :: !Int,+    edgesTotal           :: !Int,+    rebuildsTotal        :: !Int,+    success              :: !Bool+  }++badRun :: BenchRun+badRun = BenchRun 0 0 0 0 0 0 0 0 0 0 0 0 0 False++waitForProgressStart :: Session ()+waitForProgressStart = void $ do+    skipManyTill anyMessage $ satisfy $ \case+      FromServerMess SMethod_WindowWorkDoneProgressCreate _ -> True+      _                                              -> False++-- | Wait for all progress to be done+-- Needs at least one progress done notification to return+waitForProgressDone :: Session ()+waitForProgressDone = loop+  where+    loop = do+      ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case+        FromServerMess  SMethod_Progress  (TNotificationMessage _ _ (ProgressParams _ v)) | is _workDoneProgressEnd v -> Just ()+        _ -> Nothing+      done <- null <$> getIncompleteProgressSessions+      unless done loop++-- | Wait for the build queue to be empty+waitForBuildQueue :: Session Seconds+waitForBuildQueue = do+    let m = SMethod_CustomMethod (Proxy @"test")+    waitId <- sendRequest m (toJSON WaitForShakeQueue)+    (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId+    case resp of+        TResponseMessage{_result=Right Null} -> return td+        -- assume a ghcide binary lacking the WaitForShakeQueue method+        _                                    -> return 0++runBench ::+  HasConfig =>+  (Session BenchRun -> IO BenchRun) ->+  Bench ->+  IO BenchRun+runBench runSess Bench{..} = handleAny (\e -> print e >> return badRun)+  $ runSess+  $ do+      (startup, docs) <- duration $ do+        (d, docs) <- duration $ setupDocumentContents ?config+        output $ "Setting up document contents took " <> showDuration d+        -- wait again, as the progress is restarted once while loading the cradle+        -- make an edit, to ensure this doesn't block+        let DocumentPositions{..} = head docs+        changeDoc doc [charEdit stringLiteralP]+        waitForProgressDone+        return docs++      liftIO $ output $ "Running " <> name <> " benchmark"+      (runSetup, ()) <- duration $ benchSetup docs+      let loop' (Just timeForFirstResponse) !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork, timeForFirstResponse)+          loop' timeForFirstResponse !userWaits !delayedWork n = do+            (t, res) <- duration $ experiment docs+            if not res+              then return Nothing+            else do+                output (showDuration t)+                -- Wait for the delayed actions to finish+                td <- waitForBuildQueue+                loop' (timeForFirstResponse <|> Just (t,td)) (userWaits+t) (delayedWork+td) (n -1)+          loop = loop' Nothing++      (runExperiment, result) <- duration $ loop 0 0 samples+      let success = isJust result+          (userWaits, delayedWork, (firstResponse, firstResponseDelayed)) = fromMaybe (0,0,(0,0)) result++      rulesTotal <- length <$> getStoredKeys+      rulesBuilt <- either (const 0) length <$> getBuildKeysBuilt+      rulesChanged <- either (const 0) length <$> getBuildKeysChanged+      rulesVisited <- either (const 0) length <$> getBuildKeysVisited+      edgesTotal   <- fromRight 0 <$> getBuildEdgesCount+      rebuildsTotal <- fromRight 0 <$> getRebuildsCount++      return BenchRun {..}++data SetupResult = SetupResult {+    runBenchmarks :: [Bench] -> IO (),+    -- | Path to the setup benchmark example+    benchDir      :: FilePath,+    cleanUp       :: IO ()+}++callCommandLogging :: HasConfig => String -> IO ()+callCommandLogging cmd = do+    output cmd+    callCommand cmd++simpleCabalCradleContent :: String+simpleCabalCradleContent = "cradle:\n  cabal:\n"++simpleStackCradleContent :: String+simpleStackCradleContent = "cradle:\n  stack:\n"++-- | Setup the benchmark+-- we need to create a hie.yaml file for the examples+-- or the hie.yaml file would be searched in the parent directories recursively+-- implicit-hie is error prone for the example test `lsp-types-2.1.1.0`+-- we are using the simpleCabalCradleContent for the hie.yaml file instead.+-- it works if we have cabal > 3.2.+setup :: HasConfig => IO SetupResult+setup = do+  benchDir <- case exampleDetails(example ?config) of+      ExamplePath examplePath -> do+          let hieYamlPath = examplePath </> "hie.yaml"+          alreadyExists <- doesFileExist hieYamlPath+          unless alreadyExists $ writeFile hieYamlPath simpleCabalCradleContent+          return examplePath+      ExampleScript examplePath' scriptArgs -> do+          let exampleDir = examplesPath </> exampleName (example ?config)+          alreadySetup <- doesDirectoryExist exampleDir+          unless alreadySetup $ do+            createDirectoryIfMissing True exampleDir+            examplePath <- makeAbsolute examplePath'+            cmd_ (Cwd exampleDir) examplePath scriptArgs+            let hieYamlPath = exampleDir </> "hie.yaml"+            alreadyExists <- doesFileExist hieYamlPath+            unless alreadyExists $ writeFile hieYamlPath simpleCabalCradleContent++          return exampleDir+      ExampleHackage ExamplePackage{..} -> do+        let path = examplesPath </> package+            package = packageName <> "-" <> showVersion packageVersion+            hieYamlPath = path </> "hie.yaml"+        alreadySetup <- doesDirectoryExist path+        unless alreadySetup $+          case buildTool ?config of+            Cabal -> do+                let cabalVerbosity = "-v" ++ show (fromEnum (verbose ?config))+                callCommandLogging $ "cabal get " <> cabalVerbosity <> " " <> package <> " -d " <> examplesPath+                let hieYamlPath = path </> "hie.yaml"+                writeFile hieYamlPath simpleCabalCradleContent+                -- Need this in case there is a parent cabal.project somewhere+                writeFile+                    (path </> "cabal.project")+                    "packages: ."+                writeFile+                    (path </> "cabal.project.local")+                    ""+            Stack -> do+                let stackVerbosity = case verbosity ?config of+                        Quiet  -> "--silent"+                        Normal -> ""+                        All    -> "--verbose"+                callCommandLogging $ "stack " <> stackVerbosity <> " unpack " <> package <> " --to " <> examplesPath+                -- Generate the stack descriptor to match the one used to build ghcide+                stack_yaml <- fromMaybe "stack.yaml" <$> getEnv "STACK_YAML"+                stack_yaml_lines <- lines <$> readFile stack_yaml+                writeFile (path </> stack_yaml)+                        (unlines $+                        "packages: [.]" :+                            [ l+                            | l <- stack_yaml_lines+                            , any (`isPrefixOf` l)+                                ["resolver"+                                ,"allow-newer"+                                ,"compiler"]+                            ]+                        )+                writeFile hieYamlPath simpleStackCradleContent+        return path++  whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True++  let cleanUp = case exampleDetails (example ?config) of+        ExampleHackage _  -> removeDirectoryRecursive examplesPath+        ExampleScript _ _ -> removeDirectoryRecursive examplesPath+        ExamplePath _     -> return ()++      runBenchmarks = runBenchmarksFun benchDir++  return SetupResult{..}++setupDocumentContents :: Config -> Session [DocumentPositions]+setupDocumentContents config =+        forM (exampleModules $ example config) $ \m -> do+        doc <- openDoc m "haskell"++        -- Setup the special positions used by the experiments+        lastLine <- fromIntegral . length . T.lines <$> documentContents doc+        changeDoc doc [TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial+                        { _range = Range (Position lastLine 0) (Position lastLine 0)+                        , _rangeLength = Nothing+                        , _text = T.unlines [ "_hygienic = \"hygienic\"" ]+                        }+                      ]+        let+        -- Points to a string in the target file,+        -- convenient for hygienic edits+            stringLiteralP = Position lastLine 15++        -- Find an identifier defined in another file in this project+        symbols <- getDocumentSymbols doc+        let endOfImports = case symbols of+                Right symbols | Just x <- findEndOfImports symbols -> x+                _ -> error $ "symbols: " <> show symbols+        contents <- documentContents doc+        identifierP <- searchSymbol doc contents endOfImports+        return $ DocumentPositions{..}++findEndOfImports :: [DocumentSymbol] -> Maybe Position+findEndOfImports (DocumentSymbol{_kind = SymbolKind_Module, _name = "imports", _range} : _) =+    Just $ Position (succ $ _line $ _end _range) 4+findEndOfImports [DocumentSymbol{_kind = SymbolKind_File, _children = Just cc}] =+    findEndOfImports cc+findEndOfImports (DocumentSymbol{_range} : _) =+    Just $ _range ^. L.start+findEndOfImports _ = Nothing++--------------------------------------------------------------------------------------------++pad :: Int -> String -> String+pad n []     = replicate n ' '+pad 0 _      = error "pad"+pad n (x:xx) = x : pad (n-1) xx++-- | Search for a position where:+--     - get definition works and returns a uri other than this file+--     - get completions returns a non empty list+searchSymbol :: TextDocumentIdentifier -> T.Text -> Position -> Session (Maybe Position)+searchSymbol doc@TextDocumentIdentifier{_uri} fileContents pos = do+    -- this search is expensive, so we cache the result on disk+    let cachedPath = fromJust (uriToFilePath _uri) <.> "identifierPosition"+    cachedRes <- liftIO $ try @_ @IOException $ A.decode . BSL.fromStrict <$> BS.readFile cachedPath+    case cachedRes of+        Left _ -> do+            result <- loop pos+            liftIO $ BS.writeFile cachedPath $ BSL.toStrict $ A.encode result+            return result+        Right res ->+            return res+  where+      loop pos+        | (fromIntegral $ _line pos) >= lll =+            return Nothing+        | (fromIntegral $ _character pos) >= lengthOfLine (fromIntegral $ _line pos) =+            loop (nextLine pos)+        | otherwise = do+                checks <- checkDefinitions pos &&^ checkCompletions pos+                if checks+                    then return $ Just pos+                    else loop (nextIdent pos)++      nextIdent p = p{_character = _character p + 2}+      nextLine p = Position (_line p + 1) 4++      lengthOfLine n = if n >= lll then 0 else T.length (ll !! n)+      ll = T.lines fileContents+      lll = length ll++      checkDefinitions pos = do+        defs <- getDefinitions doc pos+        case defs of+            (InL (Definition (InR [Location uri _]))) -> return $ uri /= _uri+            _                                         -> return False+      checkCompletions pos =+        not . null <$> getCompletions doc pos+++getBuildKeysBuilt :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) [T.Text])+getBuildKeysBuilt = tryCallTestPlugin GetBuildKeysBuilt++getBuildKeysVisited :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) [T.Text])+getBuildKeysVisited = tryCallTestPlugin GetBuildKeysVisited++getBuildKeysChanged :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) [T.Text])+getBuildKeysChanged = tryCallTestPlugin GetBuildKeysChanged++getBuildEdgesCount :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) Int)+getBuildEdgesCount = tryCallTestPlugin GetBuildEdgesCount++getRebuildsCount :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) Int)+getRebuildsCount = tryCallTestPlugin GetRebuildsCount++-- Copy&paste from ghcide/test/Development.IDE.Test+getStoredKeys :: Session [Text]+getStoredKeys = callTestPlugin GetStoredKeys++-- Copy&paste from ghcide/test/Development.IDE.Test+tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) b)+tryCallTestPlugin cmd = do+    let cm = SMethod_CustomMethod (Proxy @"test")+    waitId <- sendRequest cm (A.toJSON cmd)+    TResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId+    return $ case _result of+         Left e -> Left e+         Right json -> case A.fromJSON json of+             A.Success a -> Right a+             A.Error e   -> error e++-- Copy&paste from ghcide/test/Development.IDE.Test+callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b+callTestPlugin cmd = do+    res <- tryCallTestPlugin cmd+    case res of+        Left (TResponseError t err _) -> error $ show t <> ": " <> T.unpack err+        Right a                       -> pure a
+ ghcide-bench/src/Experiments/Types.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings  #-}+module Experiments.Types (module Experiments.Types ) where++import           Control.DeepSeq+import           Data.Aeson+import           Data.Binary     (Binary)+import           Data.Hashable   (Hashable)+import           Data.Maybe      (fromMaybe)+import           Data.Version+import           GHC.Generics+import           Numeric.Natural++data CabalStack = Cabal | Stack+  deriving (Eq, Show)++data Verbosity = Quiet | Normal | All+  deriving (Eq, Show)+data Config = Config+  { verbosity         :: !Verbosity,+    -- For some reason, the Shake profile files are truncated and won't load+    shakeProfiling    :: !(Maybe FilePath),+    otMemoryProfiling :: !(Maybe FilePath),+    outputCSV         :: !FilePath,+    buildTool         :: !CabalStack,+    ghcideOptions     :: ![String],+    matches           :: ![String],+    repetitions       :: Maybe Natural,+    ghcide            :: FilePath,+    timeoutLsp        :: Int,+    example           :: Example,+    lspConfig         :: Bool+  }+  deriving (Eq, Show)++data ExamplePackage = ExamplePackage {packageName :: !String, packageVersion :: !Version}+  deriving (Eq, Generic, Show)+  deriving anyclass (Binary, Hashable, NFData)++data Example = Example+    { exampleName      :: !String+    , exampleDetails   :: ExampleDetails+    , exampleModules   :: [FilePath]+    , exampleExtraArgs :: [String]}+  deriving (Eq, Generic, Show)+  deriving anyclass (Binary, Hashable, NFData)++data ExampleDetails+  = ExamplePath FilePath -- ^ directory where the package is located+  | ExampleHackage ExamplePackage -- ^ package from hackage+  | ExampleScript FilePath -- ^ location of the script we are running+                  [String] -- ^ extra arguments for the script+  deriving (Eq, Generic, Show)+  deriving anyclass (Binary, Hashable, NFData)++instance FromJSON Example where+    parseJSON = withObject "example" $ \x -> do+        exampleName <- x .: "name"+        exampleModules <- x .: "modules"+        exampleExtraArgs <- fromMaybe [] <$> x .:? "extra-args"++        path <- x .:? "path"+        case path of+            Just examplePath -> do+                script <- fromMaybe False <$> x.:? "script"+                args <- fromMaybe [] <$> x .:? "script-args"+                let exampleDetails+                      | script = ExampleScript examplePath args+                      | otherwise = ExamplePath examplePath+                return Example{..}+            Nothing -> do+                packageName <- x .: "package"+                packageVersion <- x .: "version"+                let exampleDetails = ExampleHackage ExamplePackage{..}+                return Example{..}++exampleToOptions :: Example -> [String] -> [String]+exampleToOptions Example{exampleDetails = ExampleHackage ExamplePackage{..}, ..} extraArgs =+    ["--example-package-name", packageName+    ,"--example-package-version", showVersion packageVersion+    ,"--example-name", exampleName+    ] +++    ["--example-module=" <> m | m <- exampleModules+    ] +++    ["--ghcide-options=" <> o | o <- exampleExtraArgs ++ extraArgs]+exampleToOptions Example{exampleDetails = ExamplePath examplePath, ..} extraArgs =+    ["--example-path", examplePath+    ,"--example-name", exampleName+    ] +++    ["--example-module=" <> m | m <- exampleModules+    ] +++    ["--ghcide-options=" <> o | o <- exampleExtraArgs ++ extraArgs]+exampleToOptions Example{exampleDetails = ExampleScript examplePath exampleArgs, ..} extraArgs =+    ["--example-script", examplePath+    ,"--example-name", exampleName+    ] +++    ["--example-script-args=" <> o | o <- exampleArgs+    ] +++    ["--example-module=" <> m | m <- exampleModules+    ] +++    ["--ghcide-options=" <> o | o <- exampleExtraArgs ++ extraArgs]
+ ghcide-bench/test/Main.hs view
@@ -0,0 +1,47 @@+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE ImplicitParams        #-}+{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-}++module Main (main) where++import           Data.List.Extra+import qualified Experiments                  as Bench+import           Language.LSP.Test+import           Test.Tasty+import           Test.Tasty.HUnit+import           Test.Tasty.Ingredients.Rerun (defaultMainWithRerun)++main :: IO ()+main = defaultMainWithRerun benchmarkTests++benchmarkTests :: TestTree+benchmarkTests =+    let ?config = Bench.defConfig+            { Bench.verbosity = Bench.Quiet+            , Bench.repetitions = Just 3+            , Bench.buildTool = Bench.Cabal+            } in+    withResource Bench.setup Bench.cleanUp $ \getResource -> testGroup "benchmark experiments"+    [ testCase (Bench.name e) $ do+        Bench.SetupResult{Bench.benchDir} <- getResource+        res <- Bench.runBench (runInDir benchDir) e+        assertBool "did not successfully complete 5 repetitions" $ Bench.success res+        | e <- Bench.experiments+        , Bench.name e /= "edit" -- the edit experiment does not ever fail+        , Bench.name e /= "hole fit suggestions" -- is too slow!+        -- the cradle experiments are way too slow+        , not ("cradle" `isInfixOf` Bench.name e)+    ]++runInDir :: FilePath -> Session a -> IO a+runInDir dir = runSessionWithConfig defaultConfig cmd fullLatestClientCaps dir+  where+    -- TODO use HLS instead of ghcide+    cmd = "ghcide --lsp --test --verbose -j2 --cwd " <> dir
ghcide/test/exe/AsyncTests.hs view
@@ -15,17 +15,17 @@                                                 mkRange) import           Language.LSP.Test -- import Test.QuickCheck.Instances ()+import           Config import           Development.IDE.Plugin.Test   (TestRequest (BlockSeconds),                                                 blockCommandId) import           Test.Tasty import           Test.Tasty.HUnit-import           TestUtils  -- | Test if ghcide asynchronously handles Commands and user Requests tests :: TestTree tests = testGroup "async"     [-      testSession "command" $ do+      testWithDummyPluginEmpty "command" $ do             -- Execute a command that will block forever             let req = ExecuteCommandParams Nothing blockCommandId Nothing             void $ sendRequest SMethod_WorkspaceExecuteCommand req@@ -38,7 +38,7 @@             codeLenses <- getAndResolveCodeLenses doc             liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=?               [ "foo :: a -> a" ]-    , testSession "request" $ do+    , testWithDummyPluginEmpty "request" $ do             -- Execute a custom request that will block for 1000 seconds             void $ sendRequest (SMethod_CustomMethod (Proxy @"test")) $ toJSON $ BlockSeconds 1000             -- Load a file and check for code actions. Will only work if the request is run asynchronously
ghcide/test/exe/BootTests.hs view
@@ -1,5 +1,7 @@ module BootTests (tests) where +import           Config                          (checkDefs, mkR, runInDir,+                                                  runWithExtraFiles) import           Control.Applicative.Combinators import           Control.Monad import           Control.Monad.IO.Class          (liftIO)@@ -14,10 +16,9 @@                                                   SemanticTokensEdit (..),                                                   mkRange) import           Language.LSP.Test-import           System.FilePath+import           System.FilePath                 ((</>)) import           Test.Tasty import           Test.Tasty.HUnit-import           TestUtils   tests :: TestTree
ghcide/test/exe/CPPTests.hs view
@@ -9,14 +9,14 @@                                               SemanticTokensEdit (..), mkRange) import           Language.LSP.Test -- import Test.QuickCheck.Instances ()+import           Config import           Test.Tasty import           Test.Tasty.HUnit-import           TestUtils  tests :: TestTree tests =   testGroup "cpp"-    [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do+    [ testCase "cpp-error" $ do         let content =               T.unlines                 [ "{-# LANGUAGE CPP #-}",@@ -32,7 +32,7 @@                       let _ = e :: HUnitFailure                       run $ expectError content (2, 1)                   )-    , testSessionWait "cpp-ghcide" $ do+    , testWithDummyPluginEmpty "cpp-ghcide" $ do         _ <- createDoc "A.hs" "haskell" $ T.unlines           ["{-# LANGUAGE CPP #-}"           ,"main ="
ghcide/test/exe/ClientSettingsTests.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE GADTs #-} module ClientSettingsTests (tests) where +import           Config                          (testWithDummyPluginEmpty) import           Control.Applicative.Combinators import           Control.Monad import           Data.Aeson                      (toJSON)@@ -14,12 +15,12 @@                                                   SemanticTokensEdit (..),                                                   mkRange) import           Language.LSP.Test+import           Test.Hls                        (waitForProgressDone) import           Test.Tasty-import           TestUtils  tests :: TestTree tests = testGroup "client settings handling"-    [ testSession "ghcide restarts shake session on config changes" $ do+    [ testWithDummyPluginEmpty "ghcide restarts shake session on config changes" $ do             setIgnoringLogNotifications False             void $ createDoc "A.hs" "haskell" "module A where"             waitForProgressDone
ghcide/test/exe/CodeLensTests.hs view
@@ -2,6 +2,7 @@  module CodeLensTests (tests) where +import           Config import           Control.Applicative.Combinators import           Control.Lens                    ((^.)) import           Control.Monad                   (void)@@ -18,9 +19,9 @@                                                   SemanticTokensEdit (..),                                                   mkRange) import           Language.LSP.Test+import           Test.Hls                        (mkRange, waitForProgressDone) import           Test.Tasty import           Test.Tasty.HUnit-import           TestUtils  tests :: TestTree tests = testGroup "code lenses"@@ -45,7 +46,7 @@       after' enableGHCWarnings exported (def, sig) others =         T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others       createConfig mode = A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]-      sigSession testName enableGHCWarnings waitForDiags mode exported def others = testSession testName $ do+      sigSession testName enableGHCWarnings waitForDiags mode exported def others = testWithDummyPluginEmpty testName $ do         let originalCode = before enableGHCWarnings exported def others         let expectedCode = after' enableGHCWarnings exported def others         setConfigSection "haskell" (createConfig mode)@@ -87,7 +88,11 @@         , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"")         , ("promotedKindTest = Proxy @Nothing", if ghcVersion >= GHC96 then "promotedKindTest :: Proxy Nothing" else "promotedKindTest :: Proxy 'Nothing")         , ("typeOperatorTest = Refl", "typeOperatorTest :: forall {k} {a :: k}. a :~: a")-        , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType")+        , ("notInScopeTest = mkCharType"+          , if ghcVersion < GHC910+              then "notInScopeTest :: String -> Data.Data.DataType"+              else "notInScopeTest :: String -> GHC.Internal.Data.Data.DataType"+          )         , ("aVeryLongSignature a b c d e f g h i j k l m n = a && b && c && d && e && f && g && h && i && j && k && l && m && n", "aVeryLongSignature :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool")         ]    in testGroup@@ -99,7 +104,7 @@             [ sigSession "with GHC warnings" True True "diagnostics" "" (second Just $ head cases) []             , sigSession "without GHC warnings" False False "diagnostics" "" (second (const Nothing) $ head cases) []             ]-        , testSession "keep stale lens" $ do+        , testWithDummyPluginEmpty "keep stale lens" $ do             let content = T.unlines                     [ "module Stale where"                     , "f = _"
ghcide/test/exe/CompletionTests.hs view
@@ -1,9 +1,13 @@ -{-# LANGUAGE GADTs            #-}-{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedLabels  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}  module CompletionTests (tests) where +import           Config import           Control.Lens                   ((^.)) import qualified Control.Lens                   as Lens import           Control.Monad@@ -11,10 +15,7 @@ import           Data.Default import           Data.List.Extra import           Data.Maybe-import           Data.Row import qualified Data.Text                      as T-import           Development.IDE.GHC.Compat     (GhcVersion (..), ghcVersion)-import           Development.IDE.Test           (waitForTypecheck) import           Development.IDE.Types.Location import           Ide.Plugin.Config import qualified Language.LSP.Protocol.Lens     as L@@ -25,10 +26,12 @@                                                  SemanticTokensEdit (..),                                                  mkRange) import           Language.LSP.Test-import           System.FilePath+import           Test.Hls                       (waitForTypecheck)+import qualified Test.Hls.FileSystem            as FS+import           Test.Hls.FileSystem            (file, text)+import           Test.Hls.Util import           Test.Tasty import           Test.Tasty.HUnit-import           TestUtils   tests :: TestTree@@ -44,9 +47,19 @@     , testGroup "doc" completionDocTests     ] +testSessionEmpty :: TestName -> Session () -> TestTree+testSessionEmpty name = testWithDummyPlugin name (mkIdeTestFs [FS.directCradle ["A.hs"]])++testSessionEmptyWithCradle :: TestName -> T.Text -> Session () -> TestTree+testSessionEmptyWithCradle name cradle = testWithDummyPlugin name (mkIdeTestFs [file "hie.yaml" (text cradle)])++testSessionSingleFile :: TestName -> FilePath -> T.Text -> Session () -> TestTree+testSessionSingleFile testName fp txt session =+    testWithDummyPlugin testName (mkIdeTestFs [FS.directCradle [T.pack fp] , file fp (text txt)]) session+ completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe [TextEdit])] -> TestTree-completionTest name src pos expected = testSessionWait name $ do-    docId <- createDoc "A.hs" "haskell" (T.unlines src)+completionTest name src pos expected = testSessionSingleFile name "A.hs" (T.unlines src) $ do+    docId <- openDoc "A.hs" "haskell"     _ <- waitForDiagnostics     compls <- getAndResolveCompletions docId pos     let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls]@@ -185,12 +198,12 @@         [("abcd", CompletionItemKind_Function, "abcd", True, False, Nothing)         ,("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing)         ],-    testSessionWait "incomplete entries" $ do+    testSessionEmpty "incomplete entries" $ do         let src a = "data Data = " <> a         doc <- createDoc "A.hs" "haskell" $ src "AAA"         void $ waitForTypecheck doc         let editA rhs =-                changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ src rhs]+                changeDoc doc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ src rhs]         editA "AAAA"         void $ waitForTypecheck doc         editA "AAAAA"@@ -203,7 +216,7 @@  nonLocalCompletionTests :: [TestTree] nonLocalCompletionTests =-  [ brokenForWinGhc $ completionTest+  [ brokenForWinOldGhc $ completionTest       "variable"       ["module A where", "f = hea"]       (Position 1 7)@@ -261,7 +274,12 @@       []   ]   where-    brokenForWinGhc = knownBrokenFor (BrokenSpecific Windows [GHC92, GHC94, GHC96, GHC98]) "Windows has strange things in scope for some reason"+    brokenForWinGhc = knownBrokenOnWindows "Windows has strange things in scope for some reason"+    brokenForWinOldGhc =+      knownBrokenInSpecificEnv [HostOS Windows, GhcVer GHC92] "Windows (GHC == 9.2) has strange things in scope for some reason"+      . knownBrokenInSpecificEnv [HostOS Windows, GhcVer GHC94] "Windows (GHC == 9.4) has strange things in scope for some reason"+      . knownBrokenInSpecificEnv [HostOS Windows, GhcVer GHC96] "Windows (GHC == 9.6) has strange things in scope for some reason"+      . knownBrokenInSpecificEnv [HostOS Windows, GhcVer GHC98] "Windows (GHC == 9.8) has strange things in scope for some reason"  otherCompletionTests :: [TestTree] otherCompletionTests = [@@ -283,7 +301,7 @@       (Position 3 11)       [("Integer", CompletionItemKind_Struct, "Integer", True, True, Nothing)], -    testSession "duplicate record fields" $ do+    testSessionEmpty "duplicate record fields" $ do       void $         createDoc "B.hs" "haskell" $           T.unlines@@ -304,22 +322,21 @@       let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"]       liftIO $ take 1 compls' @?= ["member"], -    testSessionWait "maxCompletions" $ do+    testSessionEmpty "maxCompletions" $ do         doc <- createDoc "A.hs" "haskell" $ T.unlines             [ "{-# OPTIONS_GHC -Wunused-binds #-}",                 "module A () where",                 "a = Prelude."             ]         _ <- waitForDiagnostics-        compls <- getCompletions  doc (Position 3 13)+        compls <- getCompletions doc (Position 3 13)         liftIO $ length compls @?= maxCompletions def   ]  packageCompletionTests :: [TestTree] packageCompletionTests =-  [ testSession' "fromList" $ \dir -> do-        liftIO $ writeFile (dir </> "hie.yaml")-            "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}"+  [ testSessionEmptyWithCradle "fromList" "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}" $ do+         doc <- createDoc "A.hs" "haskell" $ T.unlines             [ "{-# OPTIONS_GHC -Wunused-binds #-}",                 "module A () where",@@ -337,9 +354,9 @@           map ("Defined in "<>) (               [ "'Data.List.NonEmpty"               , "'GHC.Exts"-              ] ++ if ghcVersion >= GHC94 then [ "'GHC.IsList" ] else [])+              ] ++ (["'GHC.IsList" | ghcVersion >= GHC94])) -  , testSessionWait "Map" $ do+  , testSessionEmptyWithCradle "Map" "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, containers, A]}}" $ do         doc <- createDoc "A.hs" "haskell" $ T.unlines             [ "{-# OPTIONS_GHC -Wunused-binds #-}",                 "module A () where",@@ -359,7 +376,7 @@               , "'Data.Map.Lazy"               , "'Data.Map.Strict"               ]-  , testSessionWait "no duplicates" $ do+  , testSessionEmpty "no duplicates" $ do         doc <- createDoc "A.hs" "haskell" $ T.unlines             [ "{-# OPTIONS_GHC -Wunused-binds #-}",                 "module A () where",@@ -381,7 +398,7 @@                 ) compls         liftIO $ length duplicate @?= 1 -  , testSessionWait "non-local before global" $ do+  , testSessionEmpty "non-local before global" $ do     -- non local completions are more specific         doc <- createDoc "A.hs" "haskell" $ T.unlines             [ "{-# OPTIONS_GHC -Wunused-binds #-}",@@ -402,9 +419,7 @@  projectCompletionTests :: [TestTree] projectCompletionTests =-    [ testSession' "from hiedb" $ \dir-> do-        liftIO $ writeFile (dir </> "hie.yaml")-            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}"+    [ testSessionEmptyWithCradle "from hiedb" "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" $ do         _ <- createDoc "A.hs" "haskell" $ T.unlines             [  "module A (anidentifier) where",                "anidentifier = ()"@@ -423,9 +438,7 @@               , _label == "anidentifier"               ]         liftIO $ compls' @?= ["Defined in 'A"],-      testSession' "auto complete project imports" $ \dir-> do-        liftIO $ writeFile (dir </> "hie.yaml")-            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}"+      testSessionEmptyWithCradle "auto complete project imports" "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}" $ do         _ <- createDoc "ALocalModule.hs" "haskell" $ T.unlines             [  "module ALocalModule (anidentifier) where",                "anidentifier = ()"@@ -440,9 +453,7 @@         let item = head $ filter ((== "ALocalModule") . (^. L.label)) compls         liftIO $ do           item ^. L.label @?= "ALocalModule",-      testSession' "auto complete functions from qualified imports without alias" $ \dir-> do-        liftIO $ writeFile (dir </> "hie.yaml")-            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}"+      testSessionEmptyWithCradle "auto complete functions from qualified imports without alias" "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" $ do         _ <- createDoc "A.hs" "haskell" $ T.unlines             [  "module A (anidentifier) where",                "anidentifier = ()"@@ -457,9 +468,8 @@         let item = head compls         liftIO $ do           item ^. L.label @?= "anidentifier",-      testSession' "auto complete functions from qualified imports with alias" $ \dir-> do-        liftIO $ writeFile (dir </> "hie.yaml")-            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}"+      testSessionEmptyWithCradle "auto complete functions from qualified imports with alias"+                  "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" $ do         _ <- createDoc "A.hs" "haskell" $ T.unlines             [  "module A (anidentifier) where",                "anidentifier = ()"@@ -478,7 +488,7 @@  completionDocTests :: [TestTree] completionDocTests =-  [ testSession "local define" $ do+  [ testSessionEmpty "local define" $ do       doc <- createDoc "A.hs" "haskell" $ T.unlines         [ "module A where"         , "foo = ()"@@ -486,14 +496,14 @@         ]       let expected = "*Defined at line 2, column 1 in this module*\n"       test doc (Position 2 8) "foo" Nothing [expected]-  , testSession "local empty doc" $ do+  , testSessionEmpty "local empty doc" $ do       doc <- createDoc "A.hs" "haskell" $ T.unlines         [ "module A where"         , "foo = ()"         , "bar = fo"         ]       test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"]-  , testSession "local single line doc without newline" $ do+  , testSessionEmpty "local single line doc without newline" $ do       doc <- createDoc "A.hs" "haskell" $ T.unlines         [ "module A where"         , "-- |docdoc"@@ -501,7 +511,7 @@         , "bar = fo"         ]       test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\n\n\ndocdoc\n"]-  , testSession "local multi line doc with newline" $ do+  , testSessionEmpty "local multi line doc with newline" $ do       doc <- createDoc "A.hs" "haskell" $ T.unlines         [ "module A where"         , "-- | abcabc"@@ -510,7 +520,7 @@         , "bar = fo"         ]       test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n\n\nabcabc\n"]-  , testSession "local multi line doc without newline" $ do+  , testSessionEmpty "local multi line doc without newline" $ do       doc <- createDoc "A.hs" "haskell" $ T.unlines         [ "module A where"         , "-- |     abcabc"@@ -520,28 +530,28 @@         , "bar = fo"         ]       test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n\n\nabcabc \n\ndef\n"]-  , testSession "extern empty doc" $ do+  , testSessionEmpty "extern empty doc" $ do       doc <- createDoc "A.hs" "haskell" $ T.unlines         [ "module A where"         , "foo = od"         ]       let expected = "*Imported from 'Prelude'*\n"       test doc (Position 1 8) "odd" (Just $ T.length expected) [expected]-  , brokenForMacGhc9 $ testSession "extern single line doc without '\\n'" $ do+  ,  testSessionEmpty "extern single line doc without '\\n'" $ do       doc <- createDoc "A.hs" "haskell" $ T.unlines         [ "module A where"         , "foo = no"         ]       let expected = "*Imported from 'Prelude'*\n* * *\n\n\nBoolean \"not\"\n"       test doc (Position 1 8) "not" (Just $ T.length expected) [expected]-  , brokenForMacGhc9 $ testSession "extern mulit line doc" $ do+  ,  testSessionEmpty "extern mulit line doc" $ do       doc <- createDoc "A.hs" "haskell" $ T.unlines         [ "module A where"         , "foo = i"         ]       let expected = "*Imported from 'Prelude'*\n* * *\n\n\nIdentity function. \n```haskell\nid x = x\n```\n"       test doc (Position 1 7) "id" (Just $ T.length expected) [expected]-  , testSession "extern defined doc" $ do+  , testSessionEmpty "extern defined doc" $ do       doc <- createDoc "A.hs" "haskell" $ T.unlines         [ "module A where"         , "foo = i"@@ -550,8 +560,6 @@       test doc (Position 1 7) "id" (Just $ T.length expected) [expected]   ]   where-    -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903-    brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC92, GHC94, GHC96]) "Extern doc doesn't support MacOS for ghc9"     test doc pos label mn expected = do       _ <- waitForDiagnostics       compls <- getCompletions doc pos
ghcide/test/exe/Config.hs view
@@ -1,10 +1,47 @@-module Config where-import           Ide.Types           (defaultPluginDescriptor)-import           System.FilePath     ((</>))-import           Test.Hls            (PluginTestDescriptor,-                                      mkPluginTestDescriptor)-import qualified Test.Hls.FileSystem as FS+{-# LANGUAGE PatternSynonyms #-} +module Config(+    -- * basic config for ghcIde testing+    mkIdeTestFs+    , dummyPlugin++    -- * runners for testing with dummy plugin+    , runWithDummyPlugin+    , testWithDummyPlugin+    , testWithDummyPluginEmpty+    , testWithDummyPlugin'+    , testWithDummyPluginEmpty'+    , testWithConfig+    , testWithExtraFiles+    , runWithExtraFiles+    , runInDir+    , run++    -- * utilities for testing+    , Expect(..)+    , pattern R+    , mkR+    , checkDefs+    , mkL+    , withLongTimeout+    , lspTestCaps+    , lspTestCapsNoFileWatches+    ) where++import           Control.Exception           (bracket_)+import           Control.Lens.Setter         ((.~))+import           Data.Foldable               (traverse_)+import           Data.Function               ((&))+import qualified Data.Text                   as T+import           Development.IDE.Test        (canonicalizeUri)+import           Ide.Types                   (defaultPluginDescriptor)+import qualified Language.LSP.Protocol.Lens  as L+import           Language.LSP.Protocol.Types (Null (..))+import           System.Environment.Blank    (setEnv, unsetEnv)+import           System.FilePath             ((</>))+import           Test.Hls+import qualified Test.Hls.FileSystem         as FS+ testDataDir :: FilePath testDataDir = "ghcide" </> "test" </> "data" @@ -13,4 +50,113 @@  -- * A dummy plugin for testing ghcIde dummyPlugin :: PluginTestDescriptor ()-dummyPlugin = mkPluginTestDescriptor (\_ pid ->defaultPluginDescriptor pid "dummyTestPlugin") "core"+dummyPlugin = mkPluginTestDescriptor (\_ pid -> defaultPluginDescriptor pid "dummyTestPlugin") "core"++runWithDummyPlugin ::  FS.VirtualFileTree -> Session a -> IO a+runWithDummyPlugin = runSessionWithServerInTmpDir def dummyPlugin++testWithConfig :: String -> TestConfig () -> Session () -> TestTree+testWithConfig name conf s = testCase name $ runSessionWithTestConfig conf $ const s++runWithDummyPlugin' ::  FS.VirtualFileTree -> (FilePath -> Session a) -> IO a+runWithDummyPlugin' fs = runSessionWithTestConfig def+    { testPluginDescriptor = dummyPlugin+    , testDirLocation = Right fs+    , testConfigCaps = lspTestCaps+    , testShiftRoot = True+    }++testWithDummyPlugin :: String -> FS.VirtualFileTree -> Session () -> TestTree+testWithDummyPlugin caseName vfs = testWithDummyPlugin' caseName vfs . const++testWithDummyPlugin' :: String -> FS.VirtualFileTree -> (FilePath -> Session ()) -> TestTree+testWithDummyPlugin' caseName vfs = testCase caseName . runWithDummyPlugin' vfs++testWithDummyPluginEmpty :: String -> Session () -> TestTree+testWithDummyPluginEmpty caseName = testWithDummyPlugin caseName $ mkIdeTestFs []++testWithDummyPluginEmpty' :: String -> (FilePath -> Session ()) -> TestTree+testWithDummyPluginEmpty' caseName = testWithDummyPlugin' caseName $ mkIdeTestFs []++runWithExtraFiles :: String -> (FilePath -> Session a) -> IO a+runWithExtraFiles dirName action = do+    let vfs = mkIdeTestFs [FS.copyDir dirName]+    runWithDummyPlugin' vfs action++testWithExtraFiles :: String -> String -> (FilePath -> Session ()) -> TestTree+testWithExtraFiles testName dirName action = testCase testName $ runWithExtraFiles dirName action++runInDir :: FilePath -> Session a -> IO a+runInDir fs = runSessionWithServer def dummyPlugin fs++run :: Session a -> IO a+run = runSessionWithTestConfig def+    { testDirLocation = Right (mkIdeTestFs [])+    , testPluginDescriptor = dummyPlugin }+    . const++pattern R :: UInt -> UInt -> UInt -> UInt -> Range+pattern R x y x' y' = Range (Position x y) (Position x' y')++data Expect+  = ExpectRange Range -- Both gotoDef and hover should report this range+  | ExpectLocation Location+--  | ExpectDefRange Range -- Only gotoDef should report this range+  | ExpectHoverRange Range -- Only hover should report this range+  | ExpectHoverText [T.Text] -- the hover message must contain these snippets+  | ExpectHoverExcludeText [T.Text] -- the hover message must _not_ contain these snippets+  | ExpectHoverTextRegex T.Text -- the hover message must match this pattern+  | ExpectExternFail -- definition lookup in other file expected to fail+  | ExpectNoDefinitions+  | ExpectNoHover+--  | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples+  deriving Eq++mkR :: UInt -> UInt -> UInt -> UInt -> Expect+mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn++mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect+mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn+++checkDefs :: Definition |? ([DefinitionLink] |? Null) -> Session [Expect] -> Session ()+checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpectations where+  check (ExpectRange expectedRange) = do+    def <- assertOneDefinitionFound defs+    assertRangeCorrect def expectedRange+  check (ExpectLocation expectedLocation) = do+    def <- assertOneDefinitionFound defs+    liftIO $ do+      canonActualLoc <- canonicalizeLocation def+      canonExpectedLoc <- canonicalizeLocation expectedLocation+      canonActualLoc @?= canonExpectedLoc+  check ExpectNoDefinitions = do+    liftIO $ assertBool "Expecting no definitions" $ null defs+  check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"+  check _ = pure () -- all other expectations not relevant to getDefinition++  assertOneDefinitionFound :: [Location] -> Session Location+  assertOneDefinitionFound [def] = pure def+  assertOneDefinitionFound xs = liftIO . assertFailure $ "Expecting exactly one definition, got " <> show (length xs)++  assertRangeCorrect Location{_range = foundRange} expectedRange =+    liftIO $ expectedRange @=? foundRange+++canonicalizeLocation :: Location -> IO Location+canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range++defToLocation :: Definition |? ([DefinitionLink] |? Null) -> [Location]+defToLocation (InL (Definition (InL l))) = [l]+defToLocation (InL (Definition (InR ls))) = ls+defToLocation (InR (InL defLink)) = (\(DefinitionLink LocationLink{_targetUri,_targetRange}) -> Location _targetUri _targetRange) <$> defLink+defToLocation (InR (InR Null)) = []++lspTestCaps :: ClientCapabilities+lspTestCaps = fullLatestClientCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing }++lspTestCapsNoFileWatches :: ClientCapabilities+lspTestCapsNoFileWatches = lspTestCaps & L.workspace . traverse . L.didChangeWatchedFiles .~ Nothing++withLongTimeout :: IO a -> IO a+withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT")
ghcide/test/exe/CradleTests.hs view
@@ -1,21 +1,25 @@ -{-# LANGUAGE GADTs            #-}-{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE GADTs #-}  module CradleTests (tests) where +import           Config                          (checkDefs, mkL, runInDir,+                                                  runWithExtraFiles,+                                                  testWithDummyPluginEmpty') import           Control.Applicative.Combinators+import           Control.Lens                    ((^.)) import           Control.Monad.IO.Class          (liftIO)-import           Data.Row import qualified Data.Text                       as T import           Development.IDE.GHC.Compat      (GhcVersion (..)) import           Development.IDE.GHC.Util+import           Development.IDE.Plugin.Test     (WaitForIdeRuleResult (..)) import           Development.IDE.Test            (expectDiagnostics,                                                   expectDiagnosticsWithTags,                                                   expectNoMoreDiagnostics,                                                   isReferenceReady,                                                   waitForAction) import           Development.IDE.Types.Location+import           GHC.TypeLits                    (symbolVal) import qualified Language.LSP.Protocol.Lens      as L import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types     hiding@@ -26,13 +30,9 @@ import           Language.LSP.Test import           System.FilePath import           System.IO.Extra                 hiding (withTempDir)--- import Test.QuickCheck.Instances ()-import           Control.Lens                    ((^.))-import           Development.IDE.Plugin.Test     (WaitForIdeRuleResult (..))-import           GHC.TypeLits                    (symbolVal)+import           Test.Hls                        (ignoreForGhcVersions) import           Test.Tasty import           Test.Tasty.HUnit-import           TestUtils   tests :: TestTree@@ -41,17 +41,17 @@     ,testGroup "ignore-fatal" [ignoreFatalWarning]     ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle]     ,testGroup "multi"   (multiTests "multi")-    ,ignoreFor (BrokenForGHC [GHC92]) "multiple units not supported on 9.2"+    ,ignoreForGhcVersions [GHC92] "multiple units not supported on 9.2"        $ testGroup "multi-unit" (multiTests "multi-unit")     ,testGroup "sub-directory"   [simpleSubDirectoryTest]-    ,ignoreFor (BrokenForGHC [GHC92]) "multiple units not supported on 9.2"+    ,ignoreForGhcVersions [GHC92] "multiple units not supported on 9.2"       $ testGroup "multi-unit-rexport" [multiRexportTest]     ]  loadCradleOnlyonce :: TestTree loadCradleOnlyonce = testGroup "load cradle only once"-    [ testSession' "implicit" implicit-    , testSession' "direct"   direct+    [ testWithDummyPluginEmpty' "implicit" implicit+    , testWithDummyPluginEmpty' "direct"   direct     ]     where         direct dir = do@@ -63,7 +63,7 @@             doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"             msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics))             liftIO $ length msgs @?= 1-            changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ "module B where\nimport Data.Maybe"]+            changeDoc doc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ "module B where\nimport Data.Maybe"]             msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics))             liftIO $ length msgs @?= 0             _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"@@ -71,7 +71,7 @@             liftIO $ length msgs @?= 0  retryFailedCradle :: TestTree-retryFailedCradle = testSession' "retry failed" $ \dir -> do+retryFailedCradle = testWithDummyPluginEmpty' "retry failed" $ \dir -> do   -- The false cradle always fails   let hieContents = "cradle: {bios: {shell: \"false\"}}"       hiePath = dir </> "hie.yaml"@@ -125,7 +125,7 @@ multiTestName dir name = "simple-" ++ dir ++ "-" ++ name  simpleMultiTest :: FilePath -> TestTree-simpleMultiTest variant = testCase (multiTestName variant "test") $ withLongTimeout $ runWithExtraFiles variant $ \dir -> do+simpleMultiTest variant = testCase (multiTestName variant "test") $ runWithExtraFiles variant $ \dir -> do     let aPath = dir </> "a/A.hs"         bPath = dir </> "b/B.hs"     adoc <- openDoc aPath "haskell"@@ -202,7 +202,7 @@     expectNoMoreDiagnostics 0.5  sessionDepsArePickedUp :: TestTree-sessionDepsArePickedUp = testSession'+sessionDepsArePickedUp = testWithDummyPluginEmpty'   "session-deps-are-picked-up"   $ \dir -> do     liftIO $@@ -222,9 +222,11 @@         [FileEvent (filePathToUri $ dir </> "hie.yaml") FileChangeType_Changed ]     -- Send change event.     let change =-          TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 4 0) (Position 4 0)-                                              .+ #rangeLength .== Nothing-                                              .+ #text .== "\n"+          TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial+              { _range = Range (Position 4 0) (Position 4 0)+              , _rangeLength = Nothing+              , _text = "\n"+              }     changeDoc doc [change]     -- Now no errors.     expectDiagnostics [("Foo.hs", [])]
ghcide/test/exe/DependentFileTest.hs view
@@ -1,11 +1,9 @@ -{-# LANGUAGE GADTs            #-}-{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE GADTs #-}  module DependentFileTest (tests) where -import           Control.Monad.IO.Class         (liftIO)-import           Data.Row+import           Config import qualified Data.Text                      as T import           Development.IDE.Test           (expectDiagnostics) import           Development.IDE.Types.Location@@ -16,19 +14,23 @@                                                  SemanticTokensEdit (..),                                                  mkRange) import           Language.LSP.Test-import           System.FilePath-import           Test.Tasty-import           TestUtils+import           Test.Hls + tests :: TestTree tests = testGroup "addDependentFile"-    [testGroup "file-changed" [testSession' "test" test]+    [testGroup "file-changed" [testCase "test" $ runSessionWithTestConfig def+        { testShiftRoot = True+        , testDirLocation = Right (mkIdeTestFs [])+        , testPluginDescriptor = dummyPlugin+        } test]     ]     where-      test dir = do+      test :: FilePath -> Session ()+      test _ = do         -- If the file contains B then no type error         -- otherwise type error-        let depFilePath = dir </> "dep-file.txt"+        let depFilePath = "dep-file.txt"         liftIO $ writeFile depFilePath "A"         let fooContent = T.unlines               [ "{-# LANGUAGE TemplateHaskell #-}"@@ -36,23 +38,25 @@               , "import Language.Haskell.TH.Syntax"               , "foo :: Int"               , "foo = 1 + $(do"-              , "               qAddDependentFile \"dep-file.txt\""-              , "               f <- qRunIO (readFile \"dep-file.txt\")"+              , "               qAddDependentFile \"" <> T.pack depFilePath <> "\""+              , "               f <- qRunIO (readFile \"" <> T.pack depFilePath <> "\")"               , "               if f == \"B\" then [| 1 |] else lift f)"               ]         let bazContent = T.unlines ["module Baz where", "import Foo ()"]-        _ <- createDoc "Foo.hs" "haskell" fooContent+        _fooDoc <- createDoc "Foo.hs" "haskell" fooContent         doc <- createDoc "Baz.hs" "haskell" bazContent         expectDiagnostics             [("Foo.hs", [(DiagnosticSeverity_Error, (4,11), "Couldn't match type")])]         -- Now modify the dependent file         liftIO $ writeFile depFilePath "B"         sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams-            [FileEvent (filePathToUri "dep-file.txt") FileChangeType_Changed ]+            [FileEvent (filePathToUri depFilePath) FileChangeType_Changed ]          -- Modifying Baz will now trigger Foo to be rebuilt as well-        let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 2 0) (Position 2 6)-                                                         .+ #rangeLength .== Nothing-                                                         .+ #text .== "f = ()"+        let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial+                { _range = Range (Position 2 0) (Position 2 6)+                , _rangeLength = Nothing+                , _text = "f = ()"+                }         changeDoc doc [change]         expectDiagnostics [("Foo.hs", [])]
ghcide/test/exe/DiagnosticTests.hs view
@@ -1,6 +1,5 @@ -{-# LANGUAGE GADTs            #-}-{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE GADTs #-}  module DiagnosticTests (tests) where @@ -9,7 +8,6 @@ import           Control.Monad import           Control.Monad.IO.Class          (liftIO) import           Data.List.Extra-import           Data.Row import qualified Data.Text                       as T import           Development.IDE.GHC.Compat      (GhcVersion (..), ghcVersion) import           Development.IDE.GHC.Util@@ -32,45 +30,56 @@ import           System.FilePath import           System.IO.Extra                 hiding (withTempDir) +import           Config import           Control.Lens                    ((^.)) import           Control.Monad.Extra             (whenJust)+import           Data.Default                    (def) import           Development.IDE.Plugin.Test     (WaitForIdeRuleResult (..)) import           System.Time.Extra+import           Test.Hls                        (TestConfig (testConfigCaps, testDirLocation, testDisableKick, testPluginDescriptor),+                                                  runSessionWithTestConfig,+                                                  waitForProgressBegin)+import           Test.Hls.FileSystem             (directCradle, file, text) import           Test.Tasty import           Test.Tasty.HUnit-import           TestUtils  tests :: TestTree tests = testGroup "diagnostics"-  [ testSessionWait "fix syntax error" $ do+  [ testWithDummyPluginEmpty "fix syntax error" $ do       let content = T.unlines [ "module Testing wher" ]       doc <- createDoc "Testing.hs" "haskell" content       expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error")])]-      let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 15) (Position 0 19)-                                                       .+ #rangeLength .== Nothing-                                                       .+ #text .== "where"+      let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial+              { _range = Range (Position 0 15) (Position 0 19)+              , _rangeLength = Nothing+              , _text = "where"+              }       changeDoc doc [change]       expectDiagnostics [("Testing.hs", [])]-  , testSessionWait "introduce syntax error" $ do+  , testWithDummyPluginEmpty "introduce syntax error" $ do       let content = T.unlines [ "module Testing where" ]       doc <- createDoc "Testing.hs" "haskell" content       void $ skipManyTill anyMessage (message SMethod_WindowWorkDoneProgressCreate)       waitForProgressBegin-      let change = TextDocumentContentChangeEvent$ InL $ #range .== Range (Position 0 15) (Position 0 18)-                                                      .+ #rangeLength .== Nothing-                                                      .+ #text .== "wher"+      let change = TextDocumentContentChangeEvent$ InL TextDocumentContentChangePartial+              { _range = Range (Position 0 15) (Position 0 18)+              , _rangeLength = Nothing+              , _text = "wher"+              }       changeDoc doc [change]       expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error")])]-  , testSessionWait "update syntax error" $ do+  , testWithDummyPluginEmpty "update syntax error" $ do       let content = T.unlines [ "module Testing(missing) where" ]       doc <- createDoc "Testing.hs" "haskell" content       expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'missing'")])]-      let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 15) (Position 0 16)-                                                       .+ #rangeLength .== Nothing-                                                       .+ #text .== "l"+      let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial+              { _range = Range (Position 0 15) (Position 0 16)+              , _rangeLength = Nothing+              , _text = "l"+              }       changeDoc doc [change]       expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'lissing'")])]-  , testSessionWait "variable not in scope" $ do+  , testWithDummyPluginEmpty "variable not in scope" $ do       let content = T.unlines             [ "module Testing where"             , "foo :: Int -> Int -> Int"@@ -86,7 +95,7 @@             ]           )         ]-  , testSessionWait "type error" $ do+  , testWithDummyPluginEmpty "type error" $ do       let content = T.unlines             [ "module Testing where"             , "foo :: Int -> String -> Int"@@ -98,7 +107,7 @@           , [(DiagnosticSeverity_Error, (2, 14), "Couldn't match type '[Char]' with 'Int'")]           )         ]-  , testSessionWait "typed hole" $ do+  , testWithDummyPluginEmpty "typed hole" $ do       let content = T.unlines             [ "module Testing where"             , "foo :: Int -> String"@@ -125,7 +134,7 @@         expectedDs aMessage =           [ ("A.hs", [(DiagnosticSeverity_Error, (2,4), aMessage)])           , ("B.hs", [(DiagnosticSeverity_Error, (3,4), bMessage)])]-        deferralTest title binding msg = testSessionWait title $ do+        deferralTest title binding msg = testWithDummyPluginEmpty title $ do           _ <- createDoc "A.hs" "haskell" $ sourceA binding           _ <- createDoc "B.hs" "haskell"   sourceB           expectDiagnostics $ expectedDs msg@@ -135,7 +144,7 @@     , deferralTest "out of scope var"    "unbound" "Variable not in scope"     ] -  , testSessionWait "remove required module" $ do+  , testWithDummyPluginEmpty "remove required module" $ do       let contentA = T.unlines [ "module ModuleA where" ]       docA <- createDoc "ModuleA.hs" "haskell" contentA       let contentB = T.unlines@@ -143,12 +152,14 @@             , "import ModuleA"             ]       _ <- createDoc "ModuleB.hs" "haskell" contentB-      let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 0) (Position 0 20)-                                                       .+ #rangeLength .== Nothing-                                                       .+ #text .== ""+      let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial+              { _range = Range (Position 0 0) (Position 0 20)+              , _rangeLength = Nothing+              , _text = ""+              }       changeDoc docA [change]       expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Error, (1, 0), "Could not find module")])]-  , testSessionWait "add missing module" $ do+  , testWithDummyPluginEmpty "add missing module" $ do       let contentB = T.unlines             [ "module ModuleB where"             , "import ModuleA ()"@@ -159,11 +170,16 @@       _ <- createDoc "ModuleA.hs" "haskell" contentA       expectDiagnostics [("ModuleB.hs", [])]   , testCase "add missing module (non workspace)" $+    runSessionWithTestConfig def+        { testPluginDescriptor = dummyPlugin+        , testConfigCaps = lspTestCapsNoFileWatches+        , testDirLocation = Right (mkIdeTestFs [])+        }+    $ \tmpDir -> do     -- By default lsp-test sends FileWatched notifications for all files, which we don't want     -- as non workspace modules will not be watched by the LSP server.     -- To work around this, we tell lsp-test that our client doesn't have the     -- FileWatched capability, which is enough to disable the notifications-    withTempDir $ \tmpDir -> runInDir'' lspTestCapsNoFileWatches tmpDir "." "." [] $ do       let contentB = T.unlines             [ "module ModuleB where"             , "import ModuleA ()"@@ -173,7 +189,7 @@       let contentA = T.unlines [ "module ModuleA where" ]       _ <- createDoc (tmpDir </> "ModuleA.hs") "haskell" contentA       expectDiagnostics [(tmpDir </> "ModuleB.hs", [])]-  , testSessionWait "cyclic module dependency" $ do+  , testWithDummyPluginEmpty "cyclic module dependency" $ do       let contentA = T.unlines             [ "module ModuleA where"             , "import ModuleB"@@ -192,28 +208,24 @@           , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]           )         ]-  , testSession' "deeply nested cyclic module dependency" $ \path -> do-      let contentA = unlines-            [ "module ModuleA where" , "import ModuleB" ]-      let contentB = unlines-            [ "module ModuleB where" , "import ModuleA" ]-      let contentC = unlines-            [ "module ModuleC where" , "import ModuleB" ]-      let contentD = T.unlines-            [ "module ModuleD where" , "import ModuleC" ]-          cradle =-            "cradle: {direct: {arguments: [ModuleA, ModuleB, ModuleC, ModuleD]}}"-      liftIO $ writeFile (path </> "ModuleA.hs") contentA-      liftIO $ writeFile (path </> "ModuleB.hs") contentB-      liftIO $ writeFile (path </> "ModuleC.hs") contentC-      liftIO $ writeFile (path </> "hie.yaml") cradle+  , let contentA = T.unlines [ "module ModuleA where" , "import ModuleB" ]+        contentB = T.unlines [ "module ModuleB where" , "import ModuleA" ]+        contentC = T.unlines [ "module ModuleC where" , "import ModuleB" ]+        contentD = T.unlines [ "module ModuleD where" , "import ModuleC" ]+        cradle = directCradle ["ModuleA", "ModuleB", "ModuleC", "ModuleD"]+    in testWithDummyPlugin "deeply nested cyclic module dependency"+        (mkIdeTestFs [+            file "ModuleA.hs" (text contentA)+            ,file "ModuleB.hs" (text contentB)+            ,file "ModuleC.hs" (text contentC)+            ,cradle+        ]) $ do       _ <- createDoc "ModuleD.hs" "haskell" contentD       expectDiagnostics-        [ ( "ModuleB.hs"-          , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]-          )+        [ ( "ModuleB.hs" , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")])+        , ( "ModuleA.hs" , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")])         ]-  , testSessionWait "cyclic module dependency with hs-boot" $ do+  , testWithDummyPluginEmpty "cyclic module dependency with hs-boot" $ do       let contentA = T.unlines             [ "module ModuleA where"             , "import {-# SOURCE #-} ModuleB"@@ -232,11 +244,9 @@       _ <- createDoc "ModuleB.hs" "haskell" contentB       _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot       expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])]-  , testSession' "bidirectional module dependency with hs-boot" $ \path -> do-      let cradle = unlines-            [ "cradle:"-            , "  direct: {arguments: [ModuleA, ModuleB]}"-            ]+  , testWithDummyPlugin "bidirectional module dependency with hs-boot"+        (mkIdeTestFs [directCradle ["ModuleA", "ModuleB"]])+        $ do       let contentA = T.unlines             [ "module ModuleA where"             , "import {-# SOURCE #-} ModuleB"@@ -254,13 +264,12 @@       let contentAboot = T.unlines             [ "module ModuleA where"             ]-      liftIO $ writeFile (path </> "hie.yaml") cradle       _ <- createDoc "ModuleA.hs" "haskell" contentA       _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot       _ <- createDoc "ModuleB.hs" "haskell" contentB       _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot       expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])]-  , testSessionWait "correct reference used with hs-boot" $ do+  , testWithDummyPluginEmpty "correct reference used with hs-boot" $ do       let contentB = T.unlines             [ "module ModuleB where"             , "import {-# SOURCE #-} ModuleA()"@@ -286,7 +295,7 @@       _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot       _ <- createDoc "ModuleC.hs" "haskell" contentC       expectDiagnostics [("ModuleC.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])]-  , testSessionWait "redundant import" $ do+  , testWithDummyPluginEmpty "redundant import" $ do       let contentA = T.unlines ["module ModuleA where"]       let contentB = T.unlines             [ "{-# OPTIONS_GHC -Wunused-imports #-}"@@ -300,7 +309,7 @@           , [(DiagnosticSeverity_Warning, (2, 0), "The import of 'ModuleA' is redundant", Just DiagnosticTag_Unnecessary)]           )         ]-  , testSessionWait "redundant import even without warning" $ do+  , testWithDummyPluginEmpty "redundant import even without warning" $ do       let contentA = T.unlines ["module ModuleA where"]       let contentB = T.unlines             [ "{-# OPTIONS_GHC -Wno-unused-imports -Wmissing-signatures #-}"@@ -312,7 +321,7 @@       _ <- createDoc "ModuleA.hs" "haskell" contentA       _ <- createDoc "ModuleB.hs" "haskell" contentB       expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])]-  , testSessionWait "package imports" $ do+  , testWithDummyPluginEmpty "package imports" $ do       let thisDataListContent = T.unlines             [ "module Data.List where"             , "x :: Integer"@@ -350,7 +359,7 @@             ]           )         ]-  , testSessionWait "unqualified warnings" $ do+  , testWithDummyPluginEmpty "unqualified warnings" $ do       let fooContent = T.unlines             [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"             , "module Foo where"@@ -368,7 +377,7 @@             ]           )         ]-    , testSessionWait "lower-case drive" $ do+    , testWithDummyPluginEmpty "lower-case drive" $ do           let aContent = T.unlines                 [ "module A.A where"                 , "import A.B ()"@@ -397,11 +406,11 @@           -- Check that if we put a lower-case drive in for A.A           -- the diagnostics for A.B will also be lower-case.           liftIO $ fileUri @?= uriB-          let msg :: T.Text = (head diags) ^. L.message+          let msg :: T.Text = head diags ^. L.message           liftIO $ unless ("redundant" `T.isInfixOf` msg) $               assertFailure ("Expected redundant import but got " <> T.unpack msg)           closeDoc a-  , testSessionWait "strip file path" $ do+  , testWithDummyPluginEmpty "strip file path" $ do       let           name = "Testing"           content = T.unlines@@ -420,9 +429,9 @@             Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:"))           failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg       Lens.mapMOf_ offenders failure notification-  , testSession' "-Werror in cradle is ignored" $ \sessionDir -> do-      liftIO $ writeFile (sessionDir </> "hie.yaml")-        "cradle: {direct: {arguments: [\"-Wall\", \"-Werror\"]}}"+  , testWithDummyPlugin "-Werror in cradle is ignored"+        (mkIdeTestFs [directCradle ["-Wall", "-Werror"]])+        $ do       let fooContent = T.unlines             [ "module Foo where"             , "foo = ()"@@ -434,7 +443,7 @@             ]           )         ]-  , testSessionWait "-Werror in pragma is ignored" $ do+  , testWithDummyPluginEmpty "-Werror in pragma is ignored" $ do       let fooContent = T.unlines             [ "{-# OPTIONS_GHC -Wall -Werror #-}"             , "module Foo() where"@@ -463,7 +472,7 @@       [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So that we know P has been loaded      -- Change y from Int to B which introduces a type error in A (imported from P)-    changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $+    changeDoc bdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $                     T.unlines ["module B where", "y :: Bool", "y = undefined"]]     expectDiagnostics       [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])@@ -471,7 +480,7 @@      -- Open A and edit to fix the type error     adoc <- createDoc aPath "haskell" aSource-    changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $+    changeDoc adoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $                     T.unlines ["module A where", "import B", "x :: Bool", "x = y"]]      expectDiagnostics@@ -484,15 +493,15 @@       ]     expectNoMoreDiagnostics 1 -  , testSessionWait "deduplicate missing module diagnostics" $  do+  , testWithDummyPluginEmpty "deduplicate missing module diagnostics" $  do       let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ]       doc <- createDoc "Foo.hs" "haskell" fooContent       expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'")])] -      changeDoc doc [TextDocumentContentChangeEvent  . InR . (.==) #text $ "module Foo() where" ]+      changeDoc doc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ "module Foo() where" ]       expectDiagnostics [] -      changeDoc doc [TextDocumentContentChangeEvent  . InR . (.==) #text $ T.unlines+      changeDoc doc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ T.unlines             [ "module Foo() where" , "import MissingModule" ] ]       expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'")])] @@ -504,12 +513,18 @@   ]   where       editPair x y = let p = Position x y ; p' = Position x (y+2) in-        (TextDocumentContentChangeEvent $ InL $ #range .== Range p p-                                             .+ #rangeLength .== Nothing-                                             .+ #text .== "fd"-        ,TextDocumentContentChangeEvent $ InL $ #range .== Range p p'-                                             .+ #rangeLength .== Nothing-                                             .+ #text .== "")+        (TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial+              { _range = Range p p+              , _rangeLength = Nothing+              , _text = "fd"+              }++        ,TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial+              { _range = Range p p'+              , _rangeLength = Nothing+              , _text = ""+              }+        )       editHeader = editPair 0 0       editImport = editPair 2 10       editBody   = editPair 3 10@@ -565,8 +580,12 @@        expectNoMoreDiagnostics 0.5     where-        -- similar to run except it disables kick-        runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s+        runTestNoKick s =+            runSessionWithTestConfig def+                { testPluginDescriptor = dummyPlugin+                , testDirLocation = Right (mkIdeTestFs [])+                , testDisableKick = True+                } $ const s          typeCheck doc = do             WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
ghcide/test/exe/ExceptionTests.hs view
@@ -7,20 +7,17 @@ import           Control.Monad.Error.Class         (MonadError (throwError)) import           Control.Monad.IO.Class            (liftIO) import qualified Data.Aeson                        as A+import           Data.Default                      (Default (..)) import           Data.Text                         as T import           Development.IDE.Core.Shake        (IdeState (..)) import qualified Development.IDE.LSP.Notifications as Notifications-import qualified Development.IDE.Main              as IDE import           Development.IDE.Plugin.HLS        (toResponseError)-import           Development.IDE.Plugin.Test       as Test-import           Development.IDE.Types.Options import           GHC.Base                          (coerce) import           Ide.Logger                        (Recorder, WithPriority,                                                     cmapWithPrio) import           Ide.Plugin.Error import           Ide.Plugin.HandleRequestTypes     (RejectionReason (DisabledGlobally))-import           Ide.PluginUtils                   (idePluginsToPluginDesc,-                                                    pluginDescToIdePlugins)+import           Ide.PluginUtils                   (pluginDescToIdePlugins) import           Ide.Types import qualified Language.LSP.Protocol.Lens        as L import           Language.LSP.Protocol.Message@@ -31,30 +28,34 @@                                                     mkRange) import           Language.LSP.Test import           LogType                           (Log (..))+import           Test.Hls                          (TestConfig (testDisableDefaultPlugin, testPluginDescriptor),+                                                    runSessionWithTestConfig,+                                                    testCheckProject,+                                                    waitForProgressDone) import           Test.Tasty import           Test.Tasty.HUnit-import           TestUtils -tests :: Recorder (WithPriority Log) -> TestTree-tests recorder = do+tests :: TestTree+tests = do   testGroup "Exceptions and PluginError" [     testGroup "Testing that IO Exceptions are caught in..."       [ testCase "PluginHandlers" $ do           let pluginId = "plugin-handler-exception"-              plugins = pluginDescToIdePlugins $+              plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState+              plugins r = pluginDescToIdePlugins $                   [ (defaultPluginDescriptor pluginId "")                       { pluginHandlers = mconcat                           [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do                               _ <- liftIO $ throwIO DivideByZero                               pure (InL [])                           ]-                      }]-          testIde recorder (testingLite recorder plugins) $ do+                      }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"]+          runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False+          } $ const $ do               doc <- createDoc "A.hs" "haskell" "module A where"-              waitForProgressDone               (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)               case lens of-                Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) ->+                Left (TResponseError {_code = InR ErrorCodes_InternalError, _message}) ->                     liftIO $ assertBool "We caught an error, but it wasn't ours!"                           (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message)                 _ -> liftIO $ assertFailure $ show lens@@ -62,29 +63,31 @@         , testCase "Commands" $ do           let pluginId = "command-exception"               commandId = CommandId "exception"-              plugins = pluginDescToIdePlugins $+              plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState+              plugins r = pluginDescToIdePlugins $                   [ (defaultPluginDescriptor pluginId "")                       { pluginCommands =                           [ PluginCommand commandId "Causes an exception" $ \_ _ (_::Int) -> do                               _ <- liftIO $ throwIO DivideByZero                               pure (InR Null)                           ]-                      }]-          testIde recorder (testingLite recorder plugins) $ do+                      }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"]+          runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False} $ const $ do               _ <- createDoc "A.hs" "haskell" "module A where"               waitForProgressDone               let cmd = mkLspCommand (coerce pluginId) commandId "" (Just [A.toJSON (1::Int)])                   execParams = ExecuteCommandParams Nothing (cmd ^. L.command) (cmd ^. L.arguments)               (view L.result -> res) <- request SMethod_WorkspaceExecuteCommand execParams               case res of-                Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) ->+                Left (TResponseError {_code = InR ErrorCodes_InternalError, _message}) ->                   liftIO $ assertBool "We caught an error, but it wasn't ours!"                           (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message)                 _ -> liftIO $ assertFailure $ show res          , testCase "Notification Handlers" $ do           let pluginId = "notification-exception"-              plugins = pluginDescToIdePlugins $+              plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState+              plugins r = pluginDescToIdePlugins $                   [ (defaultPluginDescriptor pluginId "")                       { pluginNotificationHandlers = mconcat                           [  mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ ->@@ -94,8 +97,8 @@                           [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do                               pure (InL [])                           ]-                      }]-          testIde recorder (testingLite recorder plugins) $ do+                        }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"]+          runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False} $ const $ do               doc <- createDoc "A.hs" "haskell" "module A where"               waitForProgressDone               (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)@@ -107,37 +110,18 @@                 _ -> liftIO $ assertFailure $ "We should have had an empty list" <> show lens]     , testGroup "Testing PluginError order..."-      [ pluginOrderTestCase recorder "InternalError over InvalidParams" (PluginInternalError "error test") (PluginInvalidParams "error test")-      , pluginOrderTestCase recorder "InvalidParams over InvalidUserState" (PluginInvalidParams "error test") (PluginInvalidUserState "error test")-      , pluginOrderTestCase recorder "InvalidUserState over RequestRefused" (PluginInvalidUserState "error test") (PluginRequestRefused DisabledGlobally)+      [ pluginOrderTestCase "InternalError over InvalidParams" (PluginInternalError "error test") (PluginInvalidParams "error test")+      , pluginOrderTestCase "InvalidParams over InvalidUserState" (PluginInvalidParams "error test") (PluginInvalidUserState "error test")+      , pluginOrderTestCase "InvalidUserState over RequestRefused" (PluginInvalidUserState "error test") (PluginRequestRefused DisabledGlobally)       ]    ] -testingLite :: Recorder (WithPriority Log) -> IdePlugins IdeState -> IDE.Arguments-testingLite recorder plugins =-  let-    arguments@IDE.Arguments{ argsIdeOptions } =-        IDE.defaultArguments (cmapWithPrio LogIDEMain recorder) plugins-    hlsPlugins = pluginDescToIdePlugins $-      idePluginsToPluginDesc plugins-      ++ [Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"]-      ++ [Test.blockCommandDescriptor "block-command", Test.plugin]-    ideOptions config sessionLoader =-      let-        defOptions = argsIdeOptions config sessionLoader-      in-        defOptions{ optTesting = IdeTesting True }-  in-    arguments-      { IDE.argsHlsPlugins = hlsPlugins-      , IDE.argsIdeOptions = ideOptions-      }--pluginOrderTestCase :: Recorder (WithPriority Log) -> TestName -> PluginError -> PluginError -> TestTree-pluginOrderTestCase recorder msg err1 err2 =+pluginOrderTestCase :: TestName -> PluginError -> PluginError -> TestTree+pluginOrderTestCase msg err1 err2 =   testCase msg $ do       let pluginId = "error-order-test"-          plugins = pluginDescToIdePlugins $+          plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState+          plugins r = pluginDescToIdePlugins $               [ (defaultPluginDescriptor pluginId "")                   { pluginHandlers = mconcat                       [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do@@ -145,8 +129,8 @@                         ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do                           throwError err2                       ]-                  }]-      testIde recorder (testingLite recorder plugins) $ do+                  }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"]+      runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False} $ const $ do           doc <- createDoc "A.hs" "haskell" "module A where"           waitForProgressDone           (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
ghcide/test/exe/FindDefinitionAndHoverTests.hs view
@@ -1,56 +1,42 @@+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE ViewPatterns       #-}  module FindDefinitionAndHoverTests (tests) where  import           Control.Monad-import           Control.Monad.IO.Class         (liftIO) import           Data.Foldable import           Data.Maybe-import qualified Data.Text                      as T-import           Development.IDE.GHC.Compat     (GhcVersion (..), ghcVersion)-import           Development.IDE.GHC.Util-import           Development.IDE.Test           (expectDiagnostics,-                                                 standardizeQuotes)-import           Development.IDE.Types.Location-import qualified Language.LSP.Protocol.Lens     as L-import           Language.LSP.Protocol.Types    hiding-                                                (SemanticTokenAbsolute (..),-                                                 SemanticTokenRelative (..),-                                                 SemanticTokensEdit (..),-                                                 mkRange)+import qualified Data.Text                  as T+import qualified Language.LSP.Protocol.Lens as L import           Language.LSP.Test-import           System.FilePath-import           System.Info.Extra              (isWindows)+import           System.Info.Extra          (isWindows) -import           Control.Lens                   ((^.))-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils-import           Text.Regex.TDFA                ((=~))+import           Config+import           Control.Lens               ((^.))+import           Development.IDE.Test       (expectDiagnostics,+                                             standardizeQuotes)+import           Test.Hls+import           Test.Hls.FileSystem        (copyDir)+import           Text.Regex.TDFA            ((=~))  tests :: TestTree tests = let-   tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree-  tst (get, check) pos sfp targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do--    -- Dirty the cache to check that definitions work even in the presence of iface files-    liftIO $ runInDir dir $ do-      let fooPath = dir </> "Foo.hs"-      fooSource <- liftIO $ readFileUtf8 fooPath-      fooDoc <- createDoc fooPath "haskell" fooSource-      _ <- getHover fooDoc $ Position 4 3-      closeDoc fooDoc--    doc <- openTestDataDoc (dir </> sfp)-    waitForProgressDone-    found <- get doc pos-    check found targetRange+  tst (get, check) pos sfp targetRange title =+    testWithDummyPlugin title (mkIdeTestFs [copyDir "hover"]) $ do+        doc <- openDoc sfp "haskell"+        waitForProgressDone+        _x <- waitForTypecheck doc+        found <- get doc pos+        check found targetRange   -  checkHover :: Maybe Hover -> Session [Expect] -> Session ()+  checkHover :: (HasCallStack) => Maybe Hover -> Session [Expect] -> Session ()   checkHover hover expectations = traverse_ check =<< expectations where +    check :: (HasCallStack) => Expect -> Session ()     check expected =       case hover of         Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"@@ -100,11 +86,11 @@   mkFindTests tests = testGroup "get"     [ testGroup "definition" $ mapMaybe fst tests     , testGroup "hover"      $ mapMaybe snd tests-    , checkFileCompiles sourceFilePath $+    , testGroup "hover compile" [checkFileCompiles sourceFilePath $         expectDiagnostics           [ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _")])           , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _")])-          ]+          ]]     , testGroup "type-definition" typeDefinitionTests     , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ] @@ -117,8 +103,15 @@     , tst (getHover, checkHover) (Position 17 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child"     ] +  test :: (HasCallStack) => (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b)   test runDef runHover look expect = testM runDef runHover look (return expect) +  testM :: (HasCallStack) => (TestTree -> a)+    -> (TestTree -> b)+    -> Position+    -> Session [Expect]+    -> String+    -> (a, b)   testM runDef runHover look expect title =     ( runDef   $ tst def   look sourceFilePath expect title     , runHover $ tst hover look sourceFilePath expect title ) where@@ -133,17 +126,17 @@   aaaL14 = Position 18 20  ;  aaa    = [mkR  11  0   11  3]   dcL7   = Position 11 11  ;  tcDC   = [mkR   7 23    9 16]   dcL12  = Position 16 11  ;-  xtcL5  = Position  9 11  ;  xtc    = [ExpectExternFail,   ExpectHoverText ["Int", "Defined in ", "GHC.Types", "ghc-prim"]]+  xtcL5  = Position  9 11  ;  xtc    = [ExpectHoverText ["Int", "Defined in ", "GHC.Types", "ghc-prim"]]   tcL6   = Position 10 11  ;  tcData = [mkR   7  0    9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]]   vvL16  = Position 20 12  ;  vv     = [mkR  20  4   20  6]   opL16  = Position 20 15  ;  op     = [mkR  21  2   21  4]   opL18  = Position 22 22  ;  opp    = [mkR  22 13   22 17]   aL18   = Position 22 20  ;  apmp   = [mkR  22 10   22 11]   b'L19  = Position 23 13  ;  bp     = [mkR  23  6   23  7]-  xvL20  = Position 24  8  ;  xvMsg  = [ExpectExternFail,   ExpectHoverText ["pack", ":: String -> Text", "Data.Text", "text"]]+  xvL20  = Position 24  8  ;  xvMsg  = [ExpectHoverText ["pack", ":: String -> Text", "Data.Text", "text"]]   clL23  = Position 27 11  ;  cls    = [mkR  25  0   26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]]   clL25  = Position 29  9-  eclL15 = Position 19  8  ;  ecls   = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num", "base"]]+  eclL15 = Position 19  8  ;  ecls   = [ExpectHoverText ["Num", "Defined in ", if ghcVersion < GHC910 then "GHC.Num" else "GHC.Internal.Num", "base"]]   dnbL29 = Position 33 18  ;  dnb    = [ExpectHoverText [":: ()"],   mkR  33 12   33 21]   dnbL30 = Position 34 23   lcbL33 = Position 37 26  ;  lcb    = [ExpectHoverText [":: Char"], mkR  37 26   37 27]@@ -166,7 +159,7 @@   holeL65 = Position 65 8  ;  hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]]   cccL17 = Position 17 16  ;  docLink = [ExpectHoverTextRegex "\\*Defined in 'GHC.Types'\\* \\*\\(ghc-prim-[0-9.]+\\)\\*\n\n"]   imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3]-  reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 (if ghcVersion >= GHC94 then 5 else 0) 3 (if ghcVersion >= GHC94 then 8 else 14)]+  reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], if ghcVersion >= GHC94 && ghcVersion < GHC910 then mkL bar 3 5 3 8 else mkL bar 3 0 3 14]   thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]]   cmtL68 = Position 67  0  ;  lackOfdEq = [ExpectHoverExcludeText ["$dEq"]]   import310 = Position 3 10; pkgTxt = [ExpectHoverText ["Data.Text\n\ntext-"]]@@ -181,8 +174,8 @@   , test  yes    yes    dcL7       tcDC          "data constructor record         #1029"   , test  yes    yes    dcL12      tcDC          "data constructor plain"                -- https://github.com/haskell/ghcide/pull/121   , test  yes    yes    tcL6       tcData        "type constructor                #1028" -- https://github.com/haskell/ghcide/pull/147-  , test  broken yes    xtcL5      xtc           "type constructor external   #717,1028"-  , test  broken yes    xvL20      xvMsg         "value external package           #717" -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    xtcL5      xtc           "type constructor external   #717,1028"+  , test  yes    yes    xvL20      xvMsg         "value external package           #717" -- https://github.com/haskell/ghcide/pull/120   , test  yes    yes    vvL16      vv            "plain parameter"                       -- https://github.com/haskell/ghcide/pull/120   , test  yes    yes    aL18       apmp          "pattern match name"                    -- https://github.com/haskell/ghcide/pull/120   , test  yes    yes    opL16      op            "top-level operator               #713" -- https://github.com/haskell/ghcide/pull/120@@ -190,7 +183,7 @@   , test  yes    yes    b'L19      bp            "name in backticks"                     -- https://github.com/haskell/ghcide/pull/120   , test  yes    yes    clL23      cls           "class in instance declaration   #1027"   , test  yes    yes    clL25      cls           "class in signature              #1027" -- https://github.com/haskell/ghcide/pull/147-  , test  broken yes    eclL15     ecls          "external class in signature #717,1027"+  , test  yes    yes    eclL15     ecls          "external class in signature #717,1027"   , test  yes    yes    dnbL29     dnb           "do-notation   bind              #1073"   , test  yes    yes    dnbL30     dnb           "do-notation lookup"   , test  yes    yes    lcbL33     lcb           "listcomp   bind                 #1073"@@ -228,8 +221,11 @@         no = const Nothing -- don't run this test at all         --skip = const Nothing -- unreliable, don't run +xfail :: TestTree -> String -> TestTree+xfail = flip expectFailBecause+ checkFileCompiles :: FilePath -> Session () -> TestTree checkFileCompiles fp diag =-  testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do-    void (openTestDataDoc (dir </> fp))+   testWithDummyPlugin ("hover: Does " ++ fp ++ " compile") (mkIdeTestFs [copyDir "hover"]) $ do+    _ <- openDoc fp "haskell"     diag
ghcide/test/exe/GarbageCollectionTests.hs view
@@ -1,10 +1,7 @@--{-# LANGUAGE OverloadedLabels #-}- module GarbageCollectionTests (tests) where +import           Config                      (testWithDummyPluginEmpty') import           Control.Monad.IO.Class      (liftIO)-import           Data.Row import qualified Data.Set                    as Set import qualified Data.Text                   as T import           Development.IDE.Test        (expectCurrentDiagnostics,@@ -15,23 +12,21 @@                                               SemanticTokensEdit (..), mkRange) import           Language.LSP.Test import           System.FilePath--- import Test.QuickCheck.Instances () import           Test.Tasty import           Test.Tasty.HUnit-import           TestUtils import           Text.Printf                 (printf)  tests :: TestTree tests = testGroup "garbage collection"   [ testGroup "dirty keys"-        [ testSession' "are collected" $ \dir -> do+        [ testWithDummyPluginEmpty' "are collected" $ \dir -> do             liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"             doc <- generateGarbage "A" dir             closeDoc doc             garbage <- waitForGC             liftIO $ assertBool "no garbage was found" $ not $ null garbage -        , testSession' "are deleted from the state" $ \dir -> do+        , testWithDummyPluginEmpty' "are deleted from the state" $ \dir -> do             liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"             docA <- generateGarbage "A" dir             keys0 <- getStoredKeys@@ -41,7 +36,7 @@             keys1 <- getStoredKeys             liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0) -        , testSession' "are not regenerated unless needed" $ \dir -> do+        , testWithDummyPluginEmpty' "are not regenerated unless needed" $ \dir -> do             liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}"             docA <- generateGarbage "A" dir             _docB <- generateGarbage "B" dir@@ -62,7 +57,7 @@                     Set.intersection (Set.fromList garbage) (Set.fromList keysB)             liftIO $ regeneratedKeys @?= mempty -        , testSession' "regenerate successfully" $ \dir -> do+        , testWithDummyPluginEmpty' "regenerate successfully" $ \dir -> do             liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"             docA <- generateGarbage "A" dir             closeDoc docA@@ -74,14 +69,14 @@                         , "a = ()"                         ]             doc <- generateGarbage "A" dir-            changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ edit]+            changeDoc doc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument edit]             builds <- waitForTypecheck doc             liftIO $ assertBool "it still builds" builds             expectCurrentDiagnostics doc [(DiagnosticSeverity_Error, (2,4), "Couldn't match expected type")]         ]   ]   where-    isExpected k = any (`T.isPrefixOf` k) ["GhcSessionIO"]+    isExpected k = "GhcSessionIO" `T.isPrefixOf` k      generateGarbage :: String -> FilePath -> Session TextDocumentIdentifier     generateGarbage modName dir = do
ghcide/test/exe/HighlightTests.hs view
@@ -1,9 +1,9 @@  module HighlightTests (tests) where +import           Config import           Control.Monad.IO.Class         (liftIO) import qualified Data.Text                      as T-import           Development.IDE.GHC.Compat     (GhcVersion (..)) import           Development.IDE.Types.Location import           Language.LSP.Protocol.Types    hiding                                                 (SemanticTokenAbsolute (..),@@ -13,11 +13,10 @@ import           Language.LSP.Test import           Test.Tasty import           Test.Tasty.HUnit-import           TestUtils  tests :: TestTree tests = testGroup "highlight"-  [ testSessionWait "value" $ do+  [ testWithDummyPluginEmpty "value" $ do     doc <- createDoc "A.hs" "haskell" source     _ <- waitForDiagnostics     highlights <- getHighlights doc (Position 3 2)@@ -27,7 +26,7 @@             , DocumentHighlight (R 4 6 4 9) (Just DocumentHighlightKind_Read)             , DocumentHighlight (R 5 22 5 25) (Just DocumentHighlightKind_Read)             ]-  , testSessionWait "type" $ do+  , testWithDummyPluginEmpty "type" $ do     doc <- createDoc "A.hs" "haskell" source     _ <- waitForDiagnostics     highlights <- getHighlights doc (Position 2 8)@@ -35,7 +34,7 @@             [ DocumentHighlight (R 2 7 2 10) (Just DocumentHighlightKind_Read)             , DocumentHighlight (R 3 11 3 14) (Just DocumentHighlightKind_Read)             ]-  , testSessionWait "local" $ do+  , testWithDummyPluginEmpty "local" $ do     doc <- createDoc "A.hs" "haskell" source     _ <- waitForDiagnostics     highlights <- getHighlights doc (Position 6 5)@@ -44,8 +43,8 @@             , DocumentHighlight (R 6 10 6 13) (Just DocumentHighlightKind_Read)             , DocumentHighlight (R 7 12 7 15) (Just DocumentHighlightKind_Read)             ]-  , knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "Ghc9 highlights the constructor and not just this field" $-        testSessionWait "record" $ do+  ,+        testWithDummyPluginEmpty "record" $ do         doc <- createDoc "A.hs" "haskell" recsource         _ <- waitForDiagnostics         highlights <- getHighlights doc (Position 4 15)
ghcide/test/exe/IfaceTests.hs view
@@ -1,10 +1,7 @@--{-# LANGUAGE OverloadedLabels #-}- module IfaceTests (tests) where +import           Config import           Control.Monad.IO.Class        (liftIO)-import           Data.Row import qualified Data.Text                     as T import           Development.IDE.GHC.Util import           Development.IDE.Test          (configureCheckProject,@@ -23,7 +20,6 @@ import           System.IO.Extra               hiding (withTempDir) import           Test.Tasty import           Test.Tasty.HUnit-import           TestUtils  tests :: TestTree tests = testGroup "Interface loading tests"@@ -37,7 +33,7 @@  -- | test that TH reevaluates across interfaces ifaceTHTest :: TestTree-ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do+ifaceTHTest = testWithExtraFiles "iface-th-test" "TH" $ \dir -> do     let aPath = dir </> "THA.hs"         bPath = dir </> "THB.hs"         cPath = dir </> "THC.hs"@@ -52,14 +48,14 @@     liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"])      -- Check that the change propagates to C-    changeDoc cdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ cSource]+    changeDoc cdoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument cSource]     expectDiagnostics       [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")])       ,("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding")])]     closeDoc cdoc  ifaceErrorTest :: TestTree-ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do+ifaceErrorTest = testWithExtraFiles "iface-error-test-1" "recomp" $ \dir -> do     configureCheckProject True     let bPath = dir </> "B.hs"         pPath = dir </> "P.hs"@@ -72,7 +68,9 @@       [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So what we know P has been loaded      -- Change y from Int to B-    changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]+    changeDoc bdoc [ TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $+                        T.unlines [ "module B where", "y :: Bool", "y = undefined"]+                   ]     -- save so that we can that the error propagates to A     sendNotification SMethod_TextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing) @@ -90,7 +88,7 @@     expectDiagnostics       [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])       ]-    changeDoc pdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ pSource <> "\nfoo = y :: Bool" ]+    changeDoc pdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ pSource <> "\nfoo = y :: Bool" ]     -- Now in P we have     -- bar = x :: Int     -- foo = y :: Bool@@ -106,7 +104,7 @@     expectNoMoreDiagnostics 2  ifaceErrorTest2 :: TestTree-ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \dir -> do+ifaceErrorTest2 = testWithExtraFiles "iface-error-test-2" "recomp" $ \dir -> do     let bPath = dir </> "B.hs"         pPath = dir </> "P.hs" @@ -119,10 +117,11 @@       [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So that we know P has been loaded      -- Change y from Int to B-    changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]+    changeDoc bdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $+        T.unlines ["module B where", "y :: Bool", "y = undefined"]]      -- Add a new definition to P-    changeDoc pdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ pSource <> "\nfoo = y :: Bool" ]+    changeDoc pdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ pSource <> "\nfoo = y :: Bool" ]     -- Now in P we have     -- bar = x :: Int     -- foo = y :: Bool@@ -139,7 +138,7 @@     expectNoMoreDiagnostics 2  ifaceErrorTest3 :: TestTree-ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \dir -> do+ifaceErrorTest3 = testWithExtraFiles "iface-error-test-3" "recomp" $ \dir -> do     let bPath = dir </> "B.hs"         pPath = dir </> "P.hs" @@ -149,7 +148,7 @@     bdoc <- createDoc bPath "haskell" bSource      -- Change y from Int to B-    changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]+    changeDoc bdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]      -- P should not typecheck, as there are no last valid artifacts for A     _pdoc <- createDoc pPath "haskell" pSource
ghcide/test/exe/InitializeResponseTests.hs view
@@ -1,19 +1,17 @@ -{-# LANGUAGE DataKinds        #-}-{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE DataKinds #-}  module InitializeResponseTests (tests) where  import           Control.Monad import           Data.List.Extra-import           Data.Row import qualified Data.Text                         as T import           Development.IDE.Plugin.TypeLenses (typeLensCommandId) import qualified Language.LSP.Protocol.Lens        as L import           Language.LSP.Protocol.Message import           Language.LSP.Test -import           Config                            (dummyPlugin, mkIdeTestFs)+import           Config import           Control.Lens                      ((^.)) import           Development.IDE.Plugin.Test       (blockCommandId) import           Test.Hls@@ -54,8 +52,13 @@     , chk "NO color"                   (^. L.colorProvider) Nothing     , chk "NO folding range"          _foldingRangeProvider Nothing     , che "   execute command"      _executeCommandProvider [typeLensCommandId, blockCommandId]-    , chk "   workspace"                   (^. L.workspace) (Just $ #workspaceFolders .== Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )}-                                                                 .+ #fileOperations   .== Nothing)+    , chk "   workspace"                   (^. L.workspace) (Just $ WorkspaceOptions+                                                                      { _workspaceFolders = Just WorkspaceFoldersServerCapabilities+                                                                           { _supported = Just True+                                                                           , _changeNotifications = Just (InR True)+                                                                           }+                                                                      , _fileOperations = Nothing+                                                                      })     , chk "NO experimental"             (^. L.experimental) Nothing     ] where @@ -84,7 +87,7 @@   innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error"    acquire :: IO (TResponseMessage Method_Initialize)-  acquire = runSessionWithServerInTmpDir def dummyPlugin (mkIdeTestFs []) initializeResponse+  acquire = run initializeResponse    release :: TResponseMessage Method_Initialize -> IO ()   release = mempty
ghcide/test/exe/Main.hs view
@@ -29,15 +29,8 @@   module Main (main) where--- import Test.QuickCheck.Instances ()-import           Data.Function                ((&))+ import qualified HieDbRetry-import           Ide.Logger                   (LoggingColumn (DataColumn, PriorityColumn),-                                               Pretty (pretty),-                                               Priority (Debug),-                                               WithPriority (WithPriority, priority),-                                               cfilter, cmapWithPrio,-                                               makeDefaultStderrRecorder) import           Test.Tasty import           Test.Tasty.Ingredients.Rerun @@ -74,15 +67,6 @@  main :: IO () main = do-  docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn])--  let docWithFilteredPriorityRecorder =-        docWithPriorityRecorder-        & cfilter (\WithPriority{ priority } -> priority >= Debug)--  let recorder = docWithFilteredPriorityRecorder-               & cmapWithPrio pretty-   -- We mess with env vars so run single-threaded.   defaultMainWithRerun $ testGroup "ghcide"     [ OpenCloseTest.tests@@ -99,7 +83,7 @@     , THTests.tests     , SymlinkTests.tests     , SafeTests.tests-    , UnitTests.tests recorder+    , UnitTests.tests     , HaddockTests.tests     , PositionMappingTests.tests     , WatchedFileTests.tests@@ -114,5 +98,5 @@     , ReferenceTests.tests     , GarbageCollectionTests.tests     , HieDbRetry.tests-    , ExceptionTests.tests recorder+    , ExceptionTests.tests     ]
ghcide/test/exe/NonLspCommandLine.hs view
@@ -1,14 +1,19 @@  module NonLspCommandLine (tests) where -import           Development.IDE.Test.Runfiles-import           System.Environment.Blank      (setEnv)-import           System.Exit                   (ExitCode (ExitSuccess))-import           System.Process.Extra          (CreateProcess (cwd), proc,-                                                readCreateProcessWithExitCode)+import           Control.Monad            ((>=>))+import           Data.Foldable            (for_)+import           Development.Shake        (getDirectoryFilesIO)+import           System.Directory         (copyFile, createDirectoryIfMissing)+import           System.Directory.Extra   (canonicalizePath)+import           System.Environment.Blank (setEnv)+import           System.Exit              (ExitCode (ExitSuccess))+import           System.FilePath          (takeDirectory, (</>))+import qualified System.IO.Extra+import           System.Process.Extra     (CreateProcess (cwd), proc,+                                           readCreateProcessWithExitCode) import           Test.Tasty import           Test.Tasty.HUnit-import           TestUtils   -- A test to ensure that the command line ghcide workflow stays working@@ -25,3 +30,21 @@          ec @?= ExitSuccess   ]++locateGhcideExecutable :: IO FilePath+locateGhcideExecutable = pure "ghcide"++-- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path+-- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or+-- @/var@+withTempDir :: (FilePath -> IO a) -> IO a+withTempDir f = System.IO.Extra.withTempDir $ canonicalizePath >=> f+++copyTestDataFiles :: FilePath -> FilePath -> IO ()+copyTestDataFiles dir prefix = do+  -- Copy all the test data files to the temporary workspace+  testDataFiles <- getDirectoryFilesIO ("ghcide/test/data" </> prefix) ["//*"]+  for_ testDataFiles $ \f -> do+    createDirectoryIfMissing True $ dir </> takeDirectory f+    copyFile ("ghcide/test/data" </> prefix </> f) (dir </> f)
ghcide/test/exe/OpenCloseTest.hs view
@@ -6,11 +6,13 @@ import           Language.LSP.Protocol.Message import           Language.LSP.Test -- import Test.QuickCheck.Instances ()+import           Config                          (testWithDummyPluginEmpty)+import           Test.Hls                        (waitForProgressBegin,+                                                  waitForProgressDone) import           Test.Tasty-import           TestUtils  tests :: TestTree-tests = testSession "open close" $ do+tests = testWithDummyPluginEmpty "open close" $ do     doc <- createDoc "Testing.hs" "haskell" ""     void (skipManyTill anyMessage $ message SMethod_WindowWorkDoneProgressCreate)     waitForProgressBegin
ghcide/test/exe/OutlineTests.hs view
@@ -1,189 +1,153 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-}  module OutlineTests (tests) where +import           Config import           Control.Monad.IO.Class      (liftIO)+import           Data.Text                   (Text) import qualified Data.Text                   as T+import           Development.IDE.GHC.Compat  (GhcVersion (..), ghcVersion) import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),                                               SemanticTokenRelative (..),                                               SemanticTokensEdit (..), mkRange) import           Language.LSP.Test+import           Test.Hls.FileSystem         (file, text) import           Test.Tasty import           Test.Tasty.HUnit-import           TestUtils -tests :: TestTree-tests = testGroup-  "outline"-  [ testSessionWait "type class" $ do-    let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [ moduleSymbol-          "A"-          (R 0 7 0 8)-          [ classSymbol "A a"-                        (R 1 0 1 30)-                        [docSymbol' "a" SymbolKind_Method (R 1 16 1 30) (R 1 16 1 17)]-          ]-      ]-  , testSessionWait "type class instance " $ do-    let source = T.unlines ["class A a where", "instance A () where"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [ classSymbol "A a" (R 0 0 0 15) []-      , docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19)-      ]-  , testSessionWait "type family" $ do-    let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)]-  , testSessionWait "type family instance " $ do-    let source = T.unlines-          [ "{-# language TypeFamilies #-}"-          , "type family A a"-          , "type instance A () = ()"-          ]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [ docSymbolD "A a"   "type family" SymbolKind_Function     (R 1 0 1 15)-      , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23)-      ]-  , testSessionWait "data family" $ do-    let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 11)]-  , testSessionWait "data family instance " $ do-    let source = T.unlines-          [ "{-# language TypeFamilies #-}"-          , "data family A a"-          , "data instance A () = A ()"-          ]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [ docSymbolD "A a"   "data family" SymbolKind_Function     (R 1 0 1 11)-      , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25)-      ]-  , testSessionWait "constant" $ do-    let source = T.unlines ["a = ()"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [docSymbol "a" SymbolKind_Function (R 0 0 0 6)]-  , testSessionWait "pattern" $ do-    let source = T.unlines ["Just foo = Just 21"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)]-  , testSessionWait "pattern with type signature" $ do-    let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)]-  , testSessionWait "function" $ do-    let source = T.unlines ["a _x = ()"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right [docSymbol "a" SymbolKind_Function (R 0 0 0 9)]-  , testSessionWait "type synonym" $ do-    let source = T.unlines ["type A = Bool"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)]-  , testSessionWait "datatype" $ do-    let source = T.unlines ["data A = C"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [ docSymbolWithChildren "A"-                              SymbolKind_Struct-                              (R 0 0 0 10)-                              [docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)]-      ]-  , testSessionWait "record fields" $ do-    let source = T.unlines ["data A = B {", "  x :: Int", "  , y :: Int}"]-    docId   <- createDoc "A.hs" "haskell" source+testSymbols :: (HasCallStack) => TestName -> FilePath -> [Text] -> [DocumentSymbol] -> TestTree+testSymbols testName path content expectedSymbols =+  testCase testName $ runWithDummyPlugin (mkIdeTestFs [file path (text $ T.unlines content)]) $ do+    docId <- openDoc path "haskell"     symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [ docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 2 13)-          [ docSymbolWithChildren' "B" SymbolKind_Constructor (R 0 9 2 13) (R 0 9 0 10)-            [ docSymbol "x" SymbolKind_Field (R 1 2 1 3)-            , docSymbol "y" SymbolKind_Field (R 2 4 2 5)+    liftIO $ symbols @?= Right expectedSymbols++testSymbolsA :: (HasCallStack) => TestName -> [Text] -> [DocumentSymbol] -> TestTree+testSymbolsA testName content expectedSymbols =+  testSymbols testName "A.hs" content expectedSymbols++tests :: TestTree+tests =+  testGroup+    "outline"+    [ testSymbolsA+        "type class:"+        ["module A where", "class A a where a :: a -> Bool"]+        [ moduleSymbol+            "A"+            (R 0 7 0 8)+            [ classSymbol+                "A a"+                (R 1 0 1 30)+                [docSymbol' "a" SymbolKind_Method (R 1 16 1 30) (R 1 16 1 17)]             ]-          ]-      ]-  , testSessionWait "import" $ do-    let source = T.unlines ["import Data.Maybe ()"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [docSymbolWithChildren "imports"-                             SymbolKind_Module-                             (R 0 0 0 20)-                             [ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20)-                             ]-      ]-  , testSessionWait "multiple import" $ do-    let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [docSymbolWithChildren "imports"-                             SymbolKind_Module-                             (R 1 0 3 27)-                             [ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20)-                             , docSymbol "import Control.Exception" SymbolKind_Module (R 3 0 3 27)-                             ]-      ]-  , testSessionWait "foreign import" $ do-    let source = T.unlines-          [ "{-# language ForeignFunctionInterface #-}"-          , "foreign import ccall \"a\" a :: Int"-          ]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right [docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)]-  , testSessionWait "foreign export" $ do-    let source = T.unlines-          [ "{-# language ForeignFunctionInterface #-}"-          , "foreign export ccall odd :: Int -> Bool"-          ]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right [docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)]-  ]- where-  docSymbol name kind loc =-    DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing-  docSymbol' name kind loc selectionLoc =-    DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing-  docSymbolD name detail kind loc =-    DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing-  docSymbolWithChildren name kind loc cc =-    DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just cc)-  docSymbolWithChildren' name kind loc selectionLoc cc =-    DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just cc)-  moduleSymbol name loc cc = DocumentSymbol name-                                            Nothing-                                            SymbolKind_File-                                            Nothing-                                            Nothing-                                            (R 0 0 maxBound 0)-                                            loc-                                            (Just cc)-  classSymbol name loc cc = DocumentSymbol name-                                           (Just "class")-                                           SymbolKind_Interface-                                           Nothing-                                           Nothing-                                           loc-                                           loc-                                           (Just cc)+        ],+      testSymbolsA+        "type class instance "+        ["class A a where", "instance A () where"]+        [ classSymbol "A a" (R 0 0 0 15) [],+          docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19)+        ],+      testSymbolsA "type family" ["{-# language TypeFamilies #-}", "type family A"] [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)],+      testSymbolsA+        "type family instance "+        ["{-# language TypeFamilies #-}", "type family A a", "type instance A () = ()"]+        [ docSymbolD "A a" "type family" SymbolKind_Function (R 1 0 1 15),+          docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23)+        ],+      testSymbolsA "data family" ["{-# language TypeFamilies #-}", "data family A"] [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 (if ghcVersion >= GHC910 then 13 else 11))],+      testSymbolsA+        "data family instance "+        ["{-# language TypeFamilies #-}", "data family A a", "data instance A () = A ()"]+        [ docSymbolD "A a" "data family" SymbolKind_Function (R 1 0 1 (if ghcVersion >= GHC910 then 15 else 11)),+          docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25)+        ],+      testSymbolsA "constant" ["a = ()"] [docSymbol "a" SymbolKind_Function (R 0 0 0 6)],+      testSymbolsA "pattern" ["Just foo = Just 21"] [docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)],+      testSymbolsA "pattern with type signature" ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] [docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)],+      testSymbolsA "function" ["a _x = ()"] [docSymbol "a" SymbolKind_Function (R 0 0 0 9)],+      testSymbolsA "type synonym" ["type A = Bool"] [docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)],+      testSymbolsA "datatype" ["data A = C"] [docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 0 10) [docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)]],+      testSymbolsA+        "record fields"+        ["data A = B {", "  x :: Int", "  , y :: Int}"]+        [ docSymbolWithChildren+            "A"+            SymbolKind_Struct+            (R 0 0 2 13)+            [ docSymbolWithChildren'+                "B"+                SymbolKind_Constructor+                (R 0 9 2 13)+                (R 0 9 0 10)+                [ docSymbol "x" SymbolKind_Field (R 1 2 1 3),+                  docSymbol "y" SymbolKind_Field (R 2 4 2 5)+                ]+            ]+        ],+      testSymbolsA+        "import"+        ["import Data.Maybe ()"]+        [ docSymbolWithChildren+            "imports"+            SymbolKind_Module+            (R 0 0 0 20)+            [ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20)+            ]+        ],+      testSymbolsA+        "multiple import"+        ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""]+        [ docSymbolWithChildren+            "imports"+            SymbolKind_Module+            (R 1 0 3 27)+            [ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20),+              docSymbol "import Control.Exception" SymbolKind_Module (R 3 0 3 27)+            ]+        ],+      testSymbolsA+        "foreign import"+        [ "{-# language ForeignFunctionInterface #-}",+          "foreign import ccall \"a\" a :: Int"+        ]+        [docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)],+      testSymbolsA+        "foreign export"+        [ "{-# language ForeignFunctionInterface #-}",+          "foreign export ccall odd :: Int -> Bool"+        ]+        [docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)]+    ]+  where+    docSymbol name kind loc =+      DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing+    docSymbol' name kind loc selectionLoc =+      DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing+    docSymbolD name detail kind loc =+      DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing+    docSymbolWithChildren name kind loc cc =+      DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just cc)+    docSymbolWithChildren' name kind loc selectionLoc cc =+      DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just cc)+    moduleSymbol name loc cc =+      DocumentSymbol+        name+        Nothing+        SymbolKind_File+        Nothing+        Nothing+        (R 0 0 maxBound 0)+        loc+        (Just cc)+    classSymbol name loc cc =+      DocumentSymbol+        name+        (Just "class")+        SymbolKind_Interface+        Nothing+        Nothing+        loc+        loc+        (Just cc)
ghcide/test/exe/PluginSimpleTests.hs view
@@ -1,17 +1,15 @@  module PluginSimpleTests (tests) where +import           Config import           Control.Monad.IO.Class      (liftIO)-import           Development.IDE.GHC.Compat  (GhcVersion (..)) import           Development.IDE.Test        (expectDiagnostics) import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),                                               SemanticTokenRelative (..),                                               SemanticTokensEdit (..), mkRange) import           Language.LSP.Test import           System.FilePath--- import Test.QuickCheck.Instances () import           Test.Tasty-import           TestUtils  tests :: TestTree tests =@@ -36,9 +34,7 @@    -- Error: cabal: Failed to build ghc-typelits-natnormalise-0.7.7 (which is   -- required by plugin-1.0.0). See the build log above for details.-  ignoreFor (BrokenForGHC [GHC96, GHC98]) "fragile, frequently times out" $-  ignoreFor (BrokenSpecific Windows [GHC94]) "ghc-typelist-natnormalise fails to build on GHC 9.4.2 for windows only" $-  testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do+  testWithExtraFiles "simple plugin"  "plugin-knownnat" $ \dir -> do     _ <- openDoc (dir </> "KnownNat.hs") "haskell"     liftIO $ writeFile (dir</>"hie.yaml")       "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}"
ghcide/test/exe/PositionMappingTests.hs view
@@ -1,10 +1,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE OverloadedLabels    #-}  module PositionMappingTests (tests) where  import qualified Data.EnumMap.Strict                  as EM-import           Data.Row import qualified Data.Text                            as T import           Data.Text.Utf16.Rope.Mixed           (Rope) import qualified Data.Text.Utf16.Rope.Mixed           as Rope@@ -32,8 +30,7 @@  enumMapMappingTest :: TestTree enumMapMappingTest = testCase "enumMapMappingTest" $ do-  let mkChangeEvent :: Range -> Text -> TextDocumentContentChangeEvent-      mkChangeEvent r t = TextDocumentContentChangeEvent $ InL $ #range .== r .+ #rangeLength .== Nothing .+ #text .== t+  let       mkCE :: UInt -> UInt -> UInt -> UInt -> Text -> TextDocumentContentChangeEvent       mkCE l1 c1 l2 c2 = mkChangeEvent (Range (Position l1 c1) (Position l2 c2))       events :: [(Int32, [TextDocumentContentChangeEvent])]@@ -45,6 +42,9 @@   updatePose (Position 0 4) @?= Just (Position 0 9)   updatePose (Position 0 5) @?= Just (Position 0 10) +mkChangeEvent :: Range -> Text -> TextDocumentContentChangeEvent+mkChangeEvent r t = TextDocumentContentChangeEvent $ InL+    TextDocumentContentChangePartial {_range = r, _rangeLength = Nothing, _text = t}  tests ::  TestTree tests =@@ -167,10 +167,7 @@                         rope <- genRope                         range <- genRange rope                         PrintableText replacement <- arbitrary-                        let newRope = runIdentity $ applyChange mempty rope-                                (TextDocumentContentChangeEvent $ InL $ #range .== range-                                                                     .+ #rangeLength .== Nothing-                                                                     .+ #text .== replacement)+                        let newRope = runIdentity $ applyChange mempty rope $ mkChangeEvent range replacement                         newPos <- genPosition newRope                         pure (range, replacement, newPos)                 forAll
ghcide/test/exe/PreprocessorTests.hs view
@@ -8,11 +8,11 @@                                               SemanticTokensEdit (..), mkRange) import           Language.LSP.Test -- import Test.QuickCheck.Instances ()+import           Config import           Test.Tasty-import           TestUtils  tests :: TestTree-tests = testSessionWait "preprocessor" $ do+tests = testWithDummyPluginEmpty "preprocessor" $ do   let content =         T.unlines           [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}"
ghcide/test/exe/ReferenceTests.hs view
@@ -1,4 +1,7 @@+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE OverloadedStrings #-} + module ReferenceTests (tests) where  import           Control.Applicative.Combinators@@ -7,8 +10,6 @@ import           Control.Monad.IO.Class          (liftIO) import           Data.List.Extra import qualified Data.Set                        as Set-import           Development.IDE.Test            (configureCheckProject,-                                                  referenceReady) import           Development.IDE.Types.Location import qualified Language.LSP.Protocol.Lens      as L import           Language.LSP.Protocol.Types     hiding@@ -18,14 +19,25 @@                                                   mkRange) import           Language.LSP.Test import           System.Directory-import           System.FilePath -- import Test.QuickCheck.Instances ()+import           Config import           Control.Lens                    ((^.))+import qualified Data.Aeson                      as A+import           Data.Default                    (def) import           Data.Tuple.Extra+import           GHC.TypeLits                    (symbolVal)+import           Ide.PluginUtils                 (toAbsolute)+import           Ide.Types+import           System.FilePath                 (addTrailingPathSeparator,+                                                  (</>))+import           Test.Hls                        (FromServerMessage' (..),+                                                  SMethod (..),+                                                  TCustomMessage (..),+                                                  TNotificationMessage (..))+import           Test.Hls.FileSystem             (copyDir) import           Test.Tasty import           Test.Tasty.ExpectedFailure import           Test.Tasty.HUnit-import           TestUtils   tests :: TestTree@@ -156,37 +168,46 @@     where toBool YesIncludeDeclaration = True           toBool NoExcludeDeclaration  = False ++ referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree-referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do-  -- needed to build whole project indexing-  configureCheckProject True-  let docs = map (dir </>) $ delete thisDoc $ nubOrd docs'-  -- Initial Index-  docid <- openDoc thisDoc "haskell"-  let-    loop :: [FilePath] -> Session ()-    loop [] = pure ()-    loop docs = do-      doc <- skipManyTill anyMessage $ referenceReady (`elem` docs)-      loop (delete doc docs)-  loop docs-  f dir-  closeDoc docid+referenceTestSession name thisDoc docs' f = do+  testWithDummyPlugin' name (mkIdeTestFs [copyDir "references"]) $ \fs -> do+    let rootDir = addTrailingPathSeparator fs+    -- needed to build whole project indexing+    configureCheckProject True+    -- need to get the real paths through links+    docs <- mapM (liftIO . canonicalizePath . (fs </>)) $ delete thisDoc $ nubOrd docs'+    -- Initial Index+    docid <- openDoc thisDoc "haskell" +    liftIO $ putStrLn $ "docs:" <> show docs+    let+        -- todo wait for docs+        loop :: [FilePath] -> Session ()+        loop [] = pure ()+        loop docs = do++            doc <- skipManyTill anyMessage $ referenceReady (`elem` docs)+            loop (delete doc docs)+    loop docs+    f rootDir+    closeDoc docid+ -- | Given a location, lookup the symbol and all references to it. Make sure -- they are the ones we expect.-referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree+referenceTest :: (HasCallStack) => String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree referenceTest name loc includeDeclaration expected =-    referenceTestSession name (fst3 loc) docs $ \dir -> do+    referenceTestSession name (fst3 loc) docs $ \rootDir -> do         actual <- getReferences' loc includeDeclaration-        liftIO $ actual `expectSameLocations` map (first3 (dir </>)) expected+        liftIO $ expectSameLocations rootDir actual expected   where     docs = map fst3 expected  type SymbolLocation = (FilePath, UInt, UInt) -expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion-expectSameLocations actual expected = do+expectSameLocations :: (HasCallStack) => FilePath -> [Location] -> [SymbolLocation] -> Assertion+expectSameLocations rootDir actual expected = do     let actual' =             Set.map (\location -> (location ^. L.uri                                    , location ^. L.range . L.start . L.line . Lens.to fromIntegral@@ -194,6 +215,19 @@             $ Set.fromList actual     expected' <- Set.fromList <$>         (forM expected $ \(file, l, c) -> do-                              fp <- canonicalizePath file+                              fp <- canonicalizePath $ toAbsolute rootDir file                               return (filePathToUri fp, l, c))     actual' @?= expected'+++-- todo find where to put this in hls+configureCheckProject :: Bool -> Session ()+configureCheckProject overrideCheckProject = setConfigSection "haskell" (A.toJSON $ def{checkProject = overrideCheckProject})+referenceReady :: (FilePath -> Bool) -> Session FilePath+referenceReady pred = satisfyMaybe $ \case+  FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params})+    | A.Success fp <- A.fromJSON _params+    , pred fp+    , symbolVal p == "ghcide/reference/ready"+    -> Just fp+  _ -> Nothing
ghcide/test/exe/RootUriTests.hs view
@@ -7,20 +7,33 @@ import           Language.LSP.Test import           System.FilePath -- import Test.QuickCheck.Instances ()+import           Config+import           Data.Default             (def)+import           Test.Hls                 (TestConfig (..),+                                           runSessionWithTestConfig)+import           Test.Hls.FileSystem      (copyDir) import           Test.Tasty import           Test.Tasty.HUnit-import           TestUtils   -- | checks if we use InitializeParams.rootUri for loading session tests :: TestTree tests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do   let bPath = dir </> "dirB/Foo.hs"-  liftIO $ copyTestDataFiles dir "rootUri"   bSource <- liftIO $ readFileUtf8 bPath   _ <- createDoc "Foo.hs" "haskell" bSource   expectNoMoreDiagnostics 0.5   where     -- similar to run' except we can configure where to start ghcide and session     runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO ()-    runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir)+    runTest dir1 dir2 = runSessionWithTestConfig+        def+        {+            testPluginDescriptor = dummyPlugin+            , testDirLocation = Right $ mkIdeTestFs [copyDir "rootUri"]+            , testServerRoot = Just dir1+            , testClientRoot = Just dir2+            , testShiftRoot = True+        }++
ghcide/test/exe/SafeTests.hs view
@@ -5,15 +5,15 @@ import           Development.IDE.Test (expectNoMoreDiagnostics) import           Language.LSP.Test +import           Config import           Test.Tasty-import           TestUtils  tests :: TestTree tests =   testGroup     "SafeHaskell"     [ -- Test for https://github.com/haskell/ghcide/issues/424-      testSessionWait "load" $ do+      testWithDummyPluginEmpty "load" $ do         let sourceA =               T.unlines                 ["{-# LANGUAGE Trustworthy #-}"
ghcide/test/exe/SymlinkTests.hs view
@@ -10,9 +10,9 @@ import           System.Directory import           System.FilePath +import           Config import           Test.Tasty import           Test.Tasty.HUnit-import           TestUtils  -- | Tests for projects that use symbolic links one way or another tests :: TestTree
ghcide/test/exe/THTests.hs view
@@ -1,10 +1,8 @@ -{-# LANGUAGE OverloadedLabels #-}- module THTests (tests) where +import           Config import           Control.Monad.IO.Class      (liftIO)-import           Data.Row import qualified Data.Text                   as T import           Development.IDE.GHC.Util import           Development.IDE.Test        (expectCurrentDiagnostics,@@ -17,14 +15,13 @@ import           System.FilePath import           Test.Tasty import           Test.Tasty.HUnit-import           TestUtils  tests :: TestTree tests =   testGroup     "TemplateHaskell"     [ -- Test for https://github.com/haskell/ghcide/pull/212-      testSessionWait "load" $ do+      testWithDummyPluginEmpty "load" $ do         let sourceA =               T.unlines                 [ "{-# LANGUAGE PackageImports #-}",@@ -47,7 +44,7 @@         _ <- createDoc "A.hs" "haskell" sourceA         _ <- createDoc "B.hs" "haskell" sourceB         expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Error, (6, 29), "Variable not in scope: n")] ) ]-    , testSessionWait "newtype-closure" $ do+    , testWithDummyPluginEmpty "newtype-closure" $ do         let sourceA =               T.unlines                 [ "{-# LANGUAGE DeriveDataTypeable #-}"@@ -71,11 +68,11 @@     , thReloadingTest False     , thLoadingTest     , thCoreTest-    , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True+    , thReloadingTest True     -- Regression test for https://github.com/haskell/haskell-language-server/issues/891     , thLinkingTest False-    , ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True-    , testSessionWait "findsTHIdentifiers" $ do+    , thLinkingTest True+    , testWithDummyPluginEmpty "findsTHIdentifiers" $ do         let sourceA =               T.unlines                 [ "{-# LANGUAGE TemplateHaskell #-}"@@ -142,9 +139,9 @@      -- Change th from () to Bool     let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"]-    changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ aSource']+    changeDoc adoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument aSource']     -- generate an artificial warning to avoid timing out if the TH change does not propagate-    changeDoc cdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ cSource <> "\nfoo=()"]+    changeDoc cdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ cSource <> "\nfoo=()"]      -- Check that the change propagates to C     expectDiagnostics@@ -176,13 +173,12 @@     expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding")])]      let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"]-    changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ aSource']+    changeDoc adoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument aSource']      -- modify b too     let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"]-    changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ bSource']-    waitForProgressBegin-    waitForAllProgressDone+    changeDoc bdoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument bSource']+    _ <- waitForDiagnostics      expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,1), "Top-level binding")]
− ghcide/test/exe/TestUtils.hs 
@@ -1,318 +0,0 @@--{-# LANGUAGE GADTs           #-}-{-# LANGUAGE PatternSynonyms #-}--module TestUtils where--import           Control.Applicative.Combinators-import           Control.Concurrent.Async-import           Control.Exception               (bracket_, finally)-import           Control.Lens                    ((.~))-import qualified Control.Lens                    as Lens-import qualified Control.Lens.Extras             as Lens-import           Control.Monad-import           Control.Monad.IO.Class          (liftIO)-import           Data.Foldable-import           Data.Function                   ((&))-import           Data.Maybe-import qualified Data.Text                       as T-import           Development.IDE.GHC.Compat      (GhcVersion (..), ghcVersion)-import           Development.IDE.GHC.Util-import qualified Development.IDE.Main            as IDE-import           Development.IDE.Test            (canonicalizeUri,-                                                  configureCheckProject,-                                                  expectNoMoreDiagnostics)-import           Development.IDE.Test.Runfiles-import           Development.IDE.Types.Location-import           Development.Shake               (getDirectoryFilesIO)-import           Ide.Logger                      (Recorder, WithPriority,-                                                  cmapWithPrio)-import qualified Language.LSP.Protocol.Lens      as L-import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Types     hiding-                                                 (SemanticTokenAbsolute (..),-                                                  SemanticTokenRelative (..),-                                                  SemanticTokensEdit (..),-                                                  mkRange)-import           Language.LSP.Test-import           System.Directory-import           System.Environment.Blank        (getEnv, setEnv, unsetEnv)-import           System.FilePath-import           System.Info.Extra               (isMac, isWindows)-import qualified System.IO.Extra-import           System.Process.Extra            (createPipe)-import           Test.Tasty-import           Test.Tasty.ExpectedFailure-import           Test.Tasty.HUnit--import           LogType---- | Wait for the next progress begin step-waitForProgressBegin :: Session ()-waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case-  FromServerMess  SMethod_Progress  (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressBegin v-> Just ()-  _ -> Nothing---- | Wait for the first progress end step--- Also implemented in hls-test-utils Test.Hls-waitForProgressDone :: Session ()-waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case-  FromServerMess  SMethod_Progress  (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressEnd v -> Just ()-  _ -> Nothing---- | Wait for all progress to be done--- Needs at least one progress done notification to return--- Also implemented in hls-test-utils Test.Hls-waitForAllProgressDone :: Session ()-waitForAllProgressDone = loop-  where-    loop = do-      ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case-        FromServerMess  SMethod_Progress  (TNotificationMessage _ _ (ProgressParams _ v)) |Lens.is _workDoneProgressEnd v-> Just ()-        _ -> Nothing-      done <- null <$> getIncompleteProgressSessions-      unless done loop--run :: Session a -> IO a-run s = run' (const s)--run' :: (FilePath -> Session a) -> IO a-run' s = withTempDir $ \dir -> runInDir dir (s dir)--runInDir :: FilePath -> Session a -> IO a-runInDir dir = runInDir' dir "." "." []---- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root.-runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a-runInDir' = runInDir'' lspTestCaps--runInDir''-    :: ClientCapabilities-    -> FilePath-    -> FilePath-    -> FilePath-    -> [String]-    -> Session b-    -> IO b-runInDir'' lspCaps dir startExeIn startSessionIn extraOptions s = do--  ghcideExe <- locateGhcideExecutable-  let startDir = dir </> startExeIn-  let projDir = dir </> startSessionIn--  createDirectoryIfMissing True startDir-  createDirectoryIfMissing True projDir-  -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56-  -- since the package import test creates "Data/List.hs", which otherwise has no physical home-  createDirectoryIfMissing True $ projDir ++ "/Data"--  shakeProfiling <- getEnv "SHAKE_PROFILING"-  let cmd = unwords $-       [ghcideExe, "--lsp", "--test", "--verify-core-file", "--verbose", "-j2", "--cwd", startDir-       ] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling]-       ] ++ extraOptions-  -- HIE calls getXgdDirectory which assumes that HOME is set.-  -- Only sets HOME if it wasn't already set.-  setEnv "HOME" "/homeless-shelter" False-  conf <- getConfigFromEnv-  runSessionWithConfig conf cmd lspCaps projDir $ do-      configureCheckProject False-      s---- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path--- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or--- @/var@-withTempDir :: (FilePath -> IO a) -> IO a-withTempDir f = System.IO.Extra.withTempDir $ \dir -> do-  dir' <- canonicalizePath dir-  f dir'--lspTestCaps :: ClientCapabilities-lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing }--getConfigFromEnv :: IO SessionConfig-getConfigFromEnv = do-  logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR"-  timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT"-  return defaultConfig-    { messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride-    , logColor-    }-  where-    checkEnv :: String -> IO (Maybe Bool)-    checkEnv s = fmap convertVal <$> getEnv s-    convertVal "0" = False-    convertVal _   = True--testSessionWait :: HasCallStack => String -> Session () -> TestTree-testSessionWait name = testSession name .-      -- Check that any diagnostics produced were already consumed by the test case.-      ---      -- If in future we add test cases where we don't care about checking the diagnostics,-      -- this could move elsewhere.-      ---      -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.-      ( >> expectNoMoreDiagnostics 0.5)--testSession :: String -> Session () -> TestTree-testSession name = testCase name . run--xfail :: TestTree -> String -> TestTree-xfail = flip expectFailBecause--ignoreInWindowsBecause :: String -> TestTree -> TestTree-ignoreInWindowsBecause = ignoreFor (BrokenForOS Windows)--knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree-knownBrokenForGhcVersions ghcVers = knownBrokenFor (BrokenForGHC ghcVers)--data BrokenOS = Linux | MacOS | Windows deriving (Show)--data IssueSolution = Broken | Ignore deriving (Show)--data BrokenTarget =-    BrokenSpecific BrokenOS [GhcVersion]-    -- ^Broken for `BrokenOS` with `GhcVersion`-    | BrokenForOS BrokenOS-    -- ^Broken for `BrokenOS`-    | BrokenForGHC [GhcVersion]-    -- ^Broken for `GhcVersion`-    deriving (Show)---- | Ignore test for specific os and ghc with reason.-ignoreFor :: BrokenTarget -> String -> TestTree -> TestTree-ignoreFor = knownIssueFor Ignore---- | Known broken for specific os and ghc with reason.-knownBrokenFor :: BrokenTarget -> String -> TestTree -> TestTree-knownBrokenFor = knownIssueFor Broken---- | Deal with `IssueSolution` for specific OS and GHC.-knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree-knownIssueFor solution = go . \case-    BrokenSpecific bos vers -> isTargetOS bos && isTargetGhc vers-    BrokenForOS bos         -> isTargetOS bos-    BrokenForGHC vers       -> isTargetGhc vers-    where-        isTargetOS = \case-            Windows -> isWindows-            MacOS   -> isMac-            Linux   -> not isWindows && not isMac--        isTargetGhc = elem ghcVersion--        go True = case solution of-            Broken -> expectFailBecause-            Ignore -> ignoreTestBecause-        go False = const id--data Expect-  = ExpectRange Range -- Both gotoDef and hover should report this range-  | ExpectLocation Location---  | ExpectDefRange Range -- Only gotoDef should report this range-  | ExpectHoverRange Range -- Only hover should report this range-  | ExpectHoverText [T.Text] -- the hover message must contain these snippets-  | ExpectHoverExcludeText [T.Text] -- the hover message must _not_ contain these snippets-  | ExpectHoverTextRegex T.Text -- the hover message must match this pattern-  | ExpectExternFail -- definition lookup in other file expected to fail-  | ExpectNoDefinitions-  | ExpectNoHover---  | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples-  deriving Eq--mkR :: UInt -> UInt -> UInt -> UInt -> Expect-mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn--mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect-mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn----testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree-testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix--testSession' :: String -> (FilePath -> Session ()) -> TestTree-testSession' name = testCase name . run'----mkRange :: UInt -> UInt -> UInt -> UInt -> Range-mkRange a b c d = Range (Position a b) (Position c d)---runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a-runWithExtraFiles prefix s = withTempDir $ \dir -> do-  copyTestDataFiles dir prefix-  runInDir dir (s dir)--copyTestDataFiles :: FilePath -> FilePath -> IO ()-copyTestDataFiles dir prefix = do-  -- Copy all the test data files to the temporary workspace-  testDataFiles <- getDirectoryFilesIO ("ghcide/test/data" </> prefix) ["//*"]-  for_ testDataFiles $ \f -> do-    createDirectoryIfMissing True $ dir </> takeDirectory f-    copyFile ("ghcide/test/data" </> prefix </> f) (dir </> f)--withLongTimeout :: IO a -> IO a-withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT")----lspTestCapsNoFileWatches :: ClientCapabilities-lspTestCapsNoFileWatches = lspTestCaps & L.workspace . Lens._Just . L.didChangeWatchedFiles .~ Nothing--openTestDataDoc :: FilePath -> Session TextDocumentIdentifier-openTestDataDoc path = do-  source <- liftIO $ readFileUtf8 $ "ghcide/test/data" </> path-  createDoc path "haskell" source--pattern R :: UInt -> UInt -> UInt -> UInt -> Range-pattern R x y x' y' = Range (Position x y) (Position x' y')--checkDefs :: Definition |? ([DefinitionLink] |? Null) -> Session [Expect] -> Session ()-checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpectations where-  check (ExpectRange expectedRange) = do-    def <- assertOneDefinitionFound defs-    assertRangeCorrect def expectedRange-  check (ExpectLocation expectedLocation) = do-    def <- assertOneDefinitionFound defs-    liftIO $ do-      canonActualLoc <- canonicalizeLocation def-      canonExpectedLoc <- canonicalizeLocation expectedLocation-      canonActualLoc @?= canonExpectedLoc-  check ExpectNoDefinitions = do-    liftIO $ assertBool "Expecting no definitions" $ null defs-  check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"-  check _ = pure () -- all other expectations not relevant to getDefinition--  assertOneDefinitionFound :: [Location] -> Session Location-  assertOneDefinitionFound [def] = pure def-  assertOneDefinitionFound xs = liftIO . assertFailure $ "Expecting exactly one definition, got " <> show (length xs)--  assertRangeCorrect Location{_range = foundRange} expectedRange =-    liftIO $ expectedRange @=? foundRange--canonicalizeLocation :: Location -> IO Location-canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range--defToLocation :: Definition |? ([DefinitionLink] |? Null) -> [Location]-defToLocation (InL (Definition (InL l))) = [l]-defToLocation (InL (Definition (InR ls))) = ls-defToLocation (InR (InL defLink)) = (\(DefinitionLink LocationLink{_targetUri,_targetRange}) -> Location _targetUri _targetRange) <$> defLink-defToLocation (InR (InR Null)) = []--testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO ()-testIde recorder arguments session = do-    config <- getConfigFromEnv-    cwd <- getCurrentDirectory-    (hInRead, hInWrite) <- createPipe-    (hOutRead, hOutWrite) <- createPipe--    let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments-            { IDE.argsHandleIn = pure hInRead-            , IDE.argsHandleOut = pure hOutWrite-            }--    withTempDir $ \dir -> do-        flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ ->-            runSessionWithHandles hInWrite hOutRead config lspTestCaps dir session
ghcide/test/exe/UnitTests.hs view
@@ -1,6 +1,7 @@  module UnitTests (tests) where +import           Config                            (mkIdeTestFs) import           Control.Concurrent import           Control.Monad.IO.Class            (liftIO) import           Data.IORef@@ -9,13 +10,11 @@ import           Data.String                       (IsString (fromString)) import qualified Data.Text                         as T import           Development.IDE.Core.FileStore    (getModTime)-import qualified Development.IDE.Main              as IDE import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide import qualified Development.IDE.Types.Diagnostics as Diagnostics import           Development.IDE.Types.Location import qualified FuzzySearch-import           Ide.Logger                        (Recorder, WithPriority,-                                                    cmapWithPrio)+import           Ide.Logger                        (Recorder, WithPriority) import           Ide.PluginUtils                   (pluginDescToIdePlugins) import           Ide.Types import           Language.LSP.Protocol.Message@@ -25,19 +24,20 @@                                                     SemanticTokensEdit (..),                                                     mkRange) import           Language.LSP.Test-import           LogType                           (Log (..)) import           Network.URI import qualified Progress import           System.IO.Extra                   hiding (withTempDir) import           System.Mem                        (performGC)+import           Test.Hls                          (IdeState, def,+                                                    runSessionWithServerInTmpDir,+                                                    waitForProgressDone) import           Test.Tasty import           Test.Tasty.ExpectedFailure import           Test.Tasty.HUnit-import           TestUtils import           Text.Printf                       (printf) -tests :: Recorder (WithPriority Log) -> TestTree-tests recorder = do+tests :: TestTree+tests = do   testGroup "Unit"      [ testCase "empty file path does NOT work with the empty String literal" $          uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "."@@ -71,7 +71,9 @@              expected `isInfixOf` shown      , testCase "notification handlers run in priority order" $ do         orderRef <- newIORef []-        let plugins = pluginDescToIdePlugins $+        let+            plugins ::Recorder (WithPriority Ghcide.Log) -> IdePlugins IdeState+            plugins recorder = pluginDescToIdePlugins $                 [ (priorityPluginDescriptor i)                     { pluginNotificationHandlers = mconcat                         [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ ->@@ -79,10 +81,10 @@                         ]                     }                     | i <- [1..20]-                ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder)+                ] ++ Ghcide.descriptors recorder             priorityPluginDescriptor i = (defaultPluginDescriptor (fromString $ show i) ""){pluginPriority = i} -        testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) plugins) $ do+        runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do             _ <- createDoc "A.hs" "haskell" "module A where"             waitForProgressDone             actualOrder <- liftIO $ reverse <$> readIORef orderRef
ghcide/test/exe/WatchedFileTests.hs view
@@ -3,6 +3,7 @@  module WatchedFileTests (tests) where +import           Config                          (testWithDummyPluginEmpty') import           Control.Applicative.Combinators import           Control.Monad.IO.Class          (liftIO) import qualified Data.Aeson                      as A@@ -19,12 +20,11 @@ import           System.FilePath import           Test.Tasty import           Test.Tasty.HUnit-import           TestUtils  tests :: TestTree tests = testGroup "watched files"   [ testGroup "Subscriptions"-    [ testSession' "workspace files" $ \sessionDir -> do+    [ testWithDummyPluginEmpty' "workspace files" $ \sessionDir -> do         liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}"         _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"         setIgnoringRegistrationRequests False@@ -33,7 +33,7 @@         -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle         liftIO $ length watchedFileRegs @?= 2 -    , testSession' "non workspace file" $ \sessionDir -> do+    , testWithDummyPluginEmpty' "non workspace file" $ \sessionDir -> do         tmpDir <- liftIO getTemporaryDirectory         let yaml = "cradle: {direct: {arguments: [\"-i" <> tail(init(show tmpDir)) <> "\", \"A\", \"WatchedFilesMissingModule\"]}}"         liftIO $ writeFile (sessionDir </> "hie.yaml") yaml@@ -48,7 +48,7 @@     ]   , testGroup "Changes"     [-      testSession' "workspace files" $ \sessionDir -> do+      testWithDummyPluginEmpty' "workspace files" $ \sessionDir -> do         liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}"         liftIO $ writeFile (sessionDir </> "B.hs") $ unlines           ["module B where"
haskell-language-server.cabal view
@@ -1,7 +1,7 @@ cabal-version:      3.4 category:           Development name:               haskell-language-server-version:            2.8.0.0+version:            2.9.0.0 synopsis:           LSP server for GHC description:   Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -14,7 +14,7 @@ license:            Apache-2.0 license-file:       LICENSE build-type:         Simple-tested-with:        GHC == 9.8.2 || ==9.6.4 || ==9.4.8 || ==9.2.8+tested-with:        GHC ==9.10.1 || ==9.8.2 || ==9.6.5 || ==9.4.8 || ==9.2.8 extra-source-files:   README.md   ChangeLog.md@@ -44,7 +44,10 @@   default-extensions: ExplicitNamespaces  common test-defaults-  ghc-options:        -threaded -rtsopts -with-rtsopts=-N+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  if impl(ghc >= 9.8)+    -- We allow using partial functions in tests+    ghc-options: -Wno-x-partial  -- Default warnings in HLS common warnings@@ -126,8 +129,8 @@     , base            >=4.12 && <5     , directory     , filepath-    , ghcide          == 2.8.0.0-    , hls-plugin-api  == 2.8.0.0+    , ghcide          == 2.9.0.0+    , hls-plugin-api  == 2.9.0.0     , lens     , lsp-types     , mtl@@ -146,7 +149,7 @@     , directory     , filepath     , haskell-language-server:hls-cabal-fmt-plugin-    , hls-test-utils        == 2.8.0.0+    , hls-test-utils        == 2.9.0.0    if flag(isolateCabalfmtTests)     build-tool-depends: cabal-fmt:cabal-fmt ^>=0.1.6@@ -182,8 +185,8 @@     , base            >=4.12 && <5     , directory     , filepath-    , ghcide          == 2.8.0.0-    , hls-plugin-api  == 2.8.0.0+    , ghcide          == 2.9.0.0+    , hls-plugin-api  == 2.9.0.0     , lsp-types     , text     , mtl@@ -201,10 +204,10 @@     , directory     , filepath     , haskell-language-server:hls-cabal-gild-plugin-    , hls-test-utils        == 2.8.0.0+    , hls-test-utils        == 2.9.0.0    if flag(isolateCabalGildTests)-    build-tool-depends: cabal-gild:cabal-gild ^>=1.1+    build-tool-depends: cabal-gild:cabal-gild ^>=1.3     cpp-options: -Dhls_isolate_cabalgild_tests  -----------------------------@@ -238,6 +241,7 @@     Ide.Plugin.Cabal.Completion.Data     Ide.Plugin.Cabal.Completion.Types     Ide.Plugin.Cabal.LicenseSuggest+    Ide.Plugin.Cabal.Orphans     Ide.Plugin.Cabal.Parse  @@ -250,17 +254,15 @@     , directory     , filepath     , extra                 >=1.7.4-    , ghcide                == 2.8.0.0+    , ghcide                == 2.9.0.0     , hashable-    , hls-plugin-api        == 2.8.0.0-    , hls-graph             == 2.8.0.0+    , hls-plugin-api        == 2.9.0.0+    , hls-graph             == 2.9.0.0     , lens-    , lsp                   ^>=2.4-    , lsp-types             ^>=2.1+    , lsp                   ^>=2.7+    , lsp-types             ^>=2.3     , regex-tdfa            ^>=1.3.1-    , stm     , text-    , text-rope     , transformers     , unordered-containers  >=0.2.10.0     , containers@@ -284,13 +286,10 @@     , filepath     , ghcide     , haskell-language-server:hls-cabal-plugin-    , hls-test-utils    == 2.8.0.0+    , hls-test-utils    == 2.9.0.0     , lens     , lsp-types     , text-    , text-rope-    , transformers-    , row-types  ----------------------------- -- class plugin@@ -324,10 +323,10 @@     , deepseq     , extra     , ghc-    , ghc-exactprint  >= 1.5-    , ghcide          == 2.8.0.0+    , ghc-exactprint  >= 1.5 && < 1.10.0.0+    , ghcide          == 2.9.0.0     , hls-graph-    , hls-plugin-api  == 2.8.0.0+    , hls-plugin-api  == 2.9.0.0     , lens     , lsp     , mtl@@ -349,10 +348,9 @@     , base     , filepath     , haskell-language-server:hls-class-plugin-    , hls-test-utils     == 2.8.0.0+    , hls-test-utils     == 2.9.0.0     , lens     , lsp-types-    , row-types     , text  -----------------------------@@ -385,11 +383,11 @@     , base                  >=4.12 && <5     , containers     , extra-    , ghcide                == 2.8.0.0+    , ghcide                == 2.9.0.0     , hiedb                 ^>= 0.6.0.0-    , hls-plugin-api        == 2.8.0.0+    , hls-plugin-api        == 2.9.0.0     , lens-    , lsp                    >=2.4+    , lsp                    >=2.7     , sqlite-simple     , text @@ -409,8 +407,7 @@     , extra     , filepath     , haskell-language-server:hls-call-hierarchy-plugin-    , hls-test-utils        == 2.8.0.0-    , ghcide:ghcide-test-utils+    , hls-test-utils        == 2.9.0.0     , lens     , lsp     , lsp-test@@ -455,15 +452,15 @@     , bytestring     , containers     , deepseq-    , Diff                  ^>=0.4.0+    , Diff                  ^>=0.5     , dlist     , extra     , filepath     , ghc     , ghc-boot-th-    , ghcide                == 2.8.0.0+    , ghcide                == 2.9.0.0     , hls-graph-    , hls-plugin-api        == 2.8.0.0+    , hls-plugin-api        == 2.9.0.0     , lens     , lsp     , lsp-types@@ -494,11 +491,10 @@     , filepath     , haskell-language-server:hls-eval-plugin     , hls-plugin-api-    , hls-test-utils   == 2.8.0.0+    , hls-test-utils   == 2.9.0.0     , lens     , lsp-types     , text-    , row-types  ----------------------------- -- import lens plugin@@ -526,9 +522,9 @@     , containers     , deepseq     , ghc-    , ghcide                == 2.8.0.0+    , ghcide                == 2.9.0.0     , hls-graph-    , hls-plugin-api        == 2.8.0.0+    , hls-plugin-api        == 2.9.0.0     , lens     , lsp     , mtl@@ -550,10 +546,9 @@     , extra     , filepath     , haskell-language-server:hls-explicit-imports-plugin-    , hls-test-utils   == 2.8.0.0+    , hls-test-utils   == 2.9.0.0     , lens     , lsp-types-    , row-types     , text  -----------------------------@@ -579,19 +574,17 @@   build-depends:     , base                  >=4.12    && <5     , containers-    , ghcide                == 2.8.0.0+    , ghcide                == 2.9.0.0     , hashable     , hiedb                 ^>= 0.6.0.0     , hie-compat-    , hls-plugin-api        == 2.8.0.0+    , hls-plugin-api        == 2.9.0.0     , haskell-language-server:hls-refactor-plugin     , lens-    , lsp     , lsp-types     , mtl     , mod     , syb-    , row-types     , text     , transformers     , unordered-containers@@ -611,10 +604,9 @@     , filepath     , hls-plugin-api     , haskell-language-server:hls-rename-plugin-    , hls-test-utils             == 2.8.0.0+    , hls-test-utils             == 2.9.0.0     , lens     , lsp-types-    , row-types     , text  -----------------------------@@ -627,13 +619,13 @@   manual:      True  common retrie-  if flag(retrie)+  if flag(retrie) && impl(ghc < 9.10)     build-depends: haskell-language-server:hls-retrie-plugin     cpp-options: -Dhls_retrie  library hls-retrie-plugin   import:           defaults, pedantic, warnings-  if !flag(retrie)+  if !(flag(retrie) && impl(ghc < 9.10))     buildable: False   exposed-modules:  Ide.Plugin.Retrie   hs-source-dirs:   plugins/hls-retrie-plugin/src@@ -642,12 +634,11 @@     , base                  >=4.12    && <5     , bytestring     , containers-    , directory     , extra     , ghc-    , ghcide                == 2.8.0.0+    , ghcide                == 2.9.0.0     , hashable-    , hls-plugin-api        == 2.8.0.0+    , hls-plugin-api        == 2.9.0.0     , haskell-language-server:hls-refactor-plugin     , lens     , lsp@@ -665,7 +656,7 @@  test-suite hls-retrie-plugin-tests   import:           defaults, pedantic, test-defaults, warnings-  if !flag(retrie)+  if !(flag(retrie) && impl(ghc < 9.10))     buildable: False   type:             exitcode-stdio-1.0   hs-source-dirs:   plugins/hls-retrie-plugin/test@@ -676,7 +667,7 @@     , filepath     , hls-plugin-api     , haskell-language-server:{hls-refactor-plugin, hls-retrie-plugin}-    , hls-test-utils             == 2.8.0.0+    , hls-test-utils             == 2.9.0.0     , text  -----------------------------@@ -696,13 +687,14 @@   manual:      True  common hlint-  if flag(hlint)+  if flag(hlint) && impl(ghc < 9.10)     build-depends: haskell-language-server:hls-hlint-plugin     cpp-options: -Dhls_hlint  library hls-hlint-plugin   import:           defaults, pedantic, warnings-  if !flag(hlint)+  -- https://github.com/ndmitchell/hlint/pull/1594+  if !(flag(hlint) && impl(ghc < 9.10))     buildable: False   exposed-modules:  Ide.Plugin.Hlint   hs-source-dirs:   plugins/hls-hlint-plugin/src@@ -713,10 +705,10 @@     , containers     , deepseq     , filepath-    , ghcide                == 2.8.0.0+    , ghcide                == 2.9.0.0     , hashable     , hlint                 >= 3.5 && < 3.9-    , hls-plugin-api        == 2.8.0.0+    , hls-plugin-api        == 2.9.0.0     , lens     , lsp     , mtl@@ -744,7 +736,7 @@  test-suite hls-hlint-plugin-tests   import:           defaults, pedantic, test-defaults, warnings-  if !flag(hlint)+  if !(flag(hlint) && impl(ghc < 9.10))     buildable: False   type:             exitcode-stdio-1.0   hs-source-dirs:   plugins/hls-hlint-plugin/test@@ -756,10 +748,9 @@     , filepath     , haskell-language-server:hls-hlint-plugin     , hls-plugin-api-    , hls-test-utils      == 2.8.0.0+    , hls-test-utils      == 2.9.0.0     , lens     , lsp-types-    , row-types     , text  -----------------------------@@ -818,7 +809,7 @@     , filepath     , haskell-language-server:hls-stan-plugin     , hls-plugin-api-    , hls-test-utils      == 2.8.0.0+    , hls-test-utils      == 2.9.0.0     , lens     , lsp-types     , text@@ -849,10 +840,9 @@     , aeson     , base                  >=4.12 && <5     , containers-    , directory     , filepath-    , ghcide                == 2.8.0.0-    , hls-plugin-api        == 2.8.0.0+    , ghcide                == 2.9.0.0+    , hls-plugin-api        == 2.9.0.0     , lsp     , text     , transformers@@ -869,7 +859,7 @@     , base     , filepath     , haskell-language-server:hls-module-name-plugin-    , hls-test-utils          == 2.8.0.0+    , hls-test-utils          == 2.9.0.0  ----------------------------- -- pragmas plugin@@ -895,8 +885,8 @@     , base                  >=4.12 && <5     , extra     , fuzzy-    , ghcide                == 2.8.0.0-    , hls-plugin-api        == 2.8.0.0+    , ghcide                == 2.9.0.0+    , hls-plugin-api        == 2.9.0.0     , lens     , lsp     , text@@ -915,7 +905,7 @@     , base     , filepath     , haskell-language-server:hls-pragmas-plugin-    , hls-test-utils      == 2.8.0.0+    , hls-test-utils      == 2.9.0.0     , lens     , lsp-types     , text@@ -930,13 +920,13 @@   manual:      True  common splice-  if flag(splice)+  if flag(splice) && impl(ghc < 9.10)     build-depends: haskell-language-server:hls-splice-plugin     cpp-options: -Dhls_splice  library hls-splice-plugin   import:           defaults, pedantic, warnings-  if !flag(splice)+  if !(flag(splice) && impl(ghc < 9.10))     buildable: False   exposed-modules:     Ide.Plugin.Splice@@ -950,8 +940,8 @@     , foldl     , ghc     , ghc-exactprint-    , ghcide                == 2.8.0.0-    , hls-plugin-api        == 2.8.0.0+    , ghcide                == 2.9.0.0+    , hls-plugin-api        == 2.9.0.0     , haskell-language-server:hls-refactor-plugin     , lens     , lsp@@ -966,7 +956,7 @@  test-suite hls-splice-plugin-tests   import:           defaults, pedantic, test-defaults, warnings-  if !flag(splice)+  if !(flag(splice) && impl(ghc < 9.10))     buildable: False   type:             exitcode-stdio-1.0   hs-source-dirs:   plugins/hls-splice-plugin/test@@ -975,9 +965,8 @@     , base     , filepath     , haskell-language-server:hls-splice-plugin-    , hls-test-utils == 2.8.0.0+    , hls-test-utils == 2.9.0.0     , text-    , row-types  ----------------------------- -- alternate number format plugin@@ -1004,12 +993,12 @@     , base                 >=4.12 && < 5     , containers     , extra-    , ghcide               == 2.8.0.0+    , ghcide               == 2.9.0.0     , ghc-boot-th     , hls-graph-    , hls-plugin-api       == 2.8.0.0+    , hls-plugin-api       == 2.9.0.0     , lens-    , lsp                  ^>=2.4+    , lsp                  ^>=2.7     , mtl     , regex-tdfa     , syb@@ -1033,7 +1022,7 @@     , base                 >=4.12 && < 5     , filepath     , haskell-language-server:hls-alternate-number-format-plugin-    , hls-test-utils       == 2.8.0.0+    , hls-test-utils       == 2.9.0.0     , regex-tdfa     , tasty-quickcheck     , text@@ -1066,8 +1055,8 @@   build-depends:     , base                  >=4.12 && <5     , containers-    , ghcide                == 2.8.0.0-    , hls-plugin-api        == 2.8.0.0+    , ghcide                == 2.9.0.0+    , hls-plugin-api        == 2.9.0.0     , lens     , lsp     , text@@ -1089,7 +1078,7 @@     , text     , filepath     , haskell-language-server:hls-qualify-imported-names-plugin-    , hls-test-utils             == 2.8.0.0+    , hls-test-utils             == 2.9.0.0  ----------------------------- -- code range plugin@@ -1120,9 +1109,9 @@     , containers     , deepseq     , extra-    , ghcide           == 2.8.0.0+    , ghcide           == 2.9.0.0     , hashable-    , hls-plugin-api   == 2.8.0.0+    , hls-plugin-api   == 2.9.0.0     , lens     , lsp     , mtl@@ -1145,7 +1134,7 @@     , bytestring     , filepath     , haskell-language-server:hls-code-range-plugin-    , hls-test-utils             == 2.8.0.0+    , hls-test-utils             == 2.9.0.0     , lens     , lsp     , lsp-test@@ -1174,8 +1163,8 @@   hs-source-dirs:   plugins/hls-change-type-signature-plugin/src   build-depends:     , base             >=4.12 && < 5-    , ghcide           == 2.8.0.0-    , hls-plugin-api   == 2.8.0.0+    , ghcide           == 2.9.0.0+    , hls-plugin-api   == 2.9.0.0     , lsp-types     , regex-tdfa     , syb@@ -1200,7 +1189,7 @@     , base                 >=4.12 && < 5     , filepath     , haskell-language-server:hls-change-type-signature-plugin-    , hls-test-utils       == 2.8.0.0+    , hls-test-utils       == 2.9.0.0     , regex-tdfa     , text   default-extensions:@@ -1234,12 +1223,12 @@     , containers     , extra     , ghc-    , ghcide                 == 2.8.0.0+    , ghcide                 == 2.9.0.0     , ghc-exactprint-    , hls-plugin-api         == 2.8.0.0+    , hls-plugin-api         == 2.9.0.0     , haskell-language-server:hls-refactor-plugin     , lens-    , lsp                    >=2.4+    , lsp                    >=2.7     , mtl     , text     , transformers@@ -1257,7 +1246,7 @@     , base     , filepath     , haskell-language-server:hls-gadt-plugin-    , hls-test-utils              == 2.8.0.0+    , hls-test-utils              == 2.9.0.0     , text  -----------------------------@@ -1285,10 +1274,10 @@     , containers     , deepseq     , extra-    , ghcide                == 2.8.0.0+    , ghcide                == 2.9.0.0     , hashable-    , hls-plugin-api        == 2.8.0.0-    , lsp                   >=2.4+    , hls-plugin-api        == 2.9.0.0+    , lsp                   >=2.7     , text    default-extensions: DataKinds@@ -1304,7 +1293,7 @@     , base     , filepath     , haskell-language-server:hls-explicit-fixity-plugin-    , hls-test-utils              == 2.8.0.0+    , hls-test-utils              == 2.9.0.0     , text  -----------------------------@@ -1328,8 +1317,8 @@   exposed-modules:  Ide.Plugin.ExplicitFields   build-depends:     , base                  >=4.12 && <5-    , ghcide                == 2.8.0.0-    , hls-plugin-api        == 2.8.0.0+    , ghcide                == 2.9.0.0+    , hls-plugin-api        == 2.9.0.0     , lsp     , lens     , hls-graph@@ -1355,7 +1344,7 @@     , filepath     , text     , haskell-language-server:hls-explicit-record-fields-plugin-    , hls-test-utils              == 2.8.0.0+    , hls-test-utils              == 2.9.0.0  ----------------------------- -- overloaded record dot plugin@@ -1403,7 +1392,7 @@     , filepath     , text     , haskell-language-server:hls-overloaded-record-dot-plugin-    , hls-test-utils              == 2.8.0.0+    , hls-test-utils              == 2.9.0.0   -----------------------------@@ -1416,29 +1405,30 @@   manual:      True  common floskell-  if flag(floskell)+  if flag(floskell) && impl(ghc < 9.10)     build-depends: haskell-language-server:hls-floskell-plugin     cpp-options: -Dhls_floskell  library hls-floskell-plugin   import:           defaults, pedantic, warnings-  if !flag(floskell)+  -- https://github.com/ennocramer/floskell/pull/82+  if !(flag(floskell) && impl(ghc < 9.10))     buildable: False   exposed-modules:  Ide.Plugin.Floskell   hs-source-dirs:   plugins/hls-floskell-plugin/src   build-depends:     , base            >=4.12 && <5     , floskell        ^>=0.11.0-    , ghcide          == 2.8.0.0-    , hls-plugin-api  == 2.8.0.0-    , lsp-types       ^>=2.1+    , ghcide          == 2.9.0.0+    , hls-plugin-api  == 2.9.0.0+    , lsp-types       ^>=2.3     , mtl     , text   test-suite hls-floskell-plugin-tests   import:           defaults, pedantic, test-defaults, warnings-  if !flag(floskell)+  if !(flag(floskell) && impl(ghc < 9.10))     buildable: False   type:             exitcode-stdio-1.0   hs-source-dirs:   plugins/hls-floskell-plugin/test@@ -1447,7 +1437,7 @@     , base     , filepath     , haskell-language-server:hls-floskell-plugin-    , hls-test-utils       == 2.8.0.0+    , hls-test-utils       == 2.9.0.0  ----------------------------- -- fourmolu plugin@@ -1472,17 +1462,17 @@   build-depends:     , base            >=4.12 && <5     , filepath-    , fourmolu        ^>= 0.14 || ^>= 0.15+    , fourmolu        ^>= 0.14 || ^>= 0.15 || ^>= 0.16     , ghc-boot-th-    , ghcide          == 2.8.0.0-    , hls-plugin-api  == 2.8.0.0+    , ghcide          == 2.9.0.0+    , hls-plugin-api  == 2.9.0.0     , lens     , lsp     , mtl     , process-extras  >= 0.7.1     , text     , transformers-+    , yaml  test-suite hls-fourmolu-plugin-tests   import:           defaults, pedantic, test-defaults, warnings@@ -1491,6 +1481,9 @@   type:             exitcode-stdio-1.0   hs-source-dirs:   plugins/hls-fourmolu-plugin/test   main-is:          Main.hs+  -- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/24648+  if os(darwin)+    ghc-options: -optl-Wl,-ld_classic   build-tool-depends:     fourmolu:fourmolu   build-depends:@@ -1499,7 +1492,7 @@     , filepath     , haskell-language-server:hls-fourmolu-plugin     , hls-plugin-api-    , hls-test-utils       == 2.8.0.0+    , hls-test-utils       == 2.9.0.0     , lsp-test  -----------------------------@@ -1527,8 +1520,8 @@     , extra     , filepath     , ghc-boot-th-    , ghcide          == 2.8.0.0-    , hls-plugin-api  == 2.8.0.0+    , ghcide          == 2.9.0.0+    , hls-plugin-api  == 2.9.0.0     , lsp     , mtl     , process-extras  >= 0.7.1@@ -1544,6 +1537,9 @@   type:             exitcode-stdio-1.0   hs-source-dirs:   plugins/hls-ormolu-plugin/test   main-is:          Main.hs+  -- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/24648+  if os(darwin)+    ghc-options: -optl-Wl,-ld_classic   build-tool-depends:     ormolu:ormolu   build-depends:@@ -1552,7 +1548,7 @@     , filepath     , haskell-language-server:hls-ormolu-plugin     , hls-plugin-api-    , hls-test-utils     == 2.8.0.0+    , hls-test-utils     == 2.9.0.0     , lsp-types     , ormolu @@ -1566,13 +1562,14 @@   manual:      True  common stylishHaskell-  if flag(stylishHaskell)+  if flag(stylishHaskell) && impl(ghc < 9.10)     build-depends: haskell-language-server:hls-stylish-haskell-plugin     cpp-options: -Dhls_stylishHaskell  library hls-stylish-haskell-plugin   import:           defaults, pedantic, warnings-  if !flag(stylishHaskell)+  -- https://github.com/haskell/stylish-haskell/issues/479+  if !(flag(stylishHaskell) && impl(ghc < 9.10))     buildable: False   exposed-modules:  Ide.Plugin.StylishHaskell   hs-source-dirs:   plugins/hls-stylish-haskell-plugin/src@@ -1581,8 +1578,8 @@     , directory     , filepath     , ghc-boot-th-    , ghcide           == 2.8.0.0-    , hls-plugin-api   == 2.8.0.0+    , ghcide           == 2.9.0.0+    , hls-plugin-api   == 2.9.0.0     , lsp-types     , mtl     , stylish-haskell  ^>=0.12 || ^>=0.13 || ^>=0.14@@ -1591,7 +1588,7 @@  test-suite hls-stylish-haskell-plugin-tests   import:           defaults, pedantic, test-defaults, warnings-  if !flag(stylishHaskell)+  if !(flag(stylishHaskell) && impl(ghc < 9.10))     buildable: False   type:             exitcode-stdio-1.0   hs-source-dirs:   plugins/hls-stylish-haskell-plugin/test@@ -1600,7 +1597,7 @@     , base     , filepath     , haskell-language-server:hls-stylish-haskell-plugin-    , hls-test-utils              == 2.8.0.0+    , hls-test-utils              == 2.9.0.0  ----------------------------- -- refactor plugin@@ -1653,8 +1650,8 @@     , bytestring     , ghc-boot     , regex-tdfa-    , ghcide                == 2.8.0.0-    , hls-plugin-api        == 2.8.0.0+    , ghcide                == 2.9.0.0+    , hls-plugin-api        == 2.9.0.0     , lsp     , text     , transformers@@ -1662,18 +1659,18 @@     , containers     , ghc-exactprint < 1 || >= 1.4     , extra-    , retrie     , syb     , hls-graph     , dlist     , deepseq     , mtl     , lens-    , data-default     , time     -- FIXME: Only needed to workaround for qualified imports in GHC 9.4     , regex-applicative     , parser-combinators+  if impl(ghc < 9.10)+    build-depends: data-default  test-suite hls-refactor-plugin-tests   import:           defaults, pedantic, test-defaults, warnings@@ -1686,25 +1683,23 @@   ghc-options:      -O0   build-depends:     , base+    , data-default+    , directory+    , extra     , filepath+    , ghcide:ghcide     , haskell-language-server:hls-refactor-plugin-    , hls-test-utils      == 2.8.0.0+    , hls-test-utils      == 2.9.0.0     , lens+    , lsp-test     , lsp-types-    , text-    , hls-plugin-api     , parser-combinators-    , data-default-    , extra-    , ghcide:{ghcide, ghcide-test-utils}-    , shake-    , hls-plugin-api-    , lsp-test-    , directory     , regex-tdfa-    , tasty-hunit-    , tasty-expected-failure+    , shake     , tasty+    , tasty-expected-failure+    , tasty-hunit+    , text  ----------------------------- -- semantic tokens plugin@@ -1742,10 +1737,10 @@     , extra     , text-rope     , mtl                   >= 2.2-    , ghcide                == 2.8.0.0-    , hls-plugin-api        == 2.8.0.0+    , ghcide                == 2.9.0.0+    , hls-plugin-api        == 2.9.0.0     , lens-    , lsp                    >=2.4+    , lsp                    >=2.6     , text     , transformers     , bytestring@@ -1753,7 +1748,7 @@     , array     , deepseq     , dlist-    , hls-graph == 2.8.0.0+    , hls-graph == 2.9.0.0     , template-haskell     , data-default     , stm@@ -1773,21 +1768,17 @@     , aeson     , base     , containers+    , data-default     , filepath+    , ghcide                == 2.9.0.0     , haskell-language-server:hls-semantic-tokens-plugin-    , hls-test-utils              == 2.8.0.0-    , ghcide:ghcide-test-utils-    , hls-plugin-api+    , hls-plugin-api        == 2.9.0.0+    , hls-test-utils        == 2.9.0.0     , lens     , lsp-    , text-rope     , lsp-test     , text-    , data-default-    , ghcide                == 2.8.0.0-    , hls-plugin-api        == 2.8.0.0-    , data-default-    , row-types+    , text-rope  ----------------------------- -- notes plugin@@ -1813,11 +1804,11 @@   build-depends:     , base >=4.12 && <5     , array-    , ghcide == 2.8.0.0-    , hls-graph == 2.8.0.0-    , hls-plugin-api == 2.8.0.0+    , ghcide == 2.9.0.0+    , hls-graph == 2.9.0.0+    , hls-plugin-api == 2.9.0.0     , lens-    , lsp >=2.4+    , lsp >=2.7     , mtl >= 2.2     , regex-tdfa >= 1.3.1     , text@@ -1840,11 +1831,9 @@   main-is:          NotesTest.hs   build-depends:     , base-    , directory     , filepath-    , ghcide:ghcide-test-utils     , haskell-language-server:hls-notes-plugin-    , hls-test-utils == 2.8.0.0+    , hls-test-utils == 2.9.0.0   default-extensions: OverloadedStrings  ----------------------------@@ -1905,10 +1894,10 @@     , extra     , filepath     , ghc-    , ghcide                == 2.8.0.0+    , ghcide                == 2.9.0.0     , githash               >=0.1.6.1     , hie-bios-    , hls-plugin-api        == 2.8.0.0+    , hls-plugin-api        == 2.9.0.0     , optparse-applicative     , optparse-simple     , prettyprinter         >= 1.7@@ -2012,10 +2001,10 @@     , deepseq     , extra     , filepath-    , ghcide:{ghcide, ghcide-test-utils}+    , ghcide:ghcide     , hashable     , hls-plugin-api-    , hls-test-utils == 2.8.0.0+    , hls-test-utils == 2.9.0.0     , lens     , lsp-test     , lsp-types@@ -2041,7 +2030,7 @@   if flag(eval)     cpp-options: -Dhls_eval -- formatters-  if flag(floskell)+  if flag(floskell) && impl(ghc < 9.10)     cpp-options: -Dhls_floskell   if flag(fourmolu)     cpp-options: -Dhls_fourmolu@@ -2060,7 +2049,7 @@   build-depends:     , base       >=4.16 && <5     , extra-    , hls-test-utils              == 2.8.0.0+    , hls-test-utils              == 2.9.0.0     , process    hs-source-dirs:     test/wrapper@@ -2074,7 +2063,7 @@     main-is: Main.hs     hs-source-dirs: bench     build-tool-depends:-        ghcide-bench:ghcide-bench,+        haskell-language-server:ghcide-bench,         hp2pretty:hp2pretty,     default-extensions:         LambdaCase@@ -2089,7 +2078,7 @@       , directory       , extra       , filepath-      , ghcide-bench+      , haskell-language-server:ghcide-bench-lib       , haskell-language-server       , hls-plugin-api       , lens@@ -2111,7 +2100,6 @@    build-depends:     , aeson-    , async     , base     , containers     , data-default@@ -2121,12 +2109,11 @@     , filepath     , fuzzy     , ghcide-    , ghcide:ghcide-test-utils     , hls-plugin-api     , lens     , list-t     , lsp-    , lsp-test                ^>=0.17.0.0+    , lsp-test                ^>=0.17.1     , lsp-types     , monoid-subclasses     , mtl@@ -2134,7 +2121,6 @@     , QuickCheck     , random     , regex-tdfa              ^>=1.3.1-    , row-types     , shake     , sqlite-simple     , stm@@ -2147,7 +2133,7 @@     , text     , text-rope     , unordered-containers-    , hls-test-utils == 2.8.0.0+    , hls-test-utils == 2.9.0.0    if impl(ghc <9.3)     build-depends: ghc-typelits-knownnat@@ -2188,7 +2174,6 @@     RootUriTests     SafeTests     SymlinkTests-    TestUtils     THTests     UnitTests     WatchedFileTests@@ -2199,3 +2184,95 @@     OverloadedStrings     RecordWildCards     ViewPatterns+++executable ghcide-bench+    default-language: GHC2021+    build-depends:+        aeson,+        base,+        bytestring,+        containers,+        data-default,+        extra,+        filepath,+        hls-plugin-api,+        hls-test-utils,+        lens,+        lsp-test,+        lsp-types,+        optparse-applicative,+        process,+        safe-exceptions,+        hls-graph,+        shake,+        tasty-hunit >= 0.10,+        text,+        haskell-language-server:ghcide-bench-lib,+    hs-source-dirs: ghcide-bench/exe+    ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts+    main-is: Main.hs+    default-extensions:+        LambdaCase+        OverloadedStrings+        RecordWildCards+        ViewPatterns++library ghcide-bench-lib+    default-language: GHC2021+    hs-source-dirs: ghcide-bench/src+    ghc-options: -Wall -Wno-name-shadowing+    exposed-modules:+        Experiments.Types+        Experiments+    build-depends:+        aeson,+        async,+        base == 4.*,+        binary,+        bytestring,+        deepseq,+        directory,+        extra,+        filepath,+        ghcide:{ghcide},+        hashable,+        lens,+        lsp-test,+        lsp-types,+        optparse-applicative,+        parser-combinators,+        process,+        safe-exceptions,+        shake,+        text,+        hls-test-utils,+        row-types+    default-extensions:+        LambdaCase+        RecordWildCards+        ViewPatterns+++test-suite ghcide-bench-test+    type: exitcode-stdio-1.0+    default-language: GHC2021+    build-tool-depends:+        ghcide:ghcide,+    main-is: Main.hs+    hs-source-dirs: ghcide-bench/test+    ghc-options: -Wunused-packages+    ghc-options: -threaded -Wall+    build-depends:+        base,+        extra,+        haskell-language-server:ghcide-bench-lib,+        lsp-test ^>= 0.17,+        tasty,+        tasty-hunit >= 0.10,+        tasty-rerun+    default-extensions:+        LambdaCase+        OverloadedStrings+        RecordWildCards+        ViewPatterns
plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs view
@@ -9,9 +9,10 @@  import           Data.Maybe                    (maybeToList) import           Data.Text                     (Text)-import qualified Data.Text                     as T #if __GLASGOW_HASKELL__ >= 908 import qualified Data.Text.Encoding            as T+#else+import qualified Data.Text                     as T #endif import           Development.IDE.GHC.Compat    hiding (getSrcSpan) import           Development.IDE.Graph.Classes (NFData (rnf))
plugins/hls-cabal-gild-plugin/test/testdata/lib_testdata.formatted_document.cabal view
@@ -17,4 +17,5 @@     testdata,    hs-source-dirs: app-  default-language: Haskell2010+  default-language:+    Haskell2010
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs view
@@ -6,13 +6,12 @@  module Ide.Plugin.Cabal (descriptor, Log (..)) where -import           Control.Concurrent.STM import           Control.Concurrent.Strict import           Control.DeepSeq import           Control.Lens                                ((^.)) import           Control.Monad.Extra import           Control.Monad.IO.Class-import           Control.Monad.Trans.Class                   (lift)+import           Control.Monad.Trans.Class import           Control.Monad.Trans.Maybe                   (runMaybeT) import qualified Data.ByteString                             as BS import           Data.Hashable@@ -24,21 +23,26 @@ import           Development.IDE                             as D import           Development.IDE.Core.Shake                  (restartShakeSession) import qualified Development.IDE.Core.Shake                  as Shake-import           Development.IDE.Graph                       (alwaysRerun)+import           Development.IDE.Graph                       (Key, alwaysRerun) import qualified Development.IDE.Plugin.Completions.Logic    as Ghcide import qualified Development.IDE.Plugin.Completions.Types    as Ghcide+import           Development.IDE.Types.Shake                 (toKey)+import qualified Distribution.Fields                         as Syntax+import qualified Distribution.Parsec.Position                as Syntax import           GHC.Generics import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes import qualified Ide.Plugin.Cabal.Completion.Completions     as Completions+import           Ide.Plugin.Cabal.Completion.Types           (ParseCabalFields (..),+                                                              ParseCabalFile (..)) import qualified Ide.Plugin.Cabal.Completion.Types           as Types import qualified Ide.Plugin.Cabal.Diagnostics                as Diagnostics import qualified Ide.Plugin.Cabal.LicenseSuggest             as LicenseSuggest+import           Ide.Plugin.Cabal.Orphans                    () import qualified Ide.Plugin.Cabal.Parse                      as Parse import           Ide.Types import qualified Language.LSP.Protocol.Lens                  as JL import qualified Language.LSP.Protocol.Message               as LSP import           Language.LSP.Protocol.Types-import           Language.LSP.Server                         (getVirtualFile) import qualified Language.LSP.VFS                            as VFS  data Log@@ -70,7 +74,7 @@       "Set files of interest to:" <+> viaShow files     LogCompletionContext context position ->       "Determined completion context:"-        <+> viaShow context+        <+> pretty context         <+> "for cursor position:"         <+> pretty position     LogCompletions logs -> pretty logs@@ -90,26 +94,26 @@               \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri, _version}) -> liftIO $ do                 whenUriFile _uri $ \file -> do                   log' Debug $ LogDocOpened _uri-                  addFileOfInterest recorder ide file Modified{firstOpen = True}-                  restartCabalShakeSession (shakeExtras ide) vfs file "(opened)"+                  restartCabalShakeSession (shakeExtras ide) vfs file "(opened)" $+                    addFileOfInterest recorder ide file Modified{firstOpen = True}           , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $               \ide vfs _ (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{_uri} _) -> liftIO $ do                 whenUriFile _uri $ \file -> do                   log' Debug $ LogDocModified _uri-                  addFileOfInterest recorder ide file Modified{firstOpen = False}-                  restartCabalShakeSession (shakeExtras ide) vfs file "(changed)"+                  restartCabalShakeSession (shakeExtras ide) vfs file "(changed)" $+                    addFileOfInterest recorder ide file Modified{firstOpen = False}           , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $               \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do                 whenUriFile _uri $ \file -> do                   log' Debug $ LogDocSaved _uri-                  addFileOfInterest recorder ide file OnDisk-                  restartCabalShakeSession (shakeExtras ide) vfs file "(saved)"+                  restartCabalShakeSession (shakeExtras ide) vfs file "(saved)" $+                    addFileOfInterest recorder ide file OnDisk           , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $               \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do                 whenUriFile _uri $ \file -> do                   log' Debug $ LogDocClosed _uri-                  deleteFileOfInterest recorder ide file-                  restartCabalShakeSession (shakeExtras ide) vfs file "(closed)"+                  restartCabalShakeSession (shakeExtras ide) vfs file "(closed)" $+                    deleteFileOfInterest recorder ide file           ]     , pluginConfigDescriptor = defaultConfigDescriptor       { configHasDiagnostics = True@@ -130,10 +134,11 @@ rule depends on. Then we restart the shake session, so that changes to our virtual files are actually picked up. -}-restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO ()-restartCabalShakeSession shakeExtras vfs file actionMsg = do-  join $ atomically $ Shake.recordDirtyKeys shakeExtras GetModificationTime [file]-  restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) []+restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO ()+restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do+  restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do+    keys <- actionBetweenSession+    return (toKey GetModificationTime file:keys)  -- ---------------------------------------------------------------- -- Plugin Rules@@ -144,31 +149,56 @@   -- Make sure we initialise the cabal files-of-interest.   ofInterestRules recorder   -- Rule to produce diagnostics for cabal files.-  define (cmapWithPrio LogShake recorder) $ \Types.GetCabalDiagnostics file -> do+  define (cmapWithPrio LogShake recorder) $ \ParseCabalFields file -> do     config <- getPluginConfigAction plId     if not (plcGlobalOn config && plcDiagnosticsOn config)-        then pure ([], Nothing)-        else do-          -- whenever this key is marked as dirty (e.g., when a user writes stuff to it),-          -- we rerun this rule because this rule *depends* on GetModificationTime.-          (t, mCabalSource) <- use_ GetFileContents file-          log' Debug $ LogModificationTime file t-          contents <- case mCabalSource of-            Just sources ->-              pure $ Encoding.encodeUtf8 sources-            Nothing -> do-              liftIO $ BS.readFile $ fromNormalizedFilePath file+      then pure ([], Nothing)+      else do+        -- whenever this key is marked as dirty (e.g., when a user writes stuff to it),+        -- we rerun this rule because this rule *depends* on GetModificationTime.+        (t, mCabalSource) <- use_ GetFileContents file+        log' Debug $ LogModificationTime file t+        contents <- case mCabalSource of+          Just sources ->+            pure $ Encoding.encodeUtf8 sources+          Nothing -> do+            liftIO $ BS.readFile $ fromNormalizedFilePath file -          (pWarnings, pm) <- liftIO $ Parse.parseCabalFileContents contents-          let warningDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings-          case pm of-            Left (_cabalVersion, pErrorNE) -> do-              let errorDiags = NE.toList $ NE.map (Diagnostics.errorDiagnostic file) pErrorNE-                  allDiags = errorDiags <> warningDiags-              pure (allDiags, Nothing)-            Right gpd -> do-              pure (warningDiags, Just gpd)+        case Parse.readCabalFields file contents of+          Left _ ->+            pure ([], Nothing)+          Right fields ->+            pure ([], Just fields) +  define (cmapWithPrio LogShake recorder) $ \ParseCabalFile file -> do+    config <- getPluginConfigAction plId+    if not (plcGlobalOn config && plcDiagnosticsOn config)+      then pure ([], Nothing)+      else do+        -- whenever this key is marked as dirty (e.g., when a user writes stuff to it),+        -- we rerun this rule because this rule *depends* on GetModificationTime.+        (t, mCabalSource) <- use_ GetFileContents file+        log' Debug $ LogModificationTime file t+        contents <- case mCabalSource of+          Just sources ->+            pure $ Encoding.encodeUtf8 sources+          Nothing -> do+            liftIO $ BS.readFile $ fromNormalizedFilePath file++        -- Instead of fully reparsing the sources to get a 'GenericPackageDescription',+        -- we would much rather re-use the already parsed results of 'ParseCabalFields'.+        -- Unfortunately, Cabal-syntax doesn't expose the function 'parseGenericPackageDescription''+        -- which allows us to resume the parsing pipeline with '[Field Position]'.+        (pWarnings, pm) <- liftIO $ Parse.parseCabalFileContents contents+        let warningDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings+        case pm of+          Left (_cabalVersion, pErrorNE) -> do+            let errorDiags = NE.toList $ NE.map (Diagnostics.errorDiagnostic file) pErrorNE+                allDiags = errorDiags <> warningDiags+            pure (allDiags, Nothing)+          Right gpd -> do+            pure (warningDiags, Just gpd)+   action $ do     -- Run the cabal kick. This code always runs when 'shakeRestart' is run.     -- Must be careful to not impede the performance too much. Crucial to@@ -187,15 +217,16 @@ kick :: Action () kick = do   files <- HashMap.keys <$> getCabalFilesOfInterestUntracked-  void $ uses Types.GetCabalDiagnostics files+  void $ uses Types.ParseCabalFile files  -- ---------------------------------------------------------------- -- Code Actions -- ----------------------------------------------------------------  licenseSuggestCodeAction :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction-licenseSuggestCodeAction _ _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=diags}) =-  pure $ InL $ diags >>= (fmap InR . LicenseSuggest.licenseErrorAction uri)+licenseSuggestCodeAction ideState _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=diags}) = do+  maxCompls <- fmap maxCompletions . liftIO $ runAction "cabal-plugin.suggestLicense" ideState getClientConfigAction+  pure $ InL $ diags >>= (fmap InR . LicenseSuggest.licenseErrorAction maxCompls uri)  -- ---------------------------------------------------------------- -- Cabal file of Interest rules and global variable@@ -249,24 +280,26 @@   OfInterestCabalVar var <- Shake.getIdeGlobalAction   liftIO $ readVar var -addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()+addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key] addFileOfInterest recorder state f v = do   OfInterestCabalVar var <- Shake.getIdeGlobalState state   (prev, files) <- modifyVar var $ \dict -> do     let (prev, new) = HashMap.alterF (,Just v) f dict     pure (new, (prev, new))-  when (prev /= Just v) $ do-    join $ atomically $ Shake.recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]-    log' Debug $ LogFOI files+  if prev /= Just v+    then do+        log' Debug $ LogFOI files+        return [toKey IsCabalFileOfInterest f]+    else return []  where   log' = logWith recorder -deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO ()+deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO [Key] deleteFileOfInterest recorder state f = do   OfInterestCabalVar var <- Shake.getIdeGlobalState state   files <- modifyVar' var $ HashMap.delete f-  join $ atomically $ Shake.recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]   log' Debug $ LogFOI files+  return [toKey IsFileOfInterest f]  where   log' = logWith recorder @@ -278,24 +311,36 @@ completion recorder ide _ complParams = do   let (TextDocumentIdentifier uri) = complParams ^. JL.textDocument       position = complParams ^. JL.position-  contents <- lift $ getVirtualFile $ toNormalizedUri uri-  case (contents, uriToFilePath' uri) of-    (Just cnts, Just path) -> do-      let pref = Ghcide.getCompletionPrefix position cnts-      let res = result pref path cnts-      liftIO $ fmap InL res-    _ -> pure . InR $ InR Null+  mVf <- lift $ pluginGetVirtualFile $ toNormalizedUri uri+  case (,) <$> mVf <*> uriToFilePath' uri of+    Just (cnts, path) -> do+      -- We decide on `useWithStale` here, since `useWithStaleFast` often leads to the wrong completions being suggested.+      -- In case it fails, we still will get some completion results instead of an error.+      mFields <- liftIO $ runAction "cabal-plugin.fields" ide $ useWithStale ParseCabalFields $ toNormalizedFilePath path+      case mFields of+        Nothing ->+          pure . InR $ InR Null+        Just (fields, _) -> do+          let pref = Ghcide.getCompletionPrefix position cnts+          let res = produceCompletions pref path fields+          liftIO $ fmap InL res+    Nothing -> pure . InR $ InR Null  where-  result :: Ghcide.PosPrefixInfo -> FilePath -> VFS.VirtualFile -> IO [CompletionItem]-  result prefix fp cnts = do-    runMaybeT context >>= \case+  completerRecorder = cmapWithPrio LogCompletions recorder++  produceCompletions :: Ghcide.PosPrefixInfo -> FilePath -> [Syntax.Field Syntax.Position] -> IO [CompletionItem]+  produceCompletions prefix fp fields = do+    runMaybeT (context fields) >>= \case       Nothing -> pure []       Just ctx -> do         logWith recorder Debug $ LogCompletionContext ctx pos         let completer = Completions.contextToCompleter ctx         let completerData = CompleterTypes.CompleterData               { getLatestGPD = do-                mGPD <- runIdeAction "cabal-plugin.modulesCompleter.gpd" (shakeExtras ide) $ useWithStaleFast Types.GetCabalDiagnostics $ toNormalizedFilePath fp+                -- We decide on useWithStaleFast here, since we mostly care about the file's meta information,+                -- thus, a quick response gives us the desired result most of the time.+                -- The `withStale` option is very important here, since we often call this rule with invalid cabal files.+                mGPD <- runIdeAction "cabal-plugin.modulesCompleter.gpd" (shakeExtras ide) $ useWithStaleFast ParseCabalFile $ toNormalizedFilePath fp                 pure $ fmap fst mGPD               , cabalPrefixInfo = prefInfo               , stanzaName =@@ -306,7 +351,6 @@         completions <- completer completerRecorder completerData         pure completions    where-    completerRecorder = cmapWithPrio LogCompletions recorder     pos = Ghcide.cursorPos prefix-    context = Completions.getContext completerRecorder prefInfo (cnts ^. VFS.file_text)+    context fields = Completions.getContext completerRecorder prefInfo fields     prefInfo = Completions.getCabalPrefixInfo fp prefix
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Paths.hs view
@@ -1,6 +1,7 @@ module Ide.Plugin.Cabal.Completion.Completer.Paths where  import qualified Data.List                         as List+import           Data.List.Extra                   (dropPrefix) import qualified Data.Text                         as T import           Distribution.PackageDescription   (Benchmark (..),                                                     BuildInfo (..),@@ -45,6 +46,32 @@   }   deriving (Eq, Show) ++{- | Posix.splitFileName modification, that drops trailing ./ if+  if wasn't present in the original path.++  Fix for the issue #3774+  Examples:++  >>> splitFileNameNoTrailingSlash ""+  ("", "")+  >>> splitFileNameNoTrailingSlash "./"+  ("./", "")+  >>> splitFileNameNoTrailingSlash "dir"+  ("", "dir")+  >>> splitFileNameNoTrailingSlash "./dir"+  ("./", "dir")+  >>> splitFileNameNoTrailingSlash "dir1/dir2"+  ("dir1/","dir2")+  >>> splitFileNameNoTrailingSlash "./dir1/dir2"+  ("./dir1/","dir2")+-}+splitFileNameNoTrailingSlash :: FilePath -> (String, String)+splitFileNameNoTrailingSlash prefix = rmTrailingSlash ("./" `List.isPrefixOf` prefix) (Posix.splitFileName prefix)+  where rmTrailingSlash hadTrailingSlash (queryDirectory', pathSegment')+                    | hadTrailingSlash = (queryDirectory', pathSegment')+                    | otherwise        = ("./" `dropPrefix` queryDirectory', pathSegment')+ {- | Takes an optional source subdirectory and a prefix info   and creates a path completion info accordingly. @@ -64,7 +91,7 @@     }   where     prefix = T.unpack $ completionPrefix prefInfo-    (queryDirectory', pathSegment') = Posix.splitFileName prefix+    (queryDirectory', pathSegment') = splitFileNameNoTrailingSlash prefix  -- | Extracts the source directories of the library stanza. sourceDirsExtractionLibrary :: Maybe StanzaName -> GenericPackageDescription -> [FilePath]
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs view
@@ -4,17 +4,15 @@  import           Control.Lens                                  ((^.)) import           Control.Monad.IO.Class                        (MonadIO)-import           Control.Monad.Trans.Maybe-import           Data.Foldable                                 (asum)-import qualified Data.List                                     as List-import           Data.Map                                      (Map)+import           Data.List.NonEmpty                            (NonEmpty)+import qualified Data.List.NonEmpty                            as NE import qualified Data.Map                                      as Map import qualified Data.Text                                     as T-import qualified Data.Text.Utf16.Lines                         as Rope (Position (..))-import           Data.Text.Utf16.Rope.Mixed                    (Rope)-import qualified Data.Text.Utf16.Rope.Mixed                    as Rope+import qualified Data.Text.Encoding                            as T import           Development.IDE                               as D import qualified Development.IDE.Plugin.Completions.Types      as Ghcide+import qualified Distribution.Fields                           as Syntax+import qualified Distribution.Parsec.Position                  as Syntax import           Ide.Plugin.Cabal.Completion.Completer.Simple import           Ide.Plugin.Cabal.Completion.Completer.Snippet import           Ide.Plugin.Cabal.Completion.Completer.Types   (Completer)@@ -64,32 +62,13 @@ --  Can return Nothing if an error occurs. -- --  TODO: first line can only have cabal-version: keyword-getContext :: (MonadIO m) => Recorder (WithPriority Log) -> CabalPrefixInfo -> Rope -> MaybeT m Context-getContext recorder prefInfo ls =-  case prevLinesM of-    Just prevLines -> do-      let lvlContext =-            if completionIndentation prefInfo == 0-              then TopLevel-              else currentLevel prevLines-      case lvlContext of-        TopLevel -> do-          kwContext <- MaybeT . pure $ getKeyWordContext prefInfo prevLines (cabalVersionKeyword <> cabalKeywords)-          pure (TopLevel, kwContext)-        Stanza s n ->-          case Map.lookup s stanzaKeywordMap of-            Nothing -> do-              pure (Stanza s n, None)-            Just m -> do-              kwContext <- MaybeT . pure $ getKeyWordContext prefInfo prevLines m-              pure (Stanza s n, kwContext)-    Nothing -> do-      logWith recorder Warning $ LogFileSplitError pos-      -- basically returns nothing-      fail "Abort computation"+getContext :: (MonadIO m) => Recorder (WithPriority Log) -> CabalPrefixInfo -> [Syntax.Field Syntax.Position] -> m Context+getContext recorder prefInfo fields = do+    let ctx = findCursorContext cursor (NE.singleton (0, TopLevel)) (completionPrefix prefInfo) fields+    logWith recorder Debug $ LogCompletionContext ctx+    pure ctx   where-    pos = completionCursorPosition prefInfo-    prevLinesM = splitAtPosition pos ls+    cursor = lspPositionToCabalPosition (completionCursorPosition prefInfo)  -- | Takes information about the current file's file path, --  and the cursor position in the file; and builds a CabalPrefixInfo@@ -144,84 +123,111 @@ -- Implementation Details -- ---------------------------------------------------------------- --- | Takes prefix info about the previously written text,---  a list of lines (representing a file) and a map of---  keywords and returns a keyword context if the---  previously written keyword matches one in the map.+findCursorContext ::+  Syntax.Position ->+  -- ^ The cursor position we look for in the fields+  NonEmpty (Int, StanzaContext) ->+  -- ^ A stack of current stanza contexts and their starting line numbers+  T.Text ->+  -- ^ The cursor's prefix text+  [Syntax.Field Syntax.Position] ->+  -- ^ The fields to traverse+  Context+findCursorContext cursor parentHistory prefixText fields =+  case findFieldSection cursor fields of+    Nothing -> (snd $ NE.head parentHistory, None)+    -- We found the most likely section. Now, are we starting a new section or are we completing an existing one?+    Just field@(Syntax.Field _ _) -> classifyFieldContext parentHistory cursor field+    Just section@(Syntax.Section _ args sectionFields)+      | inSameLineAsSectionName section -> (stanzaCtx, None) -- TODO: test whether keyword in same line is parsed correctly+      | otherwise ->+          findCursorContext cursor+            (NE.cons (Syntax.positionCol (getAnnotation section) + 1, Stanza (getFieldName section) (getOptionalSectionName args)) parentHistory)+            prefixText sectionFields+    where+        inSameLineAsSectionName section = Syntax.positionRow (getAnnotation section) == Syntax.positionRow cursor+        stanzaCtx = snd $ NE.head parentHistory++-- | Finds the cursor's context, where the cursor is already found to be in a specific field -----  From a cursor position, we traverse the cabal file upwards to---  find the latest written keyword if there is any.---  Values may be written on subsequent lines,---  in order to allow for this we take the indentation of the current---  word to be completed into account to find the correct keyword context.-getKeyWordContext :: CabalPrefixInfo -> [T.Text] -> Map KeyWordName a -> Maybe FieldContext-getKeyWordContext prefInfo ls keywords = do-  case lastNonEmptyLineM of-    Nothing -> Just None-    Just lastLine' -> do-      let (whiteSpaces, lastLine) = T.span (== ' ') lastLine'-      let keywordIndentation = T.length whiteSpaces-      let cursorIndentation = completionIndentation prefInfo-      -- in order to be in a keyword context the cursor needs-      -- to be indented more than the keyword-      if cursorIndentation > keywordIndentation-        then -- if the last thing written was a keyword without a value-        case List.find (`T.isPrefixOf` lastLine) (Map.keys keywords) of-          Nothing -> Just None-          Just kw -> Just $ KeyWord kw-        else Just None+-- Due to the way the field context is recognised for incomplete cabal files,+-- an incomplete keyword is also recognised as a field, therefore we need to determine+-- the specific context as we could still be in a stanza context in this case.+classifyFieldContext :: NonEmpty (Int, StanzaContext) -> Syntax.Position -> Syntax.Field Syntax.Position -> Context+classifyFieldContext ctx cursor field+  -- the cursor is not indented enough to be within the field+  -- but still indented enough to be within the stanza+  | cursorColumn <= fieldColumn && minIndent <= cursorColumn = (stanzaCtx, None)+  -- the cursor is not in the current stanza's context as it is not indented enough+  | cursorColumn < minIndent = findStanzaForColumn cursorColumn ctx+  | cursorIsInFieldName = (stanzaCtx, None)+  | cursorIsBeforeFieldName = (stanzaCtx, None)+  | otherwise = (stanzaCtx, KeyWord (getFieldName field <> ":"))   where-    lastNonEmptyLineM :: Maybe T.Text-    lastNonEmptyLineM = do-      (curLine, rest) <- List.uncons ls-      -- represents the current line while disregarding the-      -- currently written text we want to complete-      let cur = stripPartiallyWritten curLine-      List.find (not . T.null . T.stripEnd) $-        cur : rest+    (minIndent, stanzaCtx) = NE.head ctx --- | Traverse the given lines (starting before current cursor position---  up to the start of the file) to find the nearest stanza declaration,---  if none is found we are in the top level context.+    cursorIsInFieldName = inSameLineAsFieldName &&+      fieldColumn <= cursorColumn &&+      cursorColumn <= fieldColumn + T.length (getFieldName field)++    cursorIsBeforeFieldName = inSameLineAsFieldName &&+      cursorColumn < fieldColumn++    inSameLineAsFieldName = Syntax.positionRow (getAnnotation field) == Syntax.positionRow cursor++    cursorColumn = Syntax.positionCol cursor+    fieldColumn = Syntax.positionCol (getAnnotation field)++-- ----------------------------------------------------------------+-- Cabal-syntax utilities I don't really want to write myself+-- ----------------------------------------------------------------++-- | Determine the context of a cursor position within a stack of stanza contexts -----  TODO: this could be merged with getKeyWordContext in order to increase---  performance by reducing the number of times we have to traverse the cabal file.-currentLevel :: [T.Text] -> StanzaContext-currentLevel [] = TopLevel-currentLevel (cur : xs)-  | Just (s, n) <- stanza = Stanza s n-  | otherwise = currentLevel xs-  where-    stanza = asum $ map checkStanza (Map.keys stanzaKeywordMap)-    checkStanza :: StanzaType -> Maybe (StanzaType, Maybe StanzaName)-    checkStanza t =-      case T.stripPrefix t (T.strip cur) of-        Just n-          | T.null n -> Just (t, Nothing)-          | otherwise -> Just (t, Just $ T.strip n)-        Nothing -> Nothing+-- If the cursor is indented more than one of the stanzas in the stack+-- the respective stanza is returned if this is never the case, the toplevel stanza+-- in the stack is returned.+findStanzaForColumn :: Int -> NonEmpty (Int, StanzaContext) -> (StanzaContext, FieldContext)+findStanzaForColumn col ctx = case NE.uncons ctx of+    ((_, stanza), Nothing) -> (stanza, None)+    ((indentation, stanza), Just res)+        | col < indentation -> findStanzaForColumn col res+        | otherwise -> (stanza, None) --- | Get all lines before the given cursor position in the given file---  and reverse their order to traverse backwards starting from the given position.-splitAtPosition :: Position -> Rope -> Maybe [T.Text]-splitAtPosition pos ls = do-  split <- splitFile-  pure $ reverse $ Rope.lines $ fst split+-- | Determine the field the cursor is currently a part of.+--+-- The result is said field and its starting position+-- or Nothing if the passed list of fields is empty.++-- This only looks at the row of the cursor and not at the cursor's+-- position within the row.+--+-- TODO: we do not handle braces correctly. Add more tests!+findFieldSection :: Syntax.Position -> [Syntax.Field Syntax.Position] -> Maybe (Syntax.Field Syntax.Position)+findFieldSection _cursor [] = Nothing+findFieldSection _cursor [x] =+  -- Last field. We decide later, whether we are starting+  -- a new section.+  Just x+findFieldSection cursor (x:y:ys)+    | Syntax.positionRow (getAnnotation x) <= cursorLine && cursorLine < Syntax.positionRow (getAnnotation y)+    = Just x+    | otherwise = findFieldSection cursor (y:ys)   where-    splitFile = Rope.utf16SplitAtPosition ropePos ls-    ropePos =-      Rope.Position-        { Rope.posLine = fromIntegral $ pos ^. JL.line,-          Rope.posColumn = fromIntegral $ pos ^. JL.character-        }+    cursorLine = Syntax.positionRow cursor --- | Takes a line of text and removes the last partially--- written word to be completed.-stripPartiallyWritten :: T.Text -> T.Text-stripPartiallyWritten = T.dropWhileEnd (\y -> (y /= ' ') && (y /= ':'))+type FieldName = T.Text --- | Calculates how many spaces the currently completed item is indented.-completionIndentation :: CabalPrefixInfo -> Int-completionIndentation prefInfo = fromIntegral (pos ^. JL.character) - (T.length $ completionPrefix prefInfo)-  where-    pos = completionCursorPosition prefInfo+getAnnotation :: Syntax.Field ann -> ann+getAnnotation (Syntax.Field (Syntax.Name ann _) _)     = ann+getAnnotation (Syntax.Section (Syntax.Name ann _) _ _) = ann++getFieldName :: Syntax.Field ann -> FieldName+getFieldName (Syntax.Field (Syntax.Name _ fn) _)     = T.decodeUtf8 fn+getFieldName (Syntax.Section (Syntax.Name _ fn) _ _) = T.decodeUtf8 fn++getOptionalSectionName :: [Syntax.SectionArg ann] -> Maybe T.Text+getOptionalSectionName [] = Nothing+getOptionalSectionName (x:xs) = case x of+    Syntax.SecArgName _ name -> Just (T.decodeUtf8 name)+    _                        -> getOptionalSectionName xs
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Data.hs view
@@ -63,7 +63,7 @@       ("extra-tmp-files:", filePathCompleter)     ] --- | Map, containing all stanzas in a cabal file as keys+-- | Map, containing all stanzas in a cabal file as keys, --  and lists of their possible nested keywords as values. stanzaKeywordMap :: Map StanzaType (Map KeyWordName Completer) stanzaKeywordMap =@@ -73,6 +73,7 @@       ("test-suite", testSuiteFields <> libExecTestBenchCommons),       ("benchmark", benchmarkFields <> libExecTestBenchCommons),       ("foreign-library", foreignLibraryFields <> libExecTestBenchCommons),+      ("common", libExecTestBenchCommons),       ("flag", flagFields),       ("source-repository", sourceRepositoryFields)     ]
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs view
@@ -4,13 +4,17 @@  module Ide.Plugin.Cabal.Completion.Types where -import           Control.DeepSeq        (NFData)+import           Control.DeepSeq                 (NFData)+import           Control.Lens                    ((^.)) import           Data.Hashable-import qualified Data.Text              as T+import qualified Data.Text                       as T import           Data.Typeable-import           Development.IDE        as D+import           Development.IDE                 as D+import qualified Distribution.Fields             as Syntax+import qualified Distribution.PackageDescription as PD+import qualified Distribution.Parsec.Position    as Syntax import           GHC.Generics-import qualified Ide.Plugin.Cabal.Parse as Parse+import qualified Language.LSP.Protocol.Lens      as JL  data Log   = LogFileSplitError Position@@ -21,6 +25,7 @@   | LogFilePathCompleterIOError FilePath IOError   | LogUseWithStaleFastNoResult   | LogMapLookUpOfKnownKeyFailed T.Text+  | LogCompletionContext Context   deriving (Show)  instance Pretty Log where@@ -34,16 +39,26 @@       "When trying to complete the file path:" <+> pretty fp <+> "the following unexpected IO error occurred" <+> viaShow ioErr     LogUseWithStaleFastNoResult -> "Package description couldn't be read"     LogMapLookUpOfKnownKeyFailed key -> "Lookup of key in map failed even though it should exist" <+> pretty key+    LogCompletionContext ctx -> "Completion context is:" <+> pretty ctx -type instance RuleResult GetCabalDiagnostics = Parse.GenericPackageDescription+type instance RuleResult ParseCabalFile = PD.GenericPackageDescription -data GetCabalDiagnostics = GetCabalDiagnostics+data ParseCabalFile = ParseCabalFile   deriving (Eq, Show, Typeable, Generic) -instance Hashable GetCabalDiagnostics+instance Hashable ParseCabalFile -instance NFData GetCabalDiagnostics+instance NFData ParseCabalFile +type instance RuleResult ParseCabalFields = [Syntax.Field Syntax.Position]++data ParseCabalFields = ParseCabalFields+  deriving (Eq, Show, Typeable, Generic)++instance Hashable ParseCabalFields++instance NFData ParseCabalFields+ -- | The context a cursor can be in within a cabal file. -- --  We can be in stanzas or the top level,@@ -61,9 +76,13 @@     -- Stanzas have their own fields which differ from top-level fields.     -- Each stanza must be named, such as 'executable exe',     -- except for the main library.-    Stanza StanzaType (Maybe StanzaName)+    Stanza !StanzaType !(Maybe StanzaName)   deriving (Eq, Show, Read) +instance Pretty StanzaContext where+    pretty TopLevel      = "TopLevel"+    pretty (Stanza t ms) = "Stanza" <+> pretty t <+> (maybe mempty pretty ms)+ -- | Keyword context in a cabal file. -- --  Used to decide whether to suggest values or keywords.@@ -71,12 +90,16 @@   = -- | Key word context, where a keyword     -- occurs right before the current word     -- to be completed-    KeyWord KeyWordName+    KeyWord !KeyWordName   | -- | Keyword context where no keyword occurs     -- right before the current word to be completed     None   deriving (Eq, Show, Read) +instance Pretty FieldContext where+    pretty (KeyWord kw) = "KeyWord" <+> pretty kw+    pretty None         = "No Keyword"+ type KeyWordName = T.Text  type StanzaName = T.Text@@ -139,3 +162,12 @@ applyStringNotation Nothing compl   | Just _ <- T.find (== ' ') compl = "\"" <> compl <> "\""   | otherwise = compl++-- | Convert an LSP 'Position' to a 'Syntax.Position'.+--+-- Cabal Positions start their indexing at 1 while LSP starts at 0.+-- This helper makes sure, the translation is done properly.+lspPositionToCabalPosition :: Position -> Syntax.Position+lspPositionToCabalPosition pos = Syntax.Position+  (fromIntegral (pos ^. JL.line) + 1)+  (fromIntegral (pos ^. JL.character) + 1)
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs view
@@ -4,6 +4,7 @@ ( errorDiagnostic , warningDiagnostic , positionFromCabalPosition+, fatalParseErrorDiagnostic   -- * Re-exports , FileDiagnostic , Diagnostic(..)@@ -14,7 +15,7 @@ import           Development.IDE             (FileDiagnostic,                                               ShowDiagnostic (ShowDiag)) import           Distribution.Fields         (showPError, showPWarning)-import qualified Ide.Plugin.Cabal.Parse      as Lib+import qualified Distribution.Parsec         as Syntax import           Ide.PluginUtils             (extendNextLine) import           Language.LSP.Protocol.Types (Diagnostic (..),                                               DiagnosticSeverity (..),@@ -23,16 +24,21 @@                                               Range (Range),                                               fromNormalizedFilePath) +-- | Produce a diagnostic for a fatal Cabal parser error.+fatalParseErrorDiagnostic :: NormalizedFilePath -> T.Text -> FileDiagnostic+fatalParseErrorDiagnostic fp msg =+  mkDiag fp "cabal" DiagnosticSeverity_Error (toBeginningOfNextLine Syntax.zeroPos) msg+ -- | Produce a diagnostic from a Cabal parser error-errorDiagnostic :: NormalizedFilePath -> Lib.PError -> FileDiagnostic-errorDiagnostic fp err@(Lib.PError pos _) =+errorDiagnostic :: NormalizedFilePath -> Syntax.PError -> FileDiagnostic+errorDiagnostic fp err@(Syntax.PError pos _) =   mkDiag fp "cabal" DiagnosticSeverity_Error (toBeginningOfNextLine pos) msg   where     msg = T.pack $ showPError (fromNormalizedFilePath fp) err  -- | Produce a diagnostic from a Cabal parser warning-warningDiagnostic :: NormalizedFilePath -> Lib.PWarning -> FileDiagnostic-warningDiagnostic fp warning@(Lib.PWarning _ pos _) =+warningDiagnostic :: NormalizedFilePath -> Syntax.PWarning -> FileDiagnostic+warningDiagnostic fp warning@(Syntax.PWarning _ pos _) =   mkDiag fp "cabal" DiagnosticSeverity_Warning (toBeginningOfNextLine pos) msg   where     msg = T.pack $ showPWarning (fromNormalizedFilePath fp) warning@@ -41,7 +47,7 @@ -- only a single source code 'Lib.Position'. -- We define the range to be _from_ this position -- _to_ the first column of the next line.-toBeginningOfNextLine :: Lib.Position -> Range+toBeginningOfNextLine :: Syntax.Position -> Range toBeginningOfNextLine cabalPos = extendNextLine $ Range pos pos    where     pos = positionFromCabalPosition cabalPos@@ -53,8 +59,8 @@ -- -- >>> positionFromCabalPosition $ Lib.Position 1 1 -- Position 0 0-positionFromCabalPosition :: Lib.Position -> Position-positionFromCabalPosition (Lib.Position line column) = Position (fromIntegral line') (fromIntegral col')+positionFromCabalPosition :: Syntax.Position -> Position+positionFromCabalPosition (Syntax.Position line column) = Position (fromIntegral line') (fromIntegral col')   where     -- LSP is zero-based, Cabal is one-based     line' = line-1
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs view
@@ -31,13 +31,12 @@ --   with a suggestion, then return a 'CodeAction' for replacing the --   the incorrect license identifier with the suggestion. licenseErrorAction-  :: Uri-  -- ^ File for which the diagnostic was generated-  -> Diagnostic-  -- ^ Output of 'Ide.Plugin.Cabal.Diag.errorDiagnostic'+  :: Int -- ^ Maximum number of suggestions to return+  -> Uri -- ^ File for which the diagnostic was generated+  -> Diagnostic -- ^ Output of 'Ide.Plugin.Cabal.Diag.errorDiagnostic'   -> [CodeAction]-licenseErrorAction uri diag =-  mkCodeAction <$> licenseErrorSuggestion (_message diag)+licenseErrorAction maxCompletions uri diag =+  mkCodeAction <$> licenseErrorSuggestion maxCompletions (_message diag)   where     mkCodeAction (original, suggestion) =       let@@ -66,22 +65,22 @@ --   Results are sorted by best fit, and prefer solutions that have smaller --   length distance to the original word. ----- >>> take 2 $ licenseErrorSuggestion (T.pack "Unknown SPDX license identifier: 'BSD3'")+-- >>> licenseErrorSuggestion 2 (T.pack "Unknown SPDX license identifier: 'BSD3'") -- [("BSD3","BSD-3-Clause"),("BSD3","BSD-3-Clause-LBNL")] licenseErrorSuggestion ::-  T.Text-  -- ^ Output of 'Ide.Plugin.Cabal.Diag.errorDiagnostic'+  Int -- ^ Maximum number of suggestions to return+  -> T.Text -- ^ Output of 'Ide.Plugin.Cabal.Diag.errorDiagnostic'   -> [(T.Text, T.Text)]   -- ^ (Original (incorrect) license identifier, suggested replacement)-licenseErrorSuggestion msg =+licenseErrorSuggestion maxCompletions msg  =    (getMatch <$> msg =~~ regex) >>= \case           [original] ->-            let matches = map Fuzzy.original $ Fuzzy.simpleFilter Fuzzy.defChunkSize Fuzzy.defMaxResults original licenseNames-            in [(original,candidate) | candidate <- List.sortBy (lengthDistance original) matches]+            let matches = map Fuzzy.original $ Fuzzy.simpleFilter Fuzzy.defChunkSize maxCompletions original licenseNames+            in [(original,candidate) | candidate <- List.sortOn (lengthDistance original) matches]           _ -> []   where     regex :: T.Text     regex = "Unknown SPDX license identifier: '(.*)'"     getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> [T.Text]     getMatch (_, _, _, results) = results-    lengthDistance original x1 x2 = abs (T.length original - T.length x1) `compare` abs (T.length original - T.length x2)+    lengthDistance original x = abs $ T.length original - T.length x
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Orphans.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module Ide.Plugin.Cabal.Orphans where+import           Control.DeepSeq+import           Distribution.Fields.Field+import           Distribution.Parsec.Position++-- ----------------------------------------------------------------+-- Cabal-syntax orphan instances we need sometimes+-- ----------------------------------------------------------------++instance NFData (Field Position) where+    rnf (Field name fieldLines) = rnf name `seq` rnf fieldLines+    rnf (Section name sectionArgs fields) =  rnf name `seq` rnf sectionArgs `seq` rnf fields++instance NFData (Name Position) where+    rnf (Name ann fName) = rnf ann `seq` rnf fName++instance NFData (FieldLine Position) where+    rnf (FieldLine ann bs) = rnf ann `seq` rnf bs++instance NFData (SectionArg Position) where+    rnf (SecArgName ann bs)  = rnf ann `seq` rnf bs+    rnf (SecArgStr ann bs)   = rnf ann `seq` rnf bs+    rnf (SecArgOther ann bs) = rnf ann `seq` rnf bs
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs view
@@ -1,13 +1,7 @@+{-# LANGUAGE OverloadedStrings #-} module Ide.Plugin.Cabal.Parse ( parseCabalFileContents-  -- * Re-exports-, FilePath-, NonEmpty(..)-, PWarning(..)-, Version-, PError(..)-, Position(..)-, GenericPackageDescription(..)+, readCabalFields ) where  import qualified Data.ByteString                              as BS@@ -16,12 +10,31 @@                                                                PWarning (..)) import           Distribution.Fields.ParseResult              (runParseResult) import           Distribution.PackageDescription.Parsec       (parseGenericPackageDescription)-import           Distribution.Parsec.Position                 (Position (..)) import           Distribution.Types.GenericPackageDescription (GenericPackageDescription (..)) import           Distribution.Types.Version                   (Version)+import qualified Ide.Plugin.Cabal.Diagnostics                 as Diagnostics +import qualified Data.Text                                    as T+import           Development.IDE+import qualified Distribution.Fields.Parser                   as Syntax+import qualified Distribution.Parsec.Position                 as Syntax++ parseCabalFileContents   :: BS.ByteString -- ^ UTF-8 encoded bytestring   -> IO ([PWarning], Either (Maybe Version, NonEmpty PError) GenericPackageDescription) parseCabalFileContents bs =   pure $ runParseResult (parseGenericPackageDescription bs)++readCabalFields ::+  NormalizedFilePath ->+  BS.ByteString ->+  Either FileDiagnostic [Syntax.Field Syntax.Position]+readCabalFields file contents  = do+  case Syntax.readFields' contents of+    Left parseError ->+      Left $ Diagnostics.fatalParseErrorDiagnostic file+           $ "Failed to parse cabal file: " <> T.pack (show parseError)+    Right (fields, _warnings) -> do+      -- we don't want to double report diagnostics, all diagnostics are produced by 'ParseCabalFile'.+      Right fields
plugins/hls-cabal-plugin/test/Completer.hs view
@@ -9,6 +9,7 @@ import           Data.Maybe                                     (mapMaybe) import qualified Data.Text                                      as T import qualified Development.IDE.Plugin.Completions.Types       as Ghcide+import           Distribution.PackageDescription                (GenericPackageDescription) import           Distribution.PackageDescription.Parsec         (parseGenericPackageDescriptionMaybe) import           Ide.Plugin.Cabal.Completion.Completer.FilePath import           Ide.Plugin.Cabal.Completion.Completer.Module@@ -17,7 +18,6 @@ import           Ide.Plugin.Cabal.Completion.Completions import           Ide.Plugin.Cabal.Completion.Types              (CabalPrefixInfo (..),                                                                  StanzaName)-import           Ide.Plugin.Cabal.Parse                         (GenericPackageDescription) import qualified Language.LSP.Protocol.Lens                     as L import           System.FilePath import           Test.Hls@@ -51,12 +51,17 @@         compls <- getCompletions doc (Position 8 2)         let complTexts = getTextEditTexts compls         liftIO $ assertBool "suggests benchmark" $ "benchmark" `elem` complTexts+    , runCabalTestCaseSession "In top level context - stanza should be suggested" "" $ do+        doc <- openDoc "completer.cabal" "cabal"+        compls <- getCompletions doc (Position 13 2)+        let complTexts = getTextEditTexts compls+        liftIO $ assertBool "suggests common" $ "common" `elem` complTexts     , runCabalTestCaseSession "Main-is completions should be relative to hs-source-dirs of same stanza" "filepath-completions" $ do         doc <- openDoc "main-is.cabal" "cabal"         compls <- getCompletions doc (Position 10 12)         let complTexts = getTextEditTexts compls-        liftIO $ assertBool "suggests f2" $ "./f2.hs" `elem` complTexts-        liftIO $ assertBool "does not suggest" $ "./Content.hs" `notElem` complTexts+        liftIO $ assertBool "suggests f2" $ "f2.hs" `elem` complTexts+        liftIO $ assertBool "does not suggest" $ "Content.hs" `notElem` complTexts     ]     where       getTextEditTexts :: [CompletionItem] -> [T.Text]@@ -66,21 +71,21 @@ fileCompleterTests =   testGroup     "File Completer Tests"-    [ testCase "Current Directory" $ do+    [ testCase "Current Directory - no leading ./ by default" $ do         completions <- completeFilePath "" filePathComplTestDir-        completions @?== ["./.hidden", "./Content.hs", "./dir1/", "./dir2/", "./textfile.txt", "./main-is.cabal"],+        completions @?== [".hidden", "Content.hs", "dir1/", "dir2/", "textfile.txt", "main-is.cabal"],       testCase "Current Directory - alternative writing" $ do         completions <- completeFilePath "./" filePathComplTestDir         completions @?== ["./.hidden", "./Content.hs", "./dir1/", "./dir2/", "./textfile.txt", "./main-is.cabal"],       testCase "Current Directory - hidden file start" $ do         completions <- completeFilePath "." filePathComplTestDir-        completions @?== ["./Content.hs", "./.hidden", "./textfile.txt", "./main-is.cabal"],+        completions @?== ["Content.hs", ".hidden", "textfile.txt", "main-is.cabal"],       testCase "Current Directory - incomplete directory path written" $ do         completions <- completeFilePath "di" filePathComplTestDir-        completions @?== ["./dir1/", "./dir2/"],+        completions @?== ["dir1/", "dir2/"],       testCase "Current Directory - incomplete filepath written" $ do         completions <- completeFilePath "te" filePathComplTestDir-        completions @?== ["./Content.hs", "./textfile.txt"],+        completions @?== ["Content.hs", "textfile.txt"],       testCase "Subdirectory" $ do         completions <- completeFilePath "dir1/" filePathComplTestDir         completions @?== ["dir1/f1.txt", "dir1/f2.hs"],@@ -165,15 +170,15 @@ directoryCompleterTests =   testGroup     "Directory Completer Tests"-    [ testCase "Current Directory" $ do+    [ testCase "Current Directory - no leading ./ by default" $ do         completions <- completeDirectory "" filePathComplTestDir-        completions @?== ["./dir1/", "./dir2/"],+        completions @?== ["dir1/", "dir2/"],       testCase "Current Directory - alternative writing" $ do         completions <- completeDirectory "./" filePathComplTestDir         completions @?== ["./dir1/", "./dir2/"],       testCase "Current Directory - incomplete directory path written" $ do         completions <- completeDirectory "di" filePathComplTestDir-        completions @?== ["./dir1/", "./dir2/"],+        completions @?== ["dir1/", "dir2/"],       testCase "Current Directory - incomplete filepath written" $ do         completions <- completeDirectory "te" filePathComplTestDir         completions @?== [],
plugins/hls-cabal-plugin/test/Context.hs view
@@ -1,18 +1,20 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE LambdaCase               #-} {-# LANGUAGE OverloadedStrings        #-}+{-# LANGUAGE QuasiQuotes              #-}  module Context where -import           Control.Monad.Trans.Maybe                   (runMaybeT) import qualified Data.Text                                   as T-import qualified Data.Text.Utf16.Rope.Mixed                  as Rope+import qualified Data.Text.Encoding                          as Text+import           Development.IDE.Plugin.Completions.Types    (PosPrefixInfo (..)) import           Ide.Plugin.Cabal import           Ide.Plugin.Cabal.Completion.Completer.Paths import           Ide.Plugin.Cabal.Completion.Completions import           Ide.Plugin.Cabal.Completion.Types           (Context,                                                               FieldContext (KeyWord, None),                                                               StanzaContext (Stanza, TopLevel))+import qualified Ide.Plugin.Cabal.Parse                      as Parse import           Test.Hls import           Utils                                       as T @@ -22,7 +24,7 @@ contextTests :: TestTree contextTests =     testGroup-        "Context Tests "+        "Context Tests"         [ pathCompletionInfoFromCompletionContextTests         , getContextTests         ]@@ -31,12 +33,12 @@ pathCompletionInfoFromCompletionContextTests =     testGroup         "Completion Info to Completion Context Tests"-        [ testCase "Current Directory" $ do+        [ testCase "Current Directory - no leading ./ by default" $ do             let complInfo = pathCompletionInfoFromCabalPrefixInfo "" $ simpleCabalPrefixInfoFromFp "" testDataDir-            queryDirectory complInfo @?= "./"+            queryDirectory complInfo @?= ""         , testCase "Current Directory - partly written next" $ do             let complInfo = pathCompletionInfoFromCabalPrefixInfo "" $ simpleCabalPrefixInfoFromFp "di" testDataDir-            queryDirectory complInfo @?= "./"+            queryDirectory complInfo @?= ""             pathSegment complInfo @?= "di"         , testCase "Current Directory - alternative writing" $ do             let complInfo = pathCompletionInfoFromCabalPrefixInfo "" $ simpleCabalPrefixInfoFromFp "./" testDataDir@@ -58,39 +60,39 @@ getContextTests :: TestTree getContextTests =     testGroup-        "Context Tests"+        "Context Tests Real"         [ testCase "Empty File - Start" $ do             -- for a completely empty file, the context needs to             -- be top level without a specified keyword-            ctx <- callGetContext (Position 0 0) "" [""]+            ctx <- callGetContext (Position 0 0) "" ""             ctx @?= (TopLevel, None)         , testCase "Cabal version keyword - no value, no space after :" $ do             -- on a file, where the keyword is already written             -- the context should still be toplevel but the keyword should be recognized-            ctx <- callGetContext (Position 0 14) "" ["cabal-version:"]+            ctx <- callGetContext (Position 0 14) "" "cabal-version:\n"             ctx @?= (TopLevel, KeyWord "cabal-version:")         , testCase "Cabal version keyword - cursor in keyword" $ do             -- on a file, where the keyword is already written             -- but the cursor is in the middle of the keyword,             -- we are not in a keyword context-            ctx <- callGetContext (Position 0 5) "cabal" ["cabal-version:"]+            ctx <- callGetContext (Position 0 5) "cabal" "cabal-version:\n"             ctx @?= (TopLevel, None)         , testCase "Cabal version keyword - no value, many spaces" $ do             -- on a file, where the "cabal-version:" keyword is already written             -- the context should still be top level but the keyword should be recognized-            ctx <- callGetContext (Position 0 45) "" ["cabal-version:" <> T.replicate 50 " "]+            ctx <- callGetContext (Position 0 45) "" ("cabal-version:" <> T.replicate 50 " " <> "\n")             ctx @?= (TopLevel, KeyWord "cabal-version:")         , testCase "Cabal version keyword - keyword partly written" $ do             -- in the first line of the file, if the keyword             -- has not been written completely, the keyword context             -- should still be None-            ctx <- callGetContext (Position 0 5) "cabal" ["cabal"]+            ctx <- callGetContext (Position 0 5) "cabal" "cabal"             ctx @?= (TopLevel, None)         , testCase "Cabal version keyword - value partly written" $ do             -- in the first line of the file, if the keyword             -- has not been written completely, the keyword context             -- should still be None-            ctx <- callGetContext (Position 0 17) "1." ["cabal-version: 1."]+            ctx <- callGetContext (Position 0 17) "1." "cabal-version: 1."             ctx @?= (TopLevel, KeyWord "cabal-version:")         , testCase "Inside Stanza - no keyword" $ do             -- on a file, where the library stanza has been defined@@ -102,14 +104,15 @@             -- has been defined, the keyword and stanza should be recognized             ctx <- callGetContext (Position 4 21) "" libraryStanzaData             ctx @?= (Stanza "library" Nothing, KeyWord "build-depends:")-        , expectFailBecause "While not valid, it is not that important to make the code more complicated for this" $-            testCase "Cabal version keyword - no value, next line" $ do-                -- if the cabal version keyword has been written but without a value,-                -- in the next line we still should be in top level context with no keyword-                -- since the cabal version keyword and value pair need to be in the same line-                ctx <- callGetContext (Position 1 2) "" ["cabal-version:", ""]-                ctx @?= (TopLevel, None)-        , testCase "Non-cabal-version keyword - no value, next line indentented position" $ do+        , testCase "Cabal version keyword - no value, next line" $ do+            -- if the cabal version keyword has been written but without a value,+            -- in the next line we still should be in top level context with no keyword+            -- since the cabal version keyword and value pair need to be in the same line.+            -- However, that's too much work to implement for virtually no benefit, so we+            -- test here the status-quo is satisfied.+            ctx <- callGetContext (Position 1 2) "" "cabal-version:\n\n"+            ctx @?= (TopLevel, KeyWord "cabal-version:")+        , testCase "Non-cabal-version keyword - no value, next line indented position" $ do             -- if a keyword, other than the cabal version keyword has been written             -- with no value, in the next line we still should be in top level keyword context             -- of the keyword with no value, since its value may be written in the next line@@ -153,46 +156,133 @@             ctx @?= (TopLevel, KeyWord "name:")         , testCase "Named Stanza" $ do             ctx <- callGetContext (Position 2 18) "" executableStanzaData-            ctx @?= (Stanza "executable" (Just "exeName"), None)+            ctx @?= (TopLevel, None)+        , testCase "Multi line, finds context in same line" $ do+            ctx <- callGetContext (Position 5 18) "" multiLineOptsData+            ctx @?= (Stanza "library" Nothing, KeyWord "build-depends:")+        , testCase "Multi line, in the middle of option" $ do+            ctx <- callGetContext (Position 6 11) "" multiLineOptsData+            ctx @?= (Stanza "library" Nothing, KeyWord "build-depends:")+        , testCase "Multi line, finds context in between lines" $ do+            ctx <- callGetContext (Position 7 8) "" multiLineOptsData+            ctx @?= (Stanza "library" Nothing, KeyWord "build-depends:")+        , testCase "Multi line, finds context in between lines, start if line" $ do+            ctx <- callGetContext (Position 7 0) "" multiLineOptsData+            ctx @?= (TopLevel, None)+        , testCase "Multi line, end of option" $ do+            ctx <- callGetContext (Position 8 14) "" multiLineOptsData+            ctx @?= (Stanza "library" Nothing, KeyWord "build-depends:")+        , parameterisedCursorTest "Contexts in large testfile" multiPositionTestData+            [ (TopLevel, None)+            , (TopLevel, KeyWord "cabal-version:")+            , (TopLevel, None)+            , (TopLevel, KeyWord "description:")+            , (TopLevel, KeyWord "extra-source-files:")+            , (TopLevel, None)+            -- this might not be what we want, maybe add another Context+            , (TopLevel, None)+            -- this might not be what we want, maybe add another Context+            , (TopLevel, None)+            , (Stanza "source-repository" (Just "head"), None)+            , (Stanza "source-repository" (Just "head"), KeyWord "type:")+            , (Stanza "source-repository" (Just "head"), KeyWord "type:")+            , (Stanza "source-repository" (Just "head"), KeyWord "type:")+            , (Stanza "source-repository" (Just "head"), None)+            , (Stanza "common" (Just "cabalfmt"), None)+            , (Stanza "common" (Just "cabalfmt"), None)+            , (Stanza "common" (Just "cabalfmt"), KeyWord "build-depends:")+            ]+            $ \fileContent posPrefInfo ->+                callGetContext (cursorPos posPrefInfo) (prefixText posPrefInfo) fileContent         ]   where-    callGetContext :: Position -> T.Text -> [T.Text] -> IO Context+    callGetContext :: Position -> T.Text -> T.Text -> IO Context     callGetContext pos pref ls = do-        runMaybeT (getContext mempty (simpleCabalPrefixInfoFromPos pos pref) (Rope.fromText $ T.unlines ls))-            >>= \case-                Nothing -> assertFailure "Context must be found"-                Just ctx -> pure ctx+        case Parse.readCabalFields "not-real" (Text.encodeUtf8 ls) of+            Left err -> fail $ show err+            Right fields -> do+                getContext mempty (simpleCabalPrefixInfoFromPos pos pref) fields  -- ------------------------------------------------------------------------ -- Test Data -- ------------------------------------------------------------------------ -libraryStanzaData :: [T.Text]-libraryStanzaData =-    [ "cabal-version:      3.0"-    , "name:               simple-cabal"-    , "library "-    , "    default-language: Haskell98"-    , "    build-depends:    "-    , "           "-    , "ma  "-    ]+libraryStanzaData :: T.Text+libraryStanzaData = [trimming|+cabal-version:      3.0+name:               simple-cabal+library+    default-language: Haskell98+    build-depends: -executableStanzaData :: [T.Text]-executableStanzaData =-    [ "cabal-version:      3.0"-    , "name:               simple-cabal"-    , "executable exeName"-    , "    default-language: Haskell2010"-    , "    hs-source-dirs: test/preprocessor"-    ]+ma+|] -topLevelData :: [T.Text]-topLevelData =-    [ "cabal-version:      3.0"-    , "name:"-    , ""-    , ""-    , ""-    , "          eee"-    ]+executableStanzaData :: T.Text+executableStanzaData = [trimming|+cabal-version:      3.0+name:               simple-cabal+executable exeName+    default-language: Haskell2010+    hs-source-dirs: test/preprocessor+|]++topLevelData :: T.Text+topLevelData = [trimming|+cabal-version:      3.0+name:++++          eee+|]++multiLineOptsData :: T.Text+multiLineOptsData = [trimming|+cabal-version:      3.0+name:+++library+    build-depends:+        base,++        text ,+|]++multiPositionTestData :: T.Text+multiPositionTestData = [trimming|+cabal-version:      3.4+       ^             ^+category:           Development+^+name:               haskell-language-server+description:+  Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>+    ^+extra-source-files:+  README.md+  ChangeLog.md+  test/testdata/**/*.project+  test/testdata/**/*.cabal+  test/testdata/**/*.yaml+  test/testdata/**/*.hs+  test/testdata/**/*.json+    ^+  -- These globs should only match test/testdata+  plugins/**/*.project++source-repository head+     ^              ^   ^+  type:     git+    ^    ^    ^  ^+  location: https://github.com/haskell/haskell-language-server++  ^+common cabalfmt++  ^+  build-depends: haskell-language-server:hls-cabal-fmt-plugin+    ^            ^+  cpp-options: -Dhls_cabalfmt+|]
plugins/hls-cabal-plugin/test/Main.hs view
@@ -1,5 +1,5 @@+{-# LANGUAGE CPP                      #-} {-# LANGUAGE DisambiguateRecordFields #-}-{-# LANGUAGE OverloadedLabels         #-} {-# LANGUAGE OverloadedStrings        #-}  module Main (@@ -12,7 +12,6 @@ import           Control.Monad                   (guard) import qualified Data.ByteString                 as BS import           Data.Either                     (isRight)-import           Data.Row import qualified Data.Text                       as T import qualified Data.Text                       as Text import           Ide.Plugin.Cabal.LicenseSuggest (licenseErrorSuggestion)@@ -62,15 +61,23 @@         "Code Action Tests"         [ testCase "Unknown format" $ do             -- the message has the wrong format-            licenseErrorSuggestion "Unknown license identifier: 'BSD3' Do you mean BSD-3-Clause?" @?= []+            licenseErrorSuggestion maxCompletions "Unknown license identifier: 'BSD3' Do you mean BSD-3-Clause?" @?= []         , testCase "BSD-3-Clause" $ do-            take 2 (licenseErrorSuggestion "Unknown SPDX license identifier: 'BSD3' Do you mean BSD-3-Clause?")-                @?= [("BSD3", "BSD-3-Clause"), ("BSD3", "BSD-3-Clause-LBNL")]+            take 2 (licenseErrorSuggestion maxCompletions "Unknown SPDX license identifier: 'BSD3' Do you mean BSD-3-Clause?")+                @?=+-- Cabal-syntax 3.12.0.0 added bunch of new licenses, so now more licenses match "BSD3" pattern+#if MIN_VERSION_Cabal_syntax(3,12,0)+                    [("BSD3", "BSD-4.3RENO"), ("BSD3", "BSD-3-Clause")]+#else+                    [("BSD3", "BSD-3-Clause"), ("BSD3", "BSD-3-Clause-LBNL")]+#endif         , testCase "MiT" $ do             -- contains no suggestion-            take 2 (licenseErrorSuggestion "Unknown SPDX license identifier: 'MiT'")+            take 2 (licenseErrorSuggestion maxCompletions "Unknown SPDX license identifier: 'MiT'")                 @?= [("MiT", "MIT"), ("MiT", "MIT-0")]         ]+  where+    maxCompletions = 100  -- ------------------------ ------------------------------------------------ -- Integration Tests@@ -106,8 +113,7 @@                 expectNoMoreDiagnostics 1 hsDoc "typechecking"                 cabalDoc <- openDoc "simple-cabal.cabal" "cabal"                 expectNoMoreDiagnostics 1 cabalDoc "parsing"-            , ignoreTestBecause "Testcase is flaky for certain GHC versions (e.g. 9.2.5). See #3333 for details." $ do-                runCabalTestCaseSession "Diagnostics in .hs files from invalid .cabal file" "simple-cabal" $ do+            , runCabalTestCaseSession "Diagnostics in .hs files from invalid .cabal file" "simple-cabal" $ do                     hsDoc <- openDoc "A.hs" "haskell"                     expectNoMoreDiagnostics 1 hsDoc "typechecking"                     cabalDoc <- openDoc "simple-cabal.cabal" "cabal"@@ -117,13 +123,11 @@                     changeDoc                         cabalDoc                         [ TextDocumentContentChangeEvent $-                            InL $-                                #range-                                    .== theRange-                                    .+ #rangeLength-                                    .== Nothing-                                    .+ #text-                                    .== "MIT3"+                            InL TextDocumentContentChangePartial+                                { _range = theRange+                                , _rangeLength = Nothing+                                , _text = "MIT3"+                                }                         ]                     cabalDiags <- waitForDiagnosticsFrom cabalDoc                     unknownLicenseDiag <- liftIO $ inspectDiagnostic cabalDiags ["Unknown SPDX license identifier: 'MIT3'"]
plugins/hls-cabal-plugin/test/testdata/completer.cabal view
@@ -10,3 +10,5 @@  library     lib++co
plugins/hls-call-hierarchy-plugin/test/Main.hs view
@@ -113,13 +113,14 @@   , testGroup "data family"       [ testCase "1" $ do           let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "data family A"]-              range = mkRange 1 0 1 11+              -- Since GHC 9.10 the range also includes the family name (and its parameters if any)+              range = mkRange 1 0 1 (if ghcVersion == GHC910 then 13 else 11)               selRange = mkRange 1 12 1 13               expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange           oneCaseWithCreate contents 1 12 expected       , testCase "2" $ do           let contents = T.unlines [ "{-# LANGUAGE TypeFamilies #-}" , "data family A a"]-              range = mkRange 1 0 1 11+              range = mkRange 1 0 1 (if ghcVersion == GHC910 then 15 else 11)               selRange = mkRange 1 12 1 13               expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange           oneCaseWithCreate contents 1 12 expected
plugins/hls-change-type-signature-plugin/test/Main.hs view
@@ -25,8 +25,7 @@                                                  mkPluginTestDescriptor',                                                  openDoc, runSessionWithServer,                                                  testCase, testGroup, toEither,-                                                 type (|?),-                                                 waitForAllProgressDone,+                                                 type (|?), waitForBuildQueue,                                                  waitForDiagnostics, (@?=)) import           Text.Regex.TDFA                ((=~)) @@ -40,7 +39,8 @@ test = testGroup "changeTypeSignature" [         testRegexes         , codeActionTest "TExpectedActual" 4 11-        , knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "Error Message in 9.2/9.4 does not provide enough info" $ codeActionTest "TRigidType" 4 14+        , knownBrokenForGhcVersions [GHC92 .. GHC910] "Error Message in 9.2+ does not provide enough info" $+            codeActionTest "TRigidType" 4 14         , codeActionTest "TRigidType2" 4 6         , codeActionTest "TLocalBinding" 7 22         , codeActionTest "TLocalBindingShadow1" 11 8@@ -96,7 +96,7 @@ codeActionTest :: FilePath -> Int -> Int -> TestTree codeActionTest fp line col = goldenChangeSignature fp $ \doc -> do     void waitForDiagnostics  -- code actions are triggered from Diagnostics-    void waitForAllProgressDone  -- apparently some tests need this to get the CodeAction to show up+    void waitForBuildQueue  -- apparently some tests need this to get the CodeAction to show up     actions <- getCodeActions doc (pointRange line col)     foundActions <- findChangeTypeActions actions     liftIO $ length foundActions @?= 1
plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs view
@@ -39,11 +39,10 @@ import qualified Language.LSP.Protocol.Lens           as L import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types-import           Language.LSP.Server  addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsParams addMethodPlaceholders _ state _ param@AddMinimalMethodsParams{..} = do-    caps <- lift getClientCapabilities+    caps <- lift pluginGetClientCapabilities     nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri)     pm <- runActionE "classplugin.addMethodPlaceholders.GetParsedModule" state         $ useE GetParsedModule nfp@@ -58,7 +57,7 @@             then mergeEdit (workspaceEdit caps old new) pragmaInsertion             else workspaceEdit caps old new -    void $ lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ())+    void $ lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ())      pure $ InR Null     where@@ -81,7 +80,7 @@ -- sensitive to the format of diagnostic messages from GHC. codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCodeAction codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do-    verTxtDocId <- lift $ getVersionedTextDoc docId+    verTxtDocId <- lift $ pluginGetVersionedTextDoc docId     nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri)     actions <- join <$> mapM (mkActions nfp verTxtDocId) methodDiags     pure $ InL actions@@ -95,7 +94,7 @@             :: NormalizedFilePath             -> VersionedTextDocumentIdentifier             -> Diagnostic-            -> ExceptT PluginError (LspT Ide.Plugin.Config.Config IO) [Command |? CodeAction]+            -> ExceptT PluginError (HandlerM Ide.Plugin.Config.Config) [Command |? CodeAction]         mkActions docPath verTxtDocId diag = do             (HAR {hieAst = ast}, pmap) <- runActionE "classplugin.findClassIdentifier.GetHieAst" state                 $ useWithStaleE GetHieAst docPath@@ -166,7 +165,7 @@         findImplementedMethods             :: HieASTs a             -> Position-            -> ExceptT PluginError (LspT Ide.Plugin.Config.Config IO) [T.Text]+            -> ExceptT PluginError (HandlerM Ide.Plugin.Config.Config) [T.Text]         findImplementedMethods asts instancePosition = do             pure                 $ concat
plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs view
@@ -23,7 +23,6 @@ import qualified Language.LSP.Protocol.Lens           as L import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types-import           Language.LSP.Server                  (sendRequest)  -- The code lens method is only responsible for providing the ranges of the code -- lenses matched to a unique id@@ -83,7 +82,7 @@         pragmaInsertion =             maybeToList $ flip insertNewPragma InstanceSigs <$> mbPragma         wEdit = workspaceEdit pragmaInsertion-    _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) (\_ -> pure ())+    _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) (\_ -> pure ())     pure $ InR Null     where         workspaceEdit pragmaInsertion=
plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs view
@@ -5,22 +5,30 @@ module Ide.Plugin.Class.ExactPrint where  import           Control.Monad.Trans.Maybe+import           Data.Either.Extra                       (eitherToMaybe)+import           Data.Functor.Identity                   (Identity) import qualified Data.Text                               as T import           Development.IDE.GHC.Compat+import           GHC.Parser.Annotation import           Ide.Plugin.Class.Types import           Ide.Plugin.Class.Utils import           Language.Haskell.GHC.ExactPrint import           Language.Haskell.GHC.ExactPrint.Parsers--import           Data.Either.Extra                       (eitherToMaybe)-import           Data.Functor.Identity                   (Identity)-import           GHC.Parser.Annotation import           Language.LSP.Protocol.Types             (Range) +#if MIN_VERSION_ghc(9,9,0)+import           Control.Lens                            (_head, over)+#endif+ makeEditText :: Monad m => ParsedModule -> DynFlags -> AddMinimalMethodsParams -> MaybeT m (T.Text, T.Text) makeEditText pm df AddMinimalMethodsParams{..} = do     mDecls <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup-    let ps = makeDeltaAst $ pm_parsed_source pm+    let ps =+#if !MIN_VERSION_ghc(9,9,0)+            makeDeltaAst $+#endif+                pm_parsed_source pm+         old = T.pack $ exactPrint ps         (ps', _, _) = runTransform (addMethodDecls ps mDecls range withSig)         new = T.pack $ exactPrint ps'@@ -44,9 +52,33 @@     go inserting = do         allDecls <- hsDecls ps         case break (inRange range . getLoc) allDecls of-            (before, L l inst : after) -> replaceDecls ps (before ++ L l (addWhere inst):(map newLine inserting ++ after))-            (before, []) -> replaceDecls ps before+            (before, L l inst : after) ->+                let+                    instSpan = realSrcSpan $ getLoc l+                    instCol = srcSpanStartCol instSpan+#if MIN_VERSION_ghc(9,9,0)+                    instRow = srcSpanEndLine instSpan+                    methodEpAnn = noAnnSrcSpanDP $ deltaPos 1 (instCol + defaultIndent)+                    -- Put each TyCl method/type signature on separate line, indented by 2 spaces relative to instance decl+                    newLine (L _ e) = L methodEpAnn e +                    -- Set DeltaPos for following declarations so they don't move undesirably+                    resetFollowing =+                        over _head (\followingDecl ->+                            let followingDeclRow = srcSpanStartLine $ realSrcSpan $ getLoc followingDecl+                                delta = DifferentLine (followingDeclRow - instRow) instCol+                            in setEntryDP followingDecl delta)+#else+                    newLine (L l e) =+                        let dp = deltaPos 1 (instCol + defaultIndent - 1)+                        in L (noAnnSrcSpanDP (getLoc l) dp <> l) e++                    resetFollowing = id+#endif+                in replaceDecls ps (before ++ L l (addWhere inst):(map newLine inserting ++ resetFollowing after))+            (before, []) ->+                replaceDecls ps before+     -- Add `where` keyword for `instance X where` if `where` is missing.     --     -- The `where` in ghc-9.2 is now stored in the instance declaration@@ -56,20 +88,29 @@     --     -- See the link for the original definition:     --   https://hackage.haskell.org/package/ghc-9.2.1/docs/Language-Haskell-Syntax-Extension.html#t:XCClsInstDecl+    addWhere :: HsDecl GhcPs -> HsDecl GhcPs     addWhere instd@(InstD xInstD (ClsInstD ext decl@ClsInstDecl{..})) =         case cid_ext of-            (EpAnn entry anns comments, key) ->+#if MIN_VERSION_ghc(9,9,0)+            (warnings, anns, key)+                | any (\(AddEpAnn kw _ )-> kw == AnnWhere) anns -> instd+                | otherwise ->                     InstD xInstD (ClsInstD ext decl {-                    cid_ext = (EpAnn-                                entry-                                (AddEpAnn AnnWhere (EpaDelta (SameLine 1) []) : anns)-                                comments-                                , key)+                    cid_ext = ( warnings+                              , AddEpAnn AnnWhere d1 : anns+                              , key+                              )                     })+#else+            (EpAnn entry anns comments, key) ->+                InstD xInstD (ClsInstD ext decl {+                cid_ext = (EpAnn+                            entry+                            (AddEpAnn AnnWhere d1 : anns)+                            comments+                          , key+                          )+                })             _ -> instd+#endif     addWhere decl = decl--    newLine (L l e) =-        let dp = deltaPos 1 defaultIndent-        in L (noAnnSrcSpanDP (getLoc l) dp <> l) e-
plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs view
@@ -133,7 +133,11 @@ getInstanceBindLensRule :: Recorder (WithPriority Log) -> Rules () getInstanceBindLensRule recorder = do     defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetInstanceBindLens nfp -> runMaybeT $ do+#if MIN_VERSION_ghc(9,9,0)+        tmr@(tmrRenamed ->  (hs_tyclds -> tycls, _, _, _, _)) <- useMT TypeCheck nfp+#else         tmr@(tmrRenamed ->  (hs_tyclds -> tycls, _, _, _)) <- useMT TypeCheck nfp+#endif         (InstanceBindTypeSigsResult allBinds) <- useMT GetInstanceBindTypeSigs nfp          let -- declared instance methods without signatures
plugins/hls-class-plugin/test/Main.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE LambdaCase        #-}-{-# LANGUAGE OverloadedLabels  #-} {-# LANGUAGE OverloadedLists   #-} {-# LANGUAGE OverloadedStrings #-} @@ -13,7 +12,6 @@ import           Control.Monad                 (void) import           Data.Foldable                 (find) import           Data.Maybe-import           Data.Row                      ((.==)) import qualified Data.Text                     as T import qualified Ide.Plugin.Class              as Class import qualified Language.LSP.Protocol.Lens    as L@@ -65,9 +63,10 @@       getActionByTitle "Add placeholders for 'g'"   , goldenWithClass "Creates a placeholder for other two methods" "T6" "2" $       getActionByTitle "Add placeholders for 'g','h'"-  , onlyRunForGhcVersions [GHC92, GHC94] "Only ghc-9.2+ enabled GHC2021 implicitly" $-      goldenWithClass "Don't insert pragma with GHC2021" "InsertWithGHC2021Enabled" "" $-        getActionByTitle "Add placeholders for '==' with signature(s)"+  , goldenWithClass "Creates a placeholder when all top-level decls are indented" "T7" "" $+      getActionByTitle "Add placeholders for 'g','h','i'"+  , goldenWithClass "Don't insert pragma with GHC2021" "InsertWithGHC2021Enabled" "" $+      getActionByTitle "Add placeholders for '==' with signature(s)"   , goldenWithClass "Insert pragma if not exist" "InsertWithoutPragma" "" $       getActionByTitle "Add placeholders for '==' with signature(s)"   , goldenWithClass "Don't insert pragma if exist" "InsertWithPragma" "" $@@ -86,7 +85,7 @@      -- Change the doc to ensure the version is not 0     changeDoc doc-        [ TextDocumentContentChangeEvent . InR . (.==) #text $+        [ TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $             T.unlines ["module Version where", "data A a = A a", "instance Functor A where"]         ]     ver2 <- (^. L.version) <$> getVersionedDoc doc@@ -134,8 +133,7 @@     , goldenCodeLens "Apply code lens for local class" "LocalClassDefine" 0     , goldenCodeLens "Apply code lens on the same line" "Inline" 0     , goldenCodeLens "Don't insert pragma while existing" "CodeLensWithPragma" 0-    , onlyRunForGhcVersions [GHC92, GHC94] "Only ghc-9.2+ enabled GHC2021 implicitly" $-        goldenCodeLens "Don't insert pragma while GHC2021 enabled" "CodeLensWithGHC2021" 0+    , goldenCodeLens "Don't insert pragma while GHC2021 enabled" "CodeLensWithGHC2021" 0     , goldenCodeLens "Qualified name" "Qualified" 0     , goldenCodeLens "Type family" "TypeFamily" 0     , testCase "keep stale lens" $ do
plugins/hls-class-plugin/test/testdata/T5.expected.hs view
@@ -1,4 +1,4 @@-module T1 where+module T5 where  data X = X
plugins/hls-class-plugin/test/testdata/T5.hs view
@@ -1,4 +1,4 @@-module T1 where+module T5 where  data X = X
+ plugins/hls-class-plugin/test/testdata/T7.expected.hs view
@@ -0,0 +1,20 @@+module T7 where++    data X = X++    class Test a where+      f :: a -> a+      g :: a+      h :: a -> a+      i :: a++    instance Test X where+      f X = X+      g = _+      h = _+      i = _+++++    whiteSpaceBeforeAndIndentationOfThisShouldBePreserved = ()
+ plugins/hls-class-plugin/test/testdata/T7.hs view
@@ -0,0 +1,17 @@+module T7 where++    data X = X++    class Test a where+      f :: a -> a+      g :: a+      h :: a -> a+      i :: a++    instance Test X where+      f X = X+++++    whiteSpaceBeforeAndIndentationOfThisShouldBePreserved = ()
plugins/hls-code-range-plugin/test/Main.hs view
@@ -35,7 +35,7 @@         ]  selectionRangeGoldenTest :: TestName -> [(UInt, UInt)] -> TestTree-selectionRangeGoldenTest testName positions = goldenGitDiff testName (testDataDir </> testName <.> "golden" <.> "txt") $ do+selectionRangeGoldenTest testName positions = goldenGitDiff testName (testDataDir </> testName <.> "golden" <.> "txt" <> ghcSuffix) $ do     res <- runSessionWithServer def plugin testDataDir $ do         doc <- openDoc (testName <.> "hs") "haskell"         resp <- request SMethod_TextDocumentSelectionRange $ SelectionRangeParams Nothing Nothing doc@@ -43,7 +43,7 @@         let res = resp ^. result         pure $ fmap (showSelectionRangesForTest . absorbNull) res     case res of-        Left (ResponseError (InL LSPErrorCodes_RequestFailed) _ _) -> pure ""+        Left (TResponseError (InL LSPErrorCodes_RequestFailed) _ _) -> pure ""         Left err     -> assertFailure (show err)         Right golden -> pure golden   where@@ -65,7 +65,7 @@         showLBS = fromString . show  foldingRangeGoldenTest :: TestName -> TestTree-foldingRangeGoldenTest testName = goldenGitDiff  testName (testDataDir </> testName <.> "golden" <.> "txt") $ do+foldingRangeGoldenTest testName = goldenGitDiff  testName (testDataDir </> testName <.> "golden" <.> "txt" <> ghcSuffix) $ do     res <- runSessionWithServer def plugin testDataDir $ do         doc <- openDoc (testName <.> "hs") "haskell"         resp <- request SMethod_TextDocumentFoldingRange $ FoldingRangeParams Nothing Nothing doc@@ -91,3 +91,6 @@          showLBS = fromString . show         showFRK = fromString . show++ghcSuffix :: String+ghcSuffix = if ghcVersion >= GHC910 then ".ghc910" else ""
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs view
@@ -23,8 +23,8 @@ import qualified Control.Exception                            as E import           Control.Lens                                 (_1, _3, ix, (%~),                                                                (<&>), (^.))-import           Control.Monad                                (guard, void,-                                                               when)+import           Control.Monad                                (guard, join,+                                                               void, when) import           Control.Monad.IO.Class                       (MonadIO (liftIO)) import           Control.Monad.Trans.Except                   (ExceptT (..),                                                                runExceptT)@@ -47,7 +47,8 @@                                                                NeedsCompilation (NeedsCompilation),                                                                TypeCheck (..),                                                                tmrTypechecked)-import           Development.IDE.Core.Shake                   (useNoFile_,+import           Development.IDE.Core.Shake                   (shakeExtras,+                                                               useNoFile_,                                                                useWithStale_,                                                                use_, uses_) import           Development.IDE.GHC.Compat                   hiding (typeKind,@@ -91,8 +92,10 @@ import           Development.IDE.Types.HscEnvEq               (HscEnvEq (hscEnv)) import qualified GHC.LanguageExtensions.Type                  as LangExt (Extension (..)) +import           Control.Concurrent.STM.Stats                 (atomically) import           Development.IDE.Core.FileStore               (setSomethingModified) import           Development.IDE.Core.PluginUtils+import           Development.IDE.Graph                        (ShakeOptions (shakeExtra)) import           Development.IDE.Types.Shake                  (toKey) import           GHC.Types.SrcLoc                             (UnhelpfulSpanReason (UnhelpfulInteractive)) import           Ide.Logger                                   (Priority (..),@@ -200,7 +203,7 @@ runEvalCmd recorder plId st mtoken EvalParams{..} =     let dbg = logWith recorder Debug         perf = timed (\lbl duration -> dbg $ LogExecutionTime lbl duration)-        cmd :: ExceptT PluginError (LspM Config) WorkspaceEdit+        cmd :: ExceptT PluginError (HandlerM Config) WorkspaceEdit         cmd = do             let tests = map (\(a,_,b) -> (a,b)) $ testsBySection sections @@ -211,10 +214,14 @@              -- enable codegen for the module which we need to evaluate.             final_hscEnv <- liftIO $ bracket_-              (do queueForEvaluation st nfp-                  setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval")-              (do unqueueForEvaluation st nfp-                  setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval")+              (setSomethingModified VFSUnmodified st "Eval" $ do+                queueForEvaluation st nfp+                return [toKey IsEvaluating nfp]+                )+              (setSomethingModified VFSUnmodified st "Eval" $ do+                unqueueForEvaluation st nfp+                return [toKey IsEvaluating nfp]+                )               (initialiseSessionForEval (needsQuickCheck tests) st nfp)              evalCfg <- liftIO $ runAction "eval: config" st $ getEvalConfig plId@@ -231,7 +238,7 @@              return workspaceEdits      in perf "evalCmd" $ ExceptT $-            withIndefiniteProgress "Evaluating" mtoken Cancellable $ \_updater ->+            pluginWithIndefiniteProgress "Evaluating" mtoken Cancellable $ \_updater ->                 runExceptT $ response' cmd  -- | Create an HscEnv which is suitable for performing interactive evaluation.@@ -298,11 +305,11 @@         p = Position l c      in TextEdit (Range p p) "\n" -moduleText :: MonadLsp c m => Uri -> ExceptT PluginError m Text+moduleText :: Uri -> ExceptT PluginError (HandlerM config) Text moduleText uri =     handleMaybeM (PluginInternalError "mdlText") $       (virtualFileText <$>)-          <$> getVirtualFile+          <$> pluginGetVirtualFile               (toNormalizedUri uri)  testsBySection :: [Section] -> [(Section, EvalId, Test)]
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP                #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings  #-} {-# LANGUAGE RecordWildCards    #-}@@ -24,7 +25,7 @@ import           Data.Functor                             ((<&>)) import           Data.Functor.Identity import           Data.List.NonEmpty                       (NonEmpty ((:|)))-import qualified Data.List.NonEmpty                       as NE+import qualified Data.List.NonEmpty                       as NE hiding (unzip) import           Data.Map.Strict                          (Map) import qualified Data.Map.Strict                          as Map import qualified Data.Text                                as T@@ -40,6 +41,12 @@                                                            eol, hspace,                                                            letterChar) +#if MIN_VERSION_base(4,19,0)+import qualified Data.Functor                             as NE (unzip)+#else+import qualified Data.List.NonEmpty                       as NE (unzip)+#endif+ {- We build parsers combining the following three kinds of them: @@ -57,7 +64,7 @@ -}  -- | Line parser-type LineParser a = forall m. Monad m => ParsecT Void String m a+type LineParser a = forall m. ParsecT Void String m a  -- | Line comment group parser type LineGroupParser = Parsec Void [(Range, RawLineComment)]
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs view
@@ -13,21 +13,19 @@ import           Data.IORef import qualified Data.Map.Strict                      as Map import           Data.String                          (fromString)-import           Development.IDE                      (GetModSummaryWithoutTimestamps (GetModSummaryWithoutTimestamps),-                                                       GetParsedModuleWithComments (GetParsedModuleWithComments),+import           Development.IDE                      (GetParsedModuleWithComments (GetParsedModuleWithComments),                                                        IdeState,+                                                       LinkableType (BCOLinkable),                                                        NeedsCompilation (NeedsCompilation),                                                        NormalizedFilePath,                                                        RuleBody (RuleNoDiagnostics),                                                        Rules, defineEarlyCutoff,                                                        encodeLinkableType,                                                        fromNormalizedFilePath,-                                                       msrModSummary,                                                        realSrcSpanToRange,                                                        useWithStale_, use_) import           Development.IDE.Core.PositionMapping (toCurrentRange)-import           Development.IDE.Core.Rules           (computeLinkableTypeForDynFlags,-                                                       needsCompilationRule)+import           Development.IDE.Core.Rules           (needsCompilationRule) import           Development.IDE.Core.Shake           (IsIdeGlobal,                                                        RuleBody (RuleWithCustomNewnessCheck),                                                        addIdeGlobal,@@ -121,11 +119,10 @@ redefinedNeedsCompilation :: Recorder (WithPriority Log) -> Rules () redefinedNeedsCompilation recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation f -> do     isEvaluating <- use_ IsEvaluating f--    if not isEvaluating then needsCompilationRule f else do-        ms <- msrModSummary . fst <$> useWithStale_ GetModSummaryWithoutTimestamps f-        let df' = ms_hspp_opts ms-            linkableType = computeLinkableTypeForDynFlags df'+    if isEvaluating then do+        let linkableType = BCOLinkable             fp = encodeLinkableType $ Just linkableType-         pure (Just fp, Just (Just linkableType))+    else+        needsCompilationRule f+
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs view
@@ -38,6 +38,8 @@                                                         srcLocStartCol,                                                         srcLocStartLine) import           Ide.Plugin.Error+import           Ide.Types                             (HandlerM,+                                                        pluginSendRequest) import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types import           Language.LSP.Server@@ -55,13 +57,13 @@ isLiterate :: FilePath -> Bool isLiterate x = takeExtension x `elem` [".lhs", ".lhs-boot"] -response' :: ExceptT PluginError (LspM c) WorkspaceEdit -> ExceptT PluginError (LspM c) (Value |? Null)+response' :: ExceptT PluginError (HandlerM c) WorkspaceEdit -> ExceptT PluginError (HandlerM c) (Value |? Null) response' act = do     res <-  ExceptT (runExceptT act              `catchAny` \e -> do                 res <- showErr e                 pure . Left  . PluginInternalError $ fromString res)-    _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing res) (\_ -> pure ())+    _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing res) (\_ -> pure ())     pure $ InR Null  gStrictTry :: (MonadIO m, MonadCatch m) => m b -> m (Either String b)
plugins/hls-eval-plugin/test/Main.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE MultiWayIf        #-}-{-# LANGUAGE OverloadedLabels  #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-} {-# LANGUAGE ViewPatterns      #-}@@ -15,7 +13,6 @@ import           Data.List                  (isInfixOf) import           Data.List.Extra            (nubOrdOn) import qualified Data.Map                   as Map-import           Data.Row import qualified Data.Text                  as T import           Ide.Plugin.Config          (Config) import qualified Ide.Plugin.Config          as Plugin@@ -87,7 +84,6 @@   , goldenWithEval "Shows a kind with :kind" "T12" "hs"   , goldenWithEval "Reports an error for an incorrect type with :kind" "T13" "hs"   , goldenWithEval' "Returns a fully-instantiated type for :type" "T14" "hs" (if ghcVersion >= GHC98 then "ghc98.expected" else "expected") -- See https://gitlab.haskell.org/ghc/ghc/-/issues/24069-  , knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "type +v does not work anymore with 9.2" $ goldenWithEval "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" "T15" "hs"   , goldenWithEval "Doesn't break in module containing main function" "T4139" "hs"   , goldenWithEval "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments" "T16" "hs"   , goldenWithEval ":type reports an error when given with unknown +x option" "T17" "hs"@@ -130,16 +126,14 @@   , goldenWithEval "The default language extensions for the eval plugin are the same as those for ghci" "TSameDefaultLanguageExtensionsAsGhci" "hs"   , goldenWithEval "IO expressions are supported, stdout/stderr output is ignored" "TIO" "hs"   , goldenWithEvalAndFs "Property checking" cabalProjectFS "TProperty" "hs"-  , knownBrokenInEnv [HostOS Windows] "The output has path separators in it, which on Windows look different. Just skip it there" $ goldenWithEvalAndFs' "Property checking with exception" cabalProjectFS "TPropertyError" "hs" (-        if ghcVersion >= GHC98 then-          "ghc98.expected"-        else if ghcVersion >= GHC96 then-          "ghc96.expected"-        else if ghcVersion >= GHC94 then-          "ghc94.expected"-        else-          "expected"-      )+  , knownBrokenInEnv [HostOS Windows] "The output has path separators in it, which on Windows look different. Just skip it there" $+      goldenWithEvalAndFs' "Property checking with exception" cabalProjectFS "TPropertyError" "hs" $+        case ghcVersion of+          GHC910 -> "ghc910.expected"+          GHC98  -> "ghc98.expected"+          GHC96  -> "ghc96.expected"+          GHC94  -> "ghc94.expected"+          GHC92  -> "ghc92.expected"   , goldenWithEval "Prelude has no special treatment, it is imported as stated in the module" "TPrelude" "hs"   , goldenWithEval "Don't panic on {-# UNPACK #-} pragma" "TUNPACK" "hs"   , goldenWithEval "Can handle eval inside nested comment properly" "TNested" "hs"@@ -303,7 +297,7 @@   doc <- openDoc fp "haskell"   origin <- documentContents doc   let withEval = origin <> e-  changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ withEval]+  changeDoc doc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ withEval]   executeLensesBackwards doc   result <- fmap T.strip . T.stripPrefix withEval <$> documentContents doc   liftIO $ result @?= Just (T.strip expected)
− plugins/hls-eval-plugin/test/testdata/T15.expected.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE TypeApplications #-}-module T15 where--foo :: Show a => a -> String-foo = show---- >>> :type  +v  foo @Int--- foo @Int :: Show Int => Int -> String
− plugins/hls-eval-plugin/test/testdata/T15.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE TypeApplications #-}-module T15 where--foo :: Show a => a -> String-foo = show---- >>> :type  +v  foo @Int
plugins/hls-eval-plugin/test/testdata/TIO.expected.hs view
@@ -1,9 +1,12 @@ -- IO expressions are supported, stdout/stderr output is ignored module TIO where +import Control.Concurrent (threadDelay)+ {- Does not capture stdout, returns value.+Has a delay in order to show progress reporting. ->>> print "ABC" >> return "XYZ"+>>> threadDelay 2000000 >> print "ABC" >> return "XYZ" "XYZ" -}
plugins/hls-eval-plugin/test/testdata/TIO.hs view
@@ -1,9 +1,12 @@ -- IO expressions are supported, stdout/stderr output is ignored module TIO where +import Control.Concurrent (threadDelay)+ {- Does not capture stdout, returns value.+Has a delay in order to show progress reporting. ->>> print "ABC" >> return "XYZ"+>>> threadDelay 2000000 >> print "ABC" >> return "XYZ" "XYZ" -}
− plugins/hls-eval-plugin/test/testdata/TPropertyError.expected.hs 
@@ -1,6 +0,0 @@--- Support for property checking-module TProperty where---- prop> \(l::[Bool]) -> head l--- *** Failed! Exception: 'Prelude.head: empty list' (after 1 test):--- []
+ plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc910.expected.hs view
@@ -0,0 +1,13 @@+-- Support for property checking+module TProperty where++-- prop> \(l::[Bool]) -> head l+-- *** Failed! (after 1 test):+-- Exception:+--   Prelude.head: empty list+--   CallStack (from HasCallStack):+--     error, called at libraries/ghc-internal/src/GHC/Internal/List.hs:2030:3 in ghc-internal:GHC.Internal.List+--     errorEmptyList, called at libraries/ghc-internal/src/GHC/Internal/List.hs:96:11 in ghc-internal:GHC.Internal.List+--     badHead, called at libraries/ghc-internal/src/GHC/Internal/List.hs:90:28 in ghc-internal:GHC.Internal.List+--     head, called at <interactive>:1:27 in interactive:Ghci2+-- []
+ plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc92.expected.hs view
@@ -0,0 +1,6 @@+-- Support for property checking+module TProperty where++-- prop> \(l::[Bool]) -> head l+-- *** Failed! Exception: 'Prelude.head: empty list' (after 1 test):+-- []
plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs view
@@ -52,7 +52,6 @@ import qualified Language.LSP.Protocol.Lens           as L import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types-import           Language.LSP.Server  -- This plugin is named explicit-imports for historical reasons. Besides -- providing code actions and lenses to make imports explicit it also provides@@ -63,7 +62,7 @@  data Log   = LogShake Shake.Log-  | LogWAEResponseError ResponseError+  | LogWAEResponseError (TResponseError Method_WorkspaceApplyEdit)   | forall a. (Pretty a) => LogResolve a  @@ -107,9 +106,9 @@ runImportCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState IAResolveData runImportCommand recorder ideState _ eird@(ResolveOne _ _) = do   wedit <- resolveWTextEdit ideState eird-  _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) logErrors+  _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) logErrors   return $ InR  Null-  where logErrors (Left re@(ResponseError{})) = do+  where logErrors (Left re) = do           logWith recorder Error (LogWAEResponseError re)           pure ()         logErrors (Right _) = pure ()@@ -212,7 +211,7 @@     pure $ ca & L.edit ?~ wedit -------------------------------------------------------------------------------- -resolveWTextEdit :: IdeState -> IAResolveData -> ExceptT PluginError (LspT Config IO) WorkspaceEdit+resolveWTextEdit :: IdeState -> IAResolveData -> ExceptT PluginError (HandlerM Config) WorkspaceEdit -- Providing the edit for the command, or the resolve for the code action is -- completely generic, as all we need is the unique id and the text edit. resolveWTextEdit ideState (ResolveOne uri int) = do@@ -361,7 +360,11 @@ extractMinimalImports hsc TcModuleResult {..} = runMaybeT $ do   -- extract the original imports and the typechecking environment   let tcEnv = tmrTypechecked+#if MIN_VERSION_ghc(9,9,0)+      (_, imports, _, _, _) = tmrRenamed+#else       (_, imports, _, _) = tmrRenamed+#endif       ParsedModule {pm_parsed_source = L loc _} = tmrParsed       emss = exportedModuleStrings tmrParsed   Just srcSpan <- pure $ realSpan loc
plugins/hls-explicit-imports-plugin/test/Main.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE LambdaCase               #-}-{-# LANGUAGE OverloadedLabels         #-} {-# LANGUAGE OverloadedStrings        #-} {-# LANGUAGE ViewPatterns             #-} module Main@@ -10,7 +9,6 @@ import           Control.Lens                  ((^.)) import           Data.Either.Extra import           Data.Foldable                 (find)-import           Data.Row                      ((.+), (.==)) import           Data.Text                     (Text) import qualified Data.Text                     as T import           Data.Traversable              (for)@@ -93,9 +91,12 @@   case find ((== Just "Make all imports explicit") . caTitle) actions of     Just (InR x) -> executeCodeAction x     _            -> liftIO $ assertFailure "Unable to find CodeAction"-  where edit = TextDocumentContentChangeEvent $ InL $ #range .== pointRange 2 29-                                                   .+ #rangeLength .== Nothing-                                                   .+ #text .== "x"+  where edit = TextDocumentContentChangeEvent $ InL+          TextDocumentContentChangePartial+            { _range = pointRange 2 29+            , _rangeLength = Nothing+            , _text = "x"+            }  codeActionStaleAction :: FilePath -> Int -> Int -> TestTree codeActionStaleAction fp l c = goldenWithImportActions " code action" fp codeActionResolveCaps $ \doc -> do@@ -109,9 +110,12 @@         \case Just _  -> liftIO $ assertFailure "Code action still valid"               Nothing -> pure ()     _            -> liftIO $ assertFailure "Unable to find CodeAction"-  where edit = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 6 0) (Position 6 0)-                                                   .+ #rangeLength .== Nothing-                                                   .+ #text .== "\ntesting = undefined"+  where edit = TextDocumentContentChangeEvent $ InL+          TextDocumentContentChangePartial+            { _range = Range (Position 6 0) (Position 6 0)+            , _rangeLength = Nothing+            , _text = "\ntesting = undefined"+            }  codeActionAllResolveGoldenTest :: FilePath -> Int -> Int -> TestTree codeActionAllResolveGoldenTest fp l c = goldenWithImportActions " code action resolve" fp codeActionResolveCaps $ \doc -> do
plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs view
@@ -35,7 +35,6 @@                                                    TypeCheck (..)) import qualified Development.IDE.Core.Shake       as Shake import           Development.IDE.GHC.Compat       (HsConDetails (RecCon),-                                                   HsExpansion (HsExpanded),                                                    HsExpr (XExpr),                                                    HsRecFields (..), LPat,                                                    Outputable, getLoc,@@ -82,6 +81,11 @@                                                    WorkspaceEdit (WorkspaceEdit),                                                    type (|?) (InL, InR)) +#if __GLASGOW_HASKELL__ < 910+import           Development.IDE.GHC.Compat       (HsExpansion (HsExpanded))+#else+import           Development.IDE.GHC.Compat       (XXExprGhcRn (..))+#endif  data Log   = LogShake Shake.Log@@ -176,8 +180,11 @@     toRangeAndUnique (uid, recordInfo) = (recordInfoToRange recordInfo, uid)  getRecords :: TcModuleResult -> [RecordInfo]-getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) =-  collectRecords valBinds+#if __GLASGOW_HASKELL__ < 910+getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = collectRecords valBinds+#else+getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_, _)) = collectRecords valBinds+#endif  collectNamesRule :: Rules () collectNamesRule = defineNoDiagnostics mempty $ \CollectNames nfp -> runMaybeT $ do@@ -187,7 +194,11 @@ -- | Collects all 'Name's of a given source file, to be used -- in the variable usage analysis. getNames :: TcModuleResult -> UniqFM Name [Name]-getNames (tmrRenamed -> (group,_,_,_)) = collectNames group+#if __GLASGOW_HASKELL__ < 910+getNames (tmrRenamed -> (group,_,_,_))   = collectNames group+#else+getNames (tmrRenamed -> (group,_,_,_,_)) = collectNames group+#endif  data CollectRecords = CollectRecords                     deriving (Eq, Show, Generic)@@ -357,7 +368,11 @@ -- because there is a possibility that there were be more than one result per -- branch +#if __GLASGOW_HASKELL__ >= 910+getRecCons (unLoc -> XExpr (ExpandedThingRn a _)) = (collectRecords a, True)+#else getRecCons (unLoc -> XExpr (HsExpanded a _)) = (collectRecords a, True)+#endif getRecCons e@(unLoc -> RecordCon _ _ flds)   | isJust (rec_dotdot flds) = (mkRecInfo e, False)   where
plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs view
@@ -23,6 +23,7 @@ import           Data.Maybe                      (catMaybes) import           Data.Text                       (Text) import qualified Data.Text                       as T+import           Data.Version                    (showVersion) import           Development.IDE                 hiding (pluginHandlers) import           Development.IDE.GHC.Compat      as Compat hiding (Cpp, Warning,                                                             hang, vcat)@@ -38,12 +39,17 @@ import           Language.LSP.Server             hiding (defaultConfig) import           Ormolu import           Ormolu.Config+import qualified Paths_fourmolu                  as Fourmolu import           System.Exit import           System.FilePath import           System.Process.Run              (cwd, proc) import           System.Process.Text             (readCreateProcessWithExitCode) import           Text.Read                       (readMaybe) +#if MIN_VERSION_fourmolu(0,16,0)+import qualified Data.Yaml                       as Yaml+#endif+ descriptor :: Recorder (WithPriority LogEvent) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId =     (defaultPluginDescriptor plId desc)@@ -51,7 +57,7 @@         , pluginConfigDescriptor = defaultConfigDescriptor{configCustomConfig = mkCustomConfig properties}         }   where-    desc = "Provides formatting of Haskell files via fourmolu. Built with fourmolu-" <> VERSION_fourmolu+    desc = T.pack $ "Provides formatting of Haskell files via fourmolu. Built with fourmolu-" <> showVersion Fourmolu.version  properties :: Properties '[ 'PropertyKey "external" 'TBoolean, 'PropertyKey "path" 'TString] properties =@@ -66,7 +72,7 @@             False  provider :: Recorder (WithPriority LogEvent) -> PluginId -> FormattingHandler IdeState-provider recorder plId ideState token typ contents fp fo = ExceptT $ withIndefiniteProgress title token Cancellable $ \_updater -> runExceptT $ do+provider recorder plId ideState token typ contents fp fo = ExceptT $ pluginWithIndefiniteProgress title token Cancellable $ \_updater -> runExceptT $ do     fileOpts <-         maybe [] (convertDynFlags . hsc_dflags . hscEnv)             <$> liftIO (runAction "Fourmolu" ideState $ use GhcSession fp)@@ -77,36 +83,17 @@                 handle @IOException (pure . Left . PluginInternalError . T.pack . show) $                     runExceptT (cliHandler fourmoluExePath fileOpts)         else do-            logWith recorder Debug $ LogCompiledInVersion VERSION_fourmolu-            FourmoluConfig{..} <--                liftIO (loadConfigFile fp') >>= \case-                    ConfigLoaded file opts -> do-                        logWith recorder Info $ ConfigPath file-                        pure opts-                    ConfigNotFound searchDirs -> do-                        logWith recorder Info $ NoConfigPath searchDirs-                        pure emptyConfig-                    ConfigParseError f err -> do-                        lift $ sendNotification SMethod_WindowShowMessage $-                            ShowMessageParams-                                { _type_ = MessageType_Error-                                , _message = errorMessage-                                }-                        throwError $ PluginInternalError errorMessage-                      where-                        errorMessage = "Failed to load " <> T.pack f <> ": " <> T.pack (show err)-+            logWith recorder Debug $ LogCompiledInVersion (showVersion Fourmolu.version)+            FourmoluConfig{..} <- loadConfig recorder fp'             let config =-#if MIN_VERSION_fourmolu(0,13,0)-                    refineConfig ModuleSource Nothing Nothing Nothing-#endif-                    defaultConfig-                        { cfgDynOptions = map DynOption fileOpts-                        , cfgFixityOverrides = cfgFileFixities-                        , cfgRegion = region-                        , cfgDebug = False-                        , cfgPrinterOpts = resolvePrinterOpts [lspPrinterOpts, cfgFilePrinterOpts]-                        }+                    refineConfig ModuleSource Nothing Nothing Nothing $+                        defaultConfig+                            { cfgDynOptions = map DynOption fileOpts+                            , cfgFixityOverrides = cfgFileFixities+                            , cfgRegion = region+                            , cfgDebug = False+                            , cfgPrinterOpts = resolvePrinterOpts [lspPrinterOpts, cfgFilePrinterOpts]+                            }             ExceptT . liftIO $                 bimap (PluginInternalError . T.pack . show) (InL . makeDiffTextEdit contents)                     <$> try @OrmoluException (ormolu config fp' contents)@@ -158,6 +145,49 @@                 logWith recorder Info $ StdErr err                 throwError $ PluginInternalError $ "Fourmolu failed with exit code " <> T.pack (show n) +loadConfig ::+    Recorder (WithPriority LogEvent) ->+    FilePath ->+    ExceptT PluginError (HandlerM Ide.Types.Config) FourmoluConfig+#if MIN_VERSION_fourmolu(0,16,0)+loadConfig recorder fp = do+    liftIO (findConfigFile fp) >>= \case+        Left (ConfigNotFound searchDirs) -> do+            logWith recorder Info $ NoConfigPath searchDirs+            pure emptyConfig+        Right file -> do+            logWith recorder Info $ ConfigPath file+            liftIO (Yaml.decodeFileEither file) >>= \case+                Left err -> do+                    let errorMessage = "Failed to load " <> T.pack file <> ": " <> T.pack (show err)+                    lift $ pluginSendNotification SMethod_WindowShowMessage $+                        ShowMessageParams+                            { _type_ = MessageType_Error+                            , _message = errorMessage+                            }+                    throwError $ PluginInternalError errorMessage+                Right cfg -> do+                  pure cfg+#else+loadConfig recorder fp = do+    liftIO (loadConfigFile fp) >>= \case+        ConfigLoaded file opts -> do+            logWith recorder Info $ ConfigPath file+            pure opts+        ConfigNotFound searchDirs -> do+            logWith recorder Info $ NoConfigPath searchDirs+            pure emptyConfig+        ConfigParseError f err -> do+            lift $ pluginSendNotification SMethod_WindowShowMessage $+                ShowMessageParams+                    { _type_ = MessageType_Error+                    , _message = errorMessage+                    }+            throwError $ PluginInternalError errorMessage+          where+            errorMessage = "Failed to load " <> T.pack f <> ": " <> T.pack (show err)+#endif+ data LogEvent     = NoVersion Text     | ConfigPath FilePath@@ -197,8 +227,3 @@  mwhen :: Monoid a => Bool -> a -> a mwhen b x = if b then x else mempty--#if !MIN_VERSION_fourmolu(0,14,0)-resolvePrinterOpts :: [PrinterOptsPartial] -> PrinterOptsTotal-resolvePrinterOpts = foldr fillMissingPrinterOpts defaultPrinterOpts-#endif
plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs view
@@ -32,7 +32,6 @@ import qualified Language.LSP.Protocol.Lens       as L import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types-import           Language.LSP.Server              (sendRequest)  descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId "Provides a code action to convert datatypes to GADT syntax")@@ -70,7 +69,7 @@     pragma <- withExceptT GhcidePluginErrors $ getFirstPragma pId state nfp     let insertEdit = [insertNewPragma pragma GADTs | all (`notElem` exts) [GADTSyntax, GADTs]] -    _ <- lift $ sendRequest+    _ <- lift $ pluginSendRequest             SMethod_WorkspaceApplyEdit             (ApplyWorkspaceEditParams Nothing (workSpaceEdit nfp (TextEdit range txt : insertEdit)))             (\_ -> pure ())
plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs view
@@ -14,23 +14,37 @@ import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Compat.ExactPrint import           GHC.Parser.Annotation                   (AddEpAnn (..),-                                                          Anchor (Anchor),-                                                          AnchorOperation (MovedAnchor),                                                           DeltaPos (..),                                                           EpAnn (..),-                                                          EpAnnComments (EpaComments),-                                                          EpaLocation (EpaDelta),-                                                          SrcSpanAnn' (SrcSpanAnn),-                                                          spanAsAnchor)+                                                          EpAnnComments (EpaComments)) import           Ide.PluginUtils                         (subRange)-import           Language.Haskell.GHC.ExactPrint         (showAst) import           Language.Haskell.GHC.ExactPrint.Parsers (parseDecl) +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]+ #if MIN_VERSION_ghc(9,5,0) import qualified Data.List.NonEmpty                      as NE+#endif++#if MIN_VERSION_ghc(9,5,0) && !MIN_VERSION_ghc(9,9,0) import           GHC.Parser.Annotation                   (TokenLocation (..)) #endif +#if !MIN_VERSION_ghc(9,9,0)+import           GHC.Parser.Annotation                   (Anchor (Anchor),+                                                          AnchorOperation (MovedAnchor),+                                                          SrcSpanAnn' (SrcSpanAnn),+                                                          spanAsAnchor)+#endif++#if MIN_VERSION_ghc(9,9,0)+import           GHC.Parser.Annotation                   (EpUniToken (..),+                                                          EpaLocation' (..),+                                                          noAnn)+import           Language.Haskell.GHC.ExactPrint.Utils   (showAst)+#endif++ type GP = GhcPass Parsed  -- | Check if a given range is in the range of located item@@ -83,14 +97,18 @@ h98ToGADTConDecl dataName tyVars ctxt = \case     ConDeclH98{..} ->         ConDeclGADT+#if MIN_VERSION_ghc(9,9,0)+            (NoEpUniTok, con_ext)+#else             con_ext+#endif #if MIN_VERSION_ghc(9,5,0)             (NE.singleton con_name) #else             [con_name] #endif -#if MIN_VERSION_ghc(9,5,0)+#if MIN_VERSION_ghc(9,5,0) && !MIN_VERSION_ghc(9,9,0)             (L NoTokenLoc HsNormalTok) #endif             -- Ignore all existential type variable since GADT not needed@@ -103,9 +121,19 @@     where         -- Parameters in the data constructor         renderDetails :: HsConDeclH98Details GP -> HsConDeclGADTDetails GP+#if MIN_VERSION_ghc(9,9,0)+        renderDetails (PrefixCon _ args)   = PrefixConGADT noExtField args+#else         renderDetails (PrefixCon _ args)   = PrefixConGADT args+#endif+#if MIN_VERSION_ghc(9,9,0)+        renderDetails (InfixCon arg1 arg2) = PrefixConGADT noExtField [arg1, arg2]+#else         renderDetails (InfixCon arg1 arg2) = PrefixConGADT [arg1, arg2]-#if MIN_VERSION_ghc(9,3,0)+#endif+#if MIN_VERSION_ghc(9,9,0)+        renderDetails (RecCon recs)        = RecConGADT NoEpUniTok recs+#elif MIN_VERSION_ghc(9,3,0)         renderDetails (RecCon recs)        = RecConGADT recs noHsUniTok #else         renderDetails (RecCon recs)        = RecConGADT recs@@ -196,16 +224,24 @@          -- Make every data constructor start with a new line and 2 spaces         adjustCon :: LConDecl GP -> LConDecl GP+#if MIN_VERSION_ghc(9,9,0)+        adjustCon (L _ r) =+            let delta = EpaDelta (DifferentLine 1 3) []+            in L (EpAnn delta (AnnListItem []) (EpaComments [])) r+#else         adjustCon (L (SrcSpanAnn _ loc) r) =-            L (SrcSpanAnn (EpAnn (go (spanAsAnchor loc)) (AnnListItem []) (EpaComments [])) loc) r-            where-                go (Anchor a _) = Anchor a (MovedAnchor (DifferentLine 1 2))+            let go (Anchor a _) = Anchor a (MovedAnchor (DifferentLine 1 2))+            in L (SrcSpanAnn (EpAnn (go (spanAsAnchor loc)) (AnnListItem []) (EpaComments [])) loc) r+#endif          -- Adjust where annotation to the same line of the type constructor-        adjustWhere tcdDExt = tcdDExt <&> map+        adjustWhere tcdDExt = tcdDExt <&>+#if !MIN_VERSION_ghc(9,9,0)+            map+#endif             (\(AddEpAnn ann l) ->             if ann == AnnWhere-                then AddEpAnn AnnWhere (EpaDelta (SameLine 1) [])+                then AddEpAnn AnnWhere d1                 else AddEpAnn ann l             ) @@ -220,7 +256,11 @@ emptyCtxt = Nothing unWrap = unXRec @GP mapX = mapXRec @GP+#if MIN_VERSION_ghc(9,9,0)+noUsed = noAnn+#else noUsed = EpAnnNotUsed+#endif  pattern UserTyVar' :: LIdP pass -> HsTyVarBndr flag pass pattern UserTyVar' s <- UserTyVar _ _ s
plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs view
@@ -108,7 +108,6 @@ import           Language.LSP.Protocol.Types                        hiding                                                                     (Null) import qualified Language.LSP.Protocol.Types                        as LSP-import           Language.LSP.Server                                (getVersionedTextDoc)  import qualified Development.IDE.Core.Shake                         as Shake import           Development.IDE.Spans.Pragmas                      (LineSplitTextEdits (LineSplitTextEdits),@@ -367,7 +366,7 @@   | let TextDocumentIdentifier uri = documentId   , Just docNormalizedFilePath <- uriToNormalizedFilePath (toNormalizedUri uri)   = do-    verTxtDocId <- lift $ getVersionedTextDoc documentId+    verTxtDocId <- lift $ pluginGetVersionedTextDoc documentId     liftIO $ fmap (InL . map LSP.InR) $ do       allDiagnostics <- atomically $ getDiagnostics ideState
plugins/hls-hlint-plugin/test/Main.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedLabels  #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-} module Main@@ -12,7 +11,6 @@ import           Data.List                  (find) import qualified Data.Map                   as Map import           Data.Maybe                 (fromJust, isJust)-import           Data.Row                   ((.+), (.==)) import qualified Data.Text                  as T import           Ide.Plugin.Config          (Config (..)) import qualified Ide.Plugin.Config          as Plugin@@ -118,7 +116,12 @@         contents <- skipManyTill anyMessage $ getDocumentEdit doc         liftIO $ contents @?= "main = undefined\nfoo x = x\n" -    , testCase "falls back to pre 3.8 code actions" $ runSessionWithServerAndCaps def hlintPlugin noLiteralCaps testDir $ do+    , testCase "falls back to pre 3.8 code actions" $+        runSessionWithTestConfig def+            { testConfigCaps = noLiteralCaps+            , testDirLocation = Left testDir+            , testPluginDescriptor = hlintPlugin+            , testShiftRoot = True} $ const $ do         doc <- openDoc "Base.hs" "haskell"          _ <- waitForDiagnosticsFromSource doc "hlint"@@ -139,16 +142,22 @@         doc <- openDoc "Base.hs" "haskell"         testHlintDiagnostics doc -        let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 1 8) (Position 1 12)-                                                         .+ #rangeLength .== Nothing-                                                         .+ #text .== "x"+        let change = TextDocumentContentChangeEvent $ InL+              TextDocumentContentChangePartial+                { _range = Range (Position 1 8) (Position 1 12)+                , _rangeLength = Nothing+                , _text = "x"+                }+         changeDoc doc [change]         expectNoMoreDiagnostics 3 doc "hlint" -        let change' = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 1 8) (Position 1 12)-                                                          .+ #rangeLength .== Nothing-                                                          .+ #text .== "id x"-+        let change' = TextDocumentContentChangeEvent $ InL+              TextDocumentContentChangePartial+                { _range = Range (Position 1 8) (Position 1 12)+                , _rangeLength = Nothing+                , _text = "id x"+                }         changeDoc doc [change']         testHlintDiagnostics doc @@ -232,14 +241,11 @@     , testCase "[#1279] hlint should not activate extensions like PatternSynonyms" $ runHlintSession "" $ do         doc <- openDoc "PatternKeyword.hs" "haskell" -        waitForAllProgressDone         -- hlint will report a parse error if PatternSynonyms is enabled         expectNoMoreDiagnostics 3 doc "hlint"     , testCase "hlint should not warn about redundant irrefutable pattern with LANGUAGE Strict" $ runHlintSession "" $ do         doc <- openDoc "StrictData.hs" "haskell" -        waitForAllProgressDone-         expectNoMoreDiagnostics 3 doc "hlint"     ]     where@@ -337,7 +343,14 @@ testDir = "plugins/hls-hlint-plugin/test/testdata"  runHlintSession :: FilePath -> Session a -> IO a-runHlintSession subdir = failIfSessionTimeout . runSessionWithServerAndCaps def hlintPlugin codeActionNoResolveCaps (testDir </> subdir)+runHlintSession subdir = failIfSessionTimeout .+    runSessionWithTestConfig def+      { testConfigCaps = codeActionNoResolveCaps+      , testShiftRoot = True+      , testDirLocation = Left (testDir </> subdir)+      , testPluginDescriptor = hlintPlugin+      }+    . const  noHlintDiagnostics :: [Diagnostic] -> Assertion noHlintDiagnostics diags =@@ -415,10 +428,18 @@           void $ skipManyTill anyMessage $ getDocumentEdit document       _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point + setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintTest testName path =-  goldenWithHaskellAndCaps def codeActionNoResolveCaps hlintPlugin testName testDir path "expected" "hs"+    goldenWithTestConfig def+    { testConfigCaps = codeActionNoResolveCaps+    , testShiftRoot = True+    , testPluginDescriptor = hlintPlugin+    , testDirLocation = Left testDir+    }+    testName testDir path "expected" "hs" + ignoreHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree ignoreHintGoldenResolveTest testCaseName goldenFilename point hintName =   goldenResolveTest testCaseName goldenFilename point (getIgnoreHintText hintName)@@ -438,4 +459,10 @@  setupGoldenHlintResolveTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintResolveTest testName path =-  goldenWithHaskellAndCaps def codeActionResolveCaps hlintPlugin testName testDir path "expected" "hs"+    goldenWithTestConfig def+    { testConfigCaps = codeActionResolveCaps+    , testShiftRoot = True+    , testPluginDescriptor = hlintPlugin+    , testDirLocation = Left testDir+    }+    testName testDir path "expected" "hs"
plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs view
@@ -41,8 +41,8 @@                                                        hscEnvWithImportPaths,                                                        logWith,                                                        realSrcSpanToRange,-                                                       runAction, useWithStale,-                                                       (<+>))+                                                       rootDir, runAction,+                                                       useWithStale, (<+>)) import           Development.IDE.Core.PluginUtils import           Development.IDE.Core.PositionMapping (toCurrentRange) import           Development.IDE.GHC.Compat           (GenLocated (L),@@ -53,12 +53,11 @@                                                        pm_parsed_source, unLoc) import           Ide.Logger                           (Pretty (..)) import           Ide.Plugin.Error+import           Ide.PluginUtils                      (toAbsolute) import           Ide.Types import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types-import           Language.LSP.Server import           Language.LSP.VFS                     (virtualFileText)-import           System.Directory                     (makeAbsolute) import           System.FilePath                      (dropExtension, normalise,                                                        pathSeparator,                                                        splitDirectories,@@ -95,7 +94,7 @@       -- | Convert an Action to the corresponding edit operation       edit = WorkspaceEdit (Just $ Map.singleton aUri [TextEdit aRange aCode]) Nothing Nothing     in-      void $ lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (const (pure ()))+      void $ lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (const (pure ()))   pure $ InR Null  -- | A source code change@@ -108,12 +107,12 @@   deriving (Show)  -- | Required action (that can be converted to either CodeLenses or CodeActions)-action :: Recorder (WithPriority Log) -> IdeState -> Uri -> ExceptT PluginError (LspM c) [Action]+action :: Recorder (WithPriority Log) -> IdeState -> Uri -> ExceptT PluginError (HandlerM c) [Action] action recorder state uri = do     nfp <- getNormalizedFilePathE  uri     fp <- uriToFilePathE uri -    contents <- lift . getVirtualFile $ toNormalizedUri uri+    contents <- lift . pluginGetVirtualFile $ toNormalizedUri uri     let emptyModule = maybe True (T.null . T.strip . virtualFileText) contents      correctNames <- mapExceptT liftIO $ pathModuleNames recorder state nfp fp@@ -150,7 +149,10 @@       let paths = map (normalise . (<> pure pathSeparator)) srcPaths       logWith recorder Debug (NormalisedPaths paths) -      mdlPath <- liftIO $ makeAbsolute filePath+      -- TODO, this can be avoid if the filePath is already absolute,+      -- we can avoid the toAbsolute call in the future.+      -- see Note [Root Directory]+      let mdlPath = (toAbsolute $ rootDir state) filePath       logWith recorder Debug (AbsoluteFilePath mdlPath)        let suffixes = mapMaybe (`stripPrefix` mdlPath) paths
plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs view
@@ -25,7 +25,6 @@ import           Language.LSP.Protocol.Message    (Method (Method_TextDocumentDefinition),                                                    SMethod (SMethod_TextDocumentDefinition)) import           Language.LSP.Protocol.Types-import qualified Language.LSP.Server              as LSP import           Language.LSP.VFS                 (VirtualFile (..)) import           Text.Regex.TDFA                  (Regex, caseSensitive,                                                    defaultCompOpt,@@ -81,7 +80,7 @@     = do         let Position l c = param ^. L.position         contents <- fmap _file_text . err "Error getting file contents"-            =<< lift (LSP.getVirtualFile uriOrig)+            =<< lift (pluginGetVirtualFile uriOrig)         line <- err "Line not found in file" (listToMaybe $ Rope.lines $ fst             (Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) contents))         let noteOpt = listToMaybe $ mapMaybe (atPos $ fromIntegral c) $ matchAllText noteRefRegex line
plugins/hls-notes-plugin/test/NotesTest.hs view
@@ -1,10 +1,8 @@ module Main (main) where -import           Development.IDE.Test-import           Ide.Plugin.Notes     (Log, descriptor)-import           System.Directory     (canonicalizePath)-import           System.FilePath      ((</>))-import           Test.Hls             hiding (waitForBuildQueue)+import           Ide.Plugin.Notes (Log, descriptor)+import           System.FilePath  ((</>))+import           Test.Hls  plugin :: PluginTestDescriptor Log plugin = mkPluginTestDescriptor descriptor "notes"@@ -15,49 +13,48 @@     [ gotoNoteTests     ] +runSessionWithServer' :: FilePath -> (FilePath -> Session a) -> IO a+runSessionWithServer' fp act =+    runSessionWithTestConfig def+        { testLspConfig = def+        , testPluginDescriptor = plugin+        , testDirLocation = Left fp+        } act+ gotoNoteTests :: TestTree gotoNoteTests = testGroup "Goto Note Definition"-    [ testCase "single_file" $ runSessionWithServer def plugin testDataDir $ do+    [+      testCase "single_file" $ runSessionWithServer' testDataDir $ \dir -> do         doc <- openDoc "NoteDef.hs" "haskell"-        waitForBuildQueue-        waitForAllProgressDone+        waitForKickDone         defs <- getDefinitions doc (Position 3 41)-        liftIO $ do-          fp <- canonicalizePath "NoteDef.hs"-          defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 8 9) (Position 8 9))]))-    , testCase "liberal_format" $ runSessionWithServer def plugin testDataDir $ do+        let fp = dir </> "NoteDef.hs"+        liftIO $ defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 8 9) (Position 8 9))]))+    , testCase "liberal_format" $ runSessionWithServer' testDataDir $ \dir -> do         doc <- openDoc "NoteDef.hs" "haskell"-        waitForBuildQueue-        waitForAllProgressDone+        waitForKickDone         defs <- getDefinitions doc (Position 5 64)-        liftIO $ do-          fp <- canonicalizePath "NoteDef.hs"-          defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 18 11) (Position 18 11))]))+        let fp = dir </> "NoteDef.hs"+        liftIO $ defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 18 11) (Position 18 11))])) -    , testCase "invalid_note" $ runSessionWithServer def plugin testDataDir $ do+    , testCase "invalid_note" $ runSessionWithServer' testDataDir $ const $ do         doc <- openDoc "NoteDef.hs" "haskell"-        waitForBuildQueue-        waitForAllProgressDone+        waitForKickDone         defs <- getDefinitions doc (Position 6 54)-        liftIO $ do-            defs @?= InL (Definition (InR []))+        liftIO $ defs @?= InL (Definition (InR [])) -    , testCase "no_note" $ runSessionWithServer def plugin testDataDir $ do+    , testCase "no_note" $ runSessionWithServer' testDataDir $ const $ do         doc <- openDoc "NoteDef.hs" "haskell"-        waitForBuildQueue-        waitForAllProgressDone+        waitForKickDone         defs <- getDefinitions doc (Position 1 0)         liftIO $ defs @?= InL (Definition (InR [])) -    , testCase "unopened_file" $ runSessionWithServer def plugin testDataDir $ do+    , testCase "unopened_file" $ runSessionWithServer' testDataDir $ \dir -> do         doc <- openDoc "Other.hs" "haskell"-        waitForCustomMessage "ghcide/cradle/loaded" (const $ Just ())-        waitForBuildQueue-        waitForAllProgressDone+        waitForKickDone         defs <- getDefinitions doc (Position 5 20)-        liftIO $ do-          fp <- canonicalizePath "NoteDef.hs"-          defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 12 6) (Position 12 6))]))+        let fp = dir </> "NoteDef.hs"+        liftIO $ defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 12 6) (Position 12 6))]))     ]  testDataDir :: FilePath
plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs view
@@ -63,7 +63,7 @@ -- ---------------------------------------------------------------------  provider :: Recorder (WithPriority LogEvent) -> PluginId -> FormattingHandler IdeState-provider recorder plId ideState token typ contents fp _ = ExceptT $ withIndefiniteProgress title token Cancellable $ \_updater -> runExceptT $ do+provider recorder plId ideState token typ contents fp _ = ExceptT $ pluginWithIndefiniteProgress title token Cancellable $ \_updater -> runExceptT $ do   fileOpts <-       maybe [] (fromDyn . hsc_dflags . hscEnv)           <$> liftIO (runAction "Ormolu" ideState $ use GhcSession fp)@@ -117,7 +117,7 @@     title = T.pack $ "Formatting " <> takeFileName (fromNormalizedFilePath fp) -   ret :: Either SomeException T.Text -> ExceptT PluginError (LspM Types.Config) ([TextEdit] |? Null)+   ret :: Either SomeException T.Text -> ExceptT PluginError (HandlerM Types.Config) ([TextEdit] |? Null)    ret (Left err)  = throwError $ PluginInternalError . T.pack $ "ormoluCmd: " ++ show err    ret (Right new) = pure $ InL $ makeDiffTextEdit contents new
plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs view
@@ -36,20 +36,12 @@ import           Development.IDE.Core.Shake           (define, useWithStale) import qualified Development.IDE.Core.Shake           as Shake -#if __GLASGOW_HASKELL__ >= 903-import           Development.IDE.GHC.Compat           (HsExpr (HsRecSel))-#else-import           Development.IDE.GHC.Compat           (HsExpr (HsRecFld))-#endif- import           Control.DeepSeq                      (rwhnf) import           Development.IDE.Core.PluginUtils import           Development.IDE.Core.PositionMapping (PositionMapping,                                                        toCurrentRange) import           Development.IDE.GHC.Compat           (Extension (OverloadedRecordDot),-                                                       GhcPass,-                                                       HsExpansion (HsExpanded),-                                                       HsExpr (HsApp, HsVar, OpApp, XExpr),+                                                       GhcPass, HsExpr (..),                                                        LHsExpr, Pass (..),                                                        appPrec, dollarName,                                                        getLoc, hs_valds,@@ -87,6 +79,14 @@                                                        WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges),                                                        type (|?) (..)) ++#if __GLASGOW_HASKELL__ < 910+import           Development.IDE.GHC.Compat           (HsExpansion (HsExpanded))+#else+import           Development.IDE.GHC.Compat           (XXExprGhcRn (..))+#endif++ data Log     = LogShake Shake.Log     | LogCollectedRecordSelectors [RecordSelectorExpr]@@ -246,8 +246,11 @@     where getEnabledExtensions :: TcModuleResult -> [Extension]           getEnabledExtensions = getExtensions . tmrParsed           getRecordSelectors :: TcModuleResult -> [RecordSelectorExpr]-          getRecordSelectors (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) =-            collectRecordSelectors valBinds+#if __GLASGOW_HASKELL__ >= 910+          getRecordSelectors (tmrRenamed -> (hs_valds -> valBinds,_,_,_,_)) = collectRecordSelectors valBinds+#else+          getRecordSelectors (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = collectRecordSelectors valBinds+#endif           rewriteRange :: PositionMapping -> RecordSelectorExpr                             -> Maybe RecordSelectorExpr           rewriteRange pm recSel =@@ -281,7 +284,11 @@ -- branch. We do this here, by explicitly returning occurrences from traversing -- the original branch, and returning True, which keeps syb from implicitly -- continuing to traverse.+#if __GLASGOW_HASKELL__ >= 910+getRecSels (unLoc -> XExpr (ExpandedThingRn a _)) = (collectRecordSelectors a, True)+#else getRecSels (unLoc -> XExpr (HsExpanded a _)) = (collectRecordSelectors a, True)+#endif #if __GLASGOW_HASKELL__ >= 903 -- applied record selection: "selector record" or "selector (record)" or -- "selector selector2.record2"
plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs view
@@ -37,7 +37,6 @@ import qualified Language.LSP.Protocol.Lens               as L import qualified Language.LSP.Protocol.Message            as LSP import qualified Language.LSP.Protocol.Types              as LSP-import qualified Language.LSP.Server                      as LSP import qualified Text.Fuzzy                               as Fuzzy  -- ---------------------------------------------------------------------@@ -199,7 +198,7 @@ completion _ide _ complParams = do     let (LSP.TextDocumentIdentifier uri) = complParams ^. L.textDocument         position@(Position ln col) = complParams ^. L.position-    contents <- lift $ LSP.getVirtualFile $ toNormalizedUri uri+    contents <- lift $ pluginGetVirtualFile $ toNormalizedUri uri     fmap LSP.InL $ case (contents, uriToFilePath' uri) of         (Just cnts, Just _path) ->             pure $ result $ getCompletionPrefix position cnts
plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP               #-} {-# LANGUAGE MultiWayIf        #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms   #-}@@ -12,7 +13,7 @@ import qualified Control.Monad.Trans.State.Strict as State import           Data.DList                       (DList) import qualified Data.DList                       as DList-import           Data.Foldable                    (Foldable (foldl'), find)+import           Data.Foldable                    (find) import           Data.List                        (sortOn) import qualified Data.List                        as List import qualified Data.Map.Strict                  as Map@@ -71,6 +72,10 @@                                                    TextEdit (TextEdit),                                                    WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges),                                                    type (|?) (InL, InR))++#if !MIN_VERSION_base(4,20,0)+import           Data.Foldable                    (foldl')+#endif  thenCmp :: Ordering -> Ordering -> Ordering {-# INLINE thenCmp #-}
plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs view
@@ -2,16 +2,18 @@ --   multiple ghc-exactprint versions, accepting that anything more ambitious is --   pretty much impossible with the GHC 9.2 redesign of ghc-exactprint module Development.IDE.GHC.Compat.ExactPrint-    ( ExactPrint-    , exactPrint-    , makeDeltaAst-    , Retrie.Annotated, pattern Annotated, astA, annsA+    ( module ExactPrint+    , printA+    , transformA     ) where -import           Development.IDE.GHC.Compat.Parser-import           Language.Haskell.GHC.ExactPrint   as Retrie-import qualified Retrie.ExactPrint                 as Retrie+import           Language.Haskell.GHC.ExactPrint   as ExactPrint +printA :: (ExactPrint ast) => ast -> String+printA ast = exactPrint ast -pattern Annotated :: ast -> ApiAnns -> Retrie.Annotated ast-pattern Annotated {astA, annsA} <- ((,()) . Retrie.astA -> (astA, annsA))+transformA+  :: Monad m => ast1 -> (ast1 -> TransformT m ast2) -> m ast2+transformA ast f = do+  (ast',_ ,_) <- runTransformFromT 0 (f ast)+  return $ ast'
plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs view
@@ -4,7 +4,7 @@ import           Data.Data                             hiding (Fixity) import           Development.IDE.GHC.Compat            hiding (LocatedA,                                                         NameAnn)-import           Development.IDE.GHC.Compat.ExactPrint+import           Development.IDE.GHC.Compat.ExactPrint (ExactPrint, exactPrint) import           Development.IDE.GHC.Compat.Util import           Generics.SYB                          (ext1Q, ext2Q, extQ) import           GHC.Hs                                hiding (AnnLet)@@ -61,7 +61,9 @@               `extQ` sourceText               `extQ` deltaPos               `extQ` epaAnchor+#if !MIN_VERSION_ghc(9,9,0)               `extQ` anchorOp+#endif               `extQ` bytestring               `extQ` name `extQ` occName `extQ` moduleName `extQ` var               `extQ` dataCon@@ -129,16 +131,20 @@ #endif              epaAnchor :: EpaLocation -> SDoc-#if MIN_VERSION_ghc(9,5,0)+#if MIN_VERSION_ghc(9,9,0)+            epaAnchor (EpaSpan s) = parens $ text "EpaSpan" <+> srcSpan s+#elif MIN_VERSION_ghc(9,5,0)             epaAnchor (EpaSpan r _)  = text "EpaSpan" <+> realSrcSpan r #else             epaAnchor (EpaSpan r)  = text "EpaSpan" <+> realSrcSpan r #endif             epaAnchor (EpaDelta d cs) = text "EpaDelta" <+> deltaPos d <+> showAstDataHtml' cs +#if !MIN_VERSION_ghc(9,9,0)             anchorOp :: AnchorOperation -> SDoc             anchorOp UnchangedAnchor  = "UnchangedAnchor"             anchorOp (MovedAnchor dp) = "MovedAnchor " <> deltaPos dp+#endif              deltaPos :: DeltaPos -> SDoc             deltaPos (SameLine c) = text "SameLine" <+> ppr c@@ -249,6 +255,31 @@              -- ------------------------- +#if MIN_VERSION_ghc(9,9,0)+            srcSpanAnnA :: EpAnn AnnListItem -> SDoc+            srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA")++            srcSpanAnnL :: EpAnn AnnList -> SDoc+            srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL")++            srcSpanAnnP :: EpAnn AnnPragma -> SDoc+            srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP")++            srcSpanAnnC :: EpAnn AnnContext -> SDoc+            srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC")++            srcSpanAnnN :: EpAnn NameAnn -> SDoc+            srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")++            locatedAnn'' :: forall a. Data a => SDoc -> EpAnn a -> SDoc+            locatedAnn'' tag ss = parens $+              case cast ss of+                Just (ann :: EpAnn a) ->+                      text (showConstr (toConstr ann))+                                          $$ vcat (gmapQ showAstDataHtml' ann)+                Nothing -> text "locatedAnn:unmatched" <+> tag+                           <+> (parens $ text (showConstr (toConstr ss)))+#else             srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc             srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") @@ -274,6 +305,7 @@                               $$ li(srcSpan s))                 Nothing -> text "locatedAnn:unmatched" <+> tag                            <+> text (showConstr (toConstr ss))+#endif   normalize_newlines :: String -> String
plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs view
@@ -30,7 +30,6 @@       removeComma,       -- * Helper function       eqSrcSpan,-      eqSrcSpanA,       epl,       epAnn,       removeTrailingComma,@@ -55,7 +54,6 @@ import           Control.Monad.Zip import           Data.Bifunctor import           Data.Bool                               (bool)-import           Data.Default                            (Default) import qualified Data.DList                              as DL import           Data.Either.Extra                       (mapLeft) import           Data.Functor.Classes@@ -81,38 +79,54 @@ import           Ide.PluginUtils import           Language.Haskell.GHC.ExactPrint.Parsers import           Language.LSP.Protocol.Types-import           Retrie.ExactPrint                       hiding (parseDecl,-                                                          parseExpr,-                                                          parsePattern,-                                                          parseType)-#if MIN_VERSION_ghc(9,9,0)-import           GHC.Plugins                             (showSDoc)-import           GHC.Utils.Outputable                    (Outputable (ppr))-#else-import           GHC                                     (EpAnn (..),++import           Control.Lens                            (_last, (&))+import           Control.Lens.Operators                  ((%~))+import           Data.List                               (partition)+import           GHC                                     (DeltaPos (..),+                                                          SrcSpanAnnN)++-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if !MIN_VERSION_ghc(9,9,0)+import           Data.Default                            (Default)+import           GHC                                     (Anchor (..),+                                                          AnchorOperation,+                                                          EpAnn (..),                                                           NameAdornment (NameParens),                                                           NameAnn (..),                                                           SrcSpanAnn' (SrcSpanAnn),                                                           SrcSpanAnnA,                                                           TrailingAnn (AddCommaAnn),                                                           emptyComments,+                                                          realSrcSpan,                                                           spanAsAnchor) import           GHC.Parser.Annotation                   (AnnContext (..),                                                           EpaLocation (EpaDelta),                                                           deltaPos)+import           GHC.Types.SrcLoc                        (generatedSrcSpan) #endif -import           Control.Lens                            (_last, (&))-import           Control.Lens.Operators                  ((%~))-import           Data.List                               (partition)-import           GHC                                     (Anchor (..),-                                                          AnchorOperation,-                                                          DeltaPos (..),-                                                          SrcSpanAnnN,-                                                          realSrcSpan)-import           GHC.Types.SrcLoc                        (generatedSrcSpan)+#if MIN_VERSION_ghc(9,9,0)+import           GHC                                     (Anchor,+                                                          AnnContext (..),+                                                          EpAnn (..),+                                                          EpaLocation,+                                                          EpaLocation' (..),+                                                          NameAdornment (..),+                                                          NameAnn (..),+                                                          SrcSpanAnnA,+                                                          TrailingAnn (..),+                                                          deltaPos,+                                                          emptyComments,+                                                          spanAsAnchor)+#endif -setPrecedingLines :: Default t => LocatedAn t a -> Int -> Int -> LocatedAn t a+setPrecedingLines ::+#if !MIN_VERSION_ghc(9,9,0)+     Default t =>+#endif+    LocatedAn t a -> Int -> Int -> LocatedAn t a setPrecedingLines ast n c = setEntryDP ast (deltaPos n c) ------------------------------------------------------------------------------ @@ -122,27 +136,34 @@   pretty = \case     LogShake shakeLog -> pretty shakeLog -instance Show (Annotated ParsedSource) where-  show _ = "<Annotated ParsedSource>"--instance NFData (Annotated ParsedSource) where-  rnf = rwhnf- data GetAnnotatedParsedSource = GetAnnotatedParsedSource   deriving (Eq, Show, Typeable, GHC.Generic)  instance Hashable GetAnnotatedParsedSource instance NFData GetAnnotatedParsedSource-type instance RuleResult GetAnnotatedParsedSource = Annotated ParsedSource+type instance RuleResult GetAnnotatedParsedSource = ParsedSource +#if MIN_VERSION_ghc(9,5,0)+instance Show (HsModule GhcPs) where+  show _ = "<HsModule GhcPs>"+#else+instance Show HsModule where+  show _ = "<HsModule GhcPs>"+#endif+ -- | Get the latest version of the annotated parse source with comments. getAnnotatedParsedSourceRule :: Recorder (WithPriority Log) -> Rules () getAnnotatedParsedSourceRule recorder = define (cmapWithPrio LogShake recorder) $ \GetAnnotatedParsedSource nfp -> do   pm <- use GetParsedModuleWithComments nfp   return ([], fmap annotateParsedSource pm) -annotateParsedSource :: ParsedModule -> Annotated ParsedSource-annotateParsedSource (ParsedModule _ ps _ _) = unsafeMkA (makeDeltaAst ps) 0+annotateParsedSource :: ParsedModule -> ParsedSource+annotateParsedSource (ParsedModule _ ps _ _) =+#if MIN_VERSION_ghc(9,9,0)+    ps+#else+    (makeDeltaAst ps)+#endif  ------------------------------------------------------------------------------ @@ -195,7 +216,7 @@     ClientCapabilities ->     VersionedTextDocumentIdentifier ->     Graft (Either String) ParsedSource ->-    Annotated ParsedSource ->+    ParsedSource ->     Either String WorkspaceEdit transform dflags ccs verTxtDocId f a = do     let src = printA a@@ -212,7 +233,7 @@     ClientCapabilities ->     VersionedTextDocumentIdentifier ->     Graft (ExceptStringT m) ParsedSource ->-    Annotated ParsedSource ->+    ParsedSource ->     m (Either String WorkspaceEdit) transformM dflags ccs verTextDocId f a = runExceptT $     runExceptString $ do@@ -232,7 +253,9 @@     -- | (Needs parens, needs space)     (All, All) needsParensSpace HsLam{}         = (All False, All False)+#if !MIN_VERSION_ghc(9,9,0) needsParensSpace HsLamCase{}     = (All False, All True)+#endif needsParensSpace HsApp{}         = mempty needsParensSpace HsAppType{}     = mempty needsParensSpace OpApp{}         = mempty@@ -421,8 +444,8 @@ -- For example, if you would like to move a where-clause-defined variable to the same -- level as its parent HsDecl, you could use this function. ----- When matching declaration is found in the sub-declarations of `a`, `Just r` is also returned with the new `a`. If--- not declaration matched, then `Nothing` is returned.+-- When matching declaration is found in the sub-declarations of `a`, `Just r` is also returned with the new `a`.+-- If no declaration matched, then `Nothing` is returned. modifySmallestDeclWithM ::   forall a m r.   (HasDecls a, Monad m) =>@@ -440,19 +463,35 @@             False -> first (DL.singleton ldecl <>) <$> modifyMatchingDecl rest   modifyDeclsT' (fmap (first DL.toList) . modifyMatchingDecl) a +#if MIN_VERSION_ghc(9,9,0)+generatedAnchor :: DeltaPos -> Anchor+generatedAnchor dp = EpaDelta dp []+#else generatedAnchor :: AnchorOperation -> Anchor generatedAnchor anchorOp = GHC.Anchor (GHC.realSrcSpan generatedSrcSpan) anchorOp+#endif  setAnchor :: Anchor -> SrcSpanAnnN -> SrcSpanAnnN+#if MIN_VERSION_ghc(9,9,0)+setAnchor anc (EpAnn _ nameAnn comments) =+  EpAnn anc nameAnn comments+#else setAnchor anc (SrcSpanAnn (EpAnn _ nameAnn comments) span) =   SrcSpanAnn (EpAnn anc nameAnn comments) span setAnchor _ spanAnnN = spanAnnN+#endif  removeTrailingAnns :: SrcSpanAnnN -> SrcSpanAnnN+#if MIN_VERSION_ghc(9,9,0)+removeTrailingAnns (EpAnn anc nameAnn comments) =+  let nameAnnSansTrailings = nameAnn {nann_trailing = []}+  in EpAnn anc nameAnnSansTrailings comments+#else removeTrailingAnns (SrcSpanAnn (EpAnn anc nameAnn comments) span) =   let nameAnnSansTrailings = nameAnn {nann_trailing = []}   in SrcSpanAnn (EpAnn anc nameAnnSansTrailings comments) span removeTrailingAnns spanAnnN = spanAnnN+#endif  -- | Modify the type signature for the given IdP. This function handles splitting a multi-sig -- SigD into multiple SigD if the type signature is changed.@@ -471,7 +510,7 @@ -- + foo :: Bool modifySigWithM ::   forall a m.-  (HasDecls a, Monad m) =>+  (HasDecls a, Monad m, ExactPrint a) =>   IdP GhcPs ->   (LHsSigType GhcPs -> LHsSigType GhcPs) ->   a ->@@ -490,22 +529,36 @@                   let matchedId' = L (setAnchor genAnchor0 $ removeTrailingAnns annMatchedId) matchedId                       matchedIdSig =                         let sig' = SigD xsig (TypeSig xTypeSig [matchedId'] (HsWC xHsWc newSig))-                            epAnn = bool (noAnnSrcSpanDP generatedSrcSpan (DifferentLine 1 0)) annSigD (null otherIds)+                            epAnn = bool (noAnnSrcSpanDP+#if !MIN_VERSION_ghc(9,9,0)+                                            generatedSrcSpan+#endif+                                            (DifferentLine 1 0))+                                         annSigD (null otherIds)                         in L epAnn sig'                       otherSig = case otherIds of                         [] -> []-                        (L (SrcSpanAnn epAnn span) id1:ids) -> [+#if MIN_VERSION_ghc(9,9,0)+                        (L epAnn id1:ids) ->+#else+                        (L (SrcSpanAnn epAnn span) id1:ids) ->+#endif+                          [                           let epAnn' = case epAnn of                                 EpAnn _ nameAnn commentsId1 -> EpAnn genAnchor0 nameAnn commentsId1+#if MIN_VERSION_ghc(9,9,0)+                              ids' = L epAnn' id1:ids+#else                                 EpAnnNotUsed -> EpAnn genAnchor0 mempty emptyComments                               ids' = L (SrcSpanAnn epAnn' span) id1:ids+#endif                               ids'' = ids' & _last %~ first removeTrailingAnns                             in L annSigD (SigD xsig (TypeSig xTypeSig ids'' (HsWC xHsWc lHsSig)))-                            ]+                          ]                   in pure $ DL.fromList otherSig <> DL.singleton matchedIdSig <> DL.fromList rest                 _ -> error "multiple ids matched"       modifyMatchingSigD (ldecl : rest) = (DL.singleton ldecl <>) <$> modifyMatchingSigD rest-  modifyDeclsT (fmap DL.toList . modifyMatchingSigD) a+  modifyDeclsT (fmap DL.toList . modifyMatchingSigD) $ makeDeltaAst a  genAnchor0 :: Anchor genAnchor0 = generatedAnchor m0@@ -513,6 +566,13 @@ genAnchor1 :: Anchor genAnchor1 = generatedAnchor m1 +#if MIN_VERSION_ghc(9,9,0)+m0, m1 :: DeltaPos+m0 = SameLine 0+m1 = SameLine 1+#endif++ -- | Apply a transformation to the decls contained in @t@ modifyDeclsT' :: (HasDecls t, HasTransform m)              => ([LHsDecl GhcPs] -> m ([LHsDecl GhcPs], r))@@ -543,7 +603,7 @@ modifyMgMatchesT' (MG xMg (L locMatches matches)) f def combineResults = do   (unzip -> (matches', rs)) <- mapM f matches   r' <- TransformT $ lift $ foldM combineResults def rs-  pure $ (MG xMg (L locMatches matches'), r')+  pure (MG xMg (L locMatches matches'), r') #else modifyMgMatchesT' (MG xMg (L locMatches matches) originMg) f def combineResults = do   (unzip -> (matches', rs)) <- mapM f matches@@ -596,7 +656,9 @@     , Typeable l     , Outputable l     , Outputable ast+#if !MIN_VERSION_ghc(9,9,0)     , Default l+#endif     ) => ASTElement l ast | ast -> l where     parseAST :: Parser (LocatedAn l ast)     maybeParensAST :: LocatedAn l ast -> LocatedAn l ast@@ -690,11 +752,6 @@ eqSrcSpan :: SrcSpan -> SrcSpan -> Bool eqSrcSpan l r = leftmost_smallest l r == EQ --- | Equality on SrcSpan's.--- Ignores the (Maybe BufSpan) field of SrcSpan's.-eqSrcSpanA :: SrcAnn a -> SrcAnn b -> Bool-eqSrcSpanA l r = leftmost_smallest (locA l) (locA r) == EQ- addParensToCtxt :: Maybe EpaLocation -> AnnContext -> AnnContext addParensToCtxt close_dp = addOpen . addClose   where@@ -712,15 +769,27 @@ epAnn srcSpan anns = EpAnn (spanAsAnchor srcSpan) anns emptyComments  modifyAnns :: LocatedAn a ast -> (a -> a) -> LocatedAn a ast+#if MIN_VERSION_ghc(9,9,0)+modifyAnns x f = first (fmap f) x+#else modifyAnns x f = first ((fmap.fmap) f) x+#endif  removeComma :: SrcSpanAnnA -> SrcSpanAnnA+#if MIN_VERSION_ghc(9,9,0)+removeComma  (EpAnn anc (AnnListItem as) cs)+  = EpAnn anc (AnnListItem (filter (not . isCommaAnn) as)) cs+  where+      isCommaAnn AddCommaAnn{} = True+      isCommaAnn _             = False+#else removeComma it@(SrcSpanAnn EpAnnNotUsed _) = it removeComma (SrcSpanAnn (EpAnn anc (AnnListItem as) cs) l)   = SrcSpanAnn (EpAnn anc (AnnListItem (filter (not . isCommaAnn) as)) cs) l   where       isCommaAnn AddCommaAnn{} = True       isCommaAnn _             = False+#endif  addParens :: Bool -> GHC.NameAnn -> GHC.NameAnn addParens True it@NameAnn{} =
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs view
@@ -1,5 +1,6 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0+{-# LANGUAGE CPP   #-} {-# LANGUAGE GADTs #-}  module Development.IDE.Plugin.CodeAction@@ -68,12 +69,9 @@ import           Development.IDE.Types.Location import           Development.IDE.Types.Options import           GHC                                               (AddEpAnn (AddEpAnn),-                                                                    Anchor (anchor_op),-                                                                    AnchorOperation (..),                                                                     AnnsModule (am_main),                                                                     DeltaPos (..),                                                                     EpAnn (..),-                                                                    EpaLocation (..),                                                                     LEpaComment) import qualified GHC.LanguageExtensions                            as Lang import           Ide.Logger                                        hiding@@ -99,18 +97,32 @@                                                                     WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges),                                                                     type (|?) (InL, InR),                                                                     uriToFilePath)-import qualified Language.LSP.Server                               as LSP import           Language.LSP.VFS                                  (virtualFileText) import qualified Text.Fuzzy.Parallel                               as TFP import qualified Text.Regex.Applicative                            as RE import           Text.Regex.TDFA                                   ((=~), (=~~)) +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if !MIN_VERSION_ghc(9,9,0)+import           GHC                                               (Anchor (anchor_op),+                                                                    AnchorOperation (..),+                                                                    EpaLocation (..))+#endif++#if MIN_VERSION_ghc(9,9,0)+import           GHC                                               (EpaLocation,+                                                                    EpaLocation' (..),+                                                                    HasLoc (..))+import           GHC.Types.SrcLoc                                  (srcSpanToRealSrcSpan)+#endif+ -------------------------------------------------------------------------------------------------  -- | Generate code actions. codeAction :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do-  contents <- lift $ LSP.getVirtualFile $ toNormalizedUri uri+  contents <- lift $ pluginGetVirtualFile $ toNormalizedUri uri   liftIO $ do     let text = virtualFileText <$> contents         mbFile = toNormalizedFilePath' <$> uriToFilePath uri@@ -190,7 +202,7 @@   whenJust res $ \(nfp, wedit@WorkspaceEdit {_changes}) -> do     whenJust (listToMaybe =<< listToMaybe . M.elems =<< _changes) $ \TextEdit {_range} -> do       let srcSpan = rangeToSrcSpan nfp _range-      LSP.sendNotification SMethod_WindowShowMessage $+      pluginSendNotification SMethod_WindowShowMessage $         ShowMessageParams MessageType_Info $           "Import "             <> maybe ("‘" <> newThing) (\x -> "‘" <> x <> " (" <> newThing <> ")") thingParent@@ -199,7 +211,7 @@             <> " (at "             <> printOutputable srcSpan             <> ")"-      void $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())+      void $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())   return $ Right $ InR Null  extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit)@@ -223,7 +235,12 @@         Just imp -> do             fmap (nfp,) $ liftEither $               rewriteToWEdit df doc $-                  extendImport (T.unpack <$> thingParent) (T.unpack newThing) (makeDeltaAst imp)+                  extendImport (T.unpack <$> thingParent) (T.unpack newThing)+#if MIN_VERSION_ghc(9,9,0)+                    imp+#else+                    (makeDeltaAst imp)+#endif          Nothing -> do             let qns = (,) <$> importQual <*> Just (qualifiedImportStyle df)@@ -253,7 +270,7 @@                                                        , ideclHiding = Just (False, _) #endif                                                        }) =-    unLoc ideclName == wantedModule && (wantedModule == qual || (unLoc . reLoc <$> ideclAs) == Just qual)+    unLoc ideclName == wantedModule && (wantedModule == qual || (unLoc <$> ideclAs) == Just qual) isWantedModule _ _ _ = False  @@ -307,7 +324,7 @@     findSigOfExpr :: HsExpr p -> Maybe (Sig p)     findSigOfExpr = go       where-#if MIN_VERSION_ghc(9,3,0)+#if MIN_VERSION_ghc(9,3,0) && !MIN_VERSION_ghc(9,9,0)         go (HsLet _ _ binds _ _) = findSigOfBinds range binds #else         go (HsLet _ binds _) = findSigOfBinds range binds@@ -338,7 +355,11 @@         showSDoc df (ppr hsib_body) == instanceHead     ] +#if MIN_VERSION_ghc(9,9,0)+findDeclContainingLoc :: (Foldable t, HasLoc l) => Position -> t (GenLocated l e) -> Maybe (GenLocated l e)+#else findDeclContainingLoc :: Foldable t => Position -> t (GenLocated (SrcSpanAnn' a) e) -> Maybe (GenLocated (SrcSpanAnn' a) e)+#endif findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` locA l)  -- Single:@@ -350,7 +371,7 @@ --  imported from ‘Data.ByteString’ at B.hs:6:1-22 --  imported from ‘Data.ByteString.Lazy’ at B.hs:8:1-27 --  imported from ‘Data.Text’ at B.hs:7:1-16-suggestHideShadow :: Annotated ParsedSource -> T.Text -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Either TextEdit Rewrite])]+suggestHideShadow :: ParsedSource -> T.Text -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Either TextEdit Rewrite])] suggestHideShadow ps fileContents mTcM mHar Diagnostic {_message, _range}   | Just [identifier, modName, s] <-       matchRegexUnifySpaces@@ -368,7 +389,7 @@     result <> [hideAll]   | otherwise = []   where-    L _ HsModule {hsmodImports} = astA ps+    L _ HsModule {hsmodImports} = ps      suggests identifier modName s       | Just tcM <- mTcM,@@ -423,7 +444,7 @@     | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"     , Just (L _ impDecl) <- find (\(L (locA -> l) _) -> _start _range `isInsideSrcSpan` l && _end _range `isInsideSrcSpan` l ) hsmodImports     , Just c <- contents-    , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings)+    , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings >>= trySplitIntoOriginalAndRecordField)     , ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges)     , not (null ranges')     = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]@@ -435,6 +456,15 @@     | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String)         = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]     | otherwise = []+    where+      -- In case of an unused record field import, the binding from the message will not match any import directly+      -- In this case, we try if we can additionally extract a record field name+      -- Example: The import of ‘B(b2)’ from module ‘ModuleB’ is redundant+      trySplitIntoOriginalAndRecordField :: T.Text -> [T.Text]+      trySplitIntoOriginalAndRecordField binding =+        case matchRegexUnifySpaces binding "([^ ]+)\\(([^)]+)\\)" of+          Just [_, fields] -> [binding, fields]+          _                -> [binding]  diagInRange :: Diagnostic -> Range -> Bool diagInRange Diagnostic {_range = dr} r = dr `subRange` extendedRange@@ -537,7 +567,7 @@ suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..}   | msg <- unifySpaces _message   , Just export <- hsmodExports-  , Just exportRange <- getLocatedRange $ reLoc export+  , Just exportRange <- getLocatedRange $ export   , exports <- unLoc export   , Just (removeFromExport, !ranges) <- fmap (getRanges exports . notInScope) (extractNotInScopeName msg)                          <|> (,[_range]) <$> matchExportItem msg@@ -608,16 +638,16 @@         let maybeIdx = findIndex (\(L _ id) -> isSameName id name) lnames         in case maybeIdx of             Nothing -> Nothing-            Just _ | [lname] <- lnames -> Just (getLoc $ reLoc lname, True)+            Just _ | [lname] <- lnames -> Just (getLoc lname, True)             Just idx ->-              let targetLname = getLoc $ reLoc $ lnames !! idx+              let targetLname = getLoc $ lnames !! idx                   startLoc = srcSpanStart targetLname                   endLoc = srcSpanEnd targetLname                   startLoc' = if idx == 0                               then startLoc-                              else srcSpanEnd . getLoc . reLoc $ lnames !! (idx - 1)+                              else srcSpanEnd . getLoc $ lnames !! (idx - 1)                   endLoc' = if idx == 0 && idx < length lnames - 1-                            then srcSpanStart . getLoc . reLoc $ lnames !! (idx + 1)+                            then srcSpanStart . getLoc $ lnames !! (idx + 1)                             else endLoc               in Just (mkSrcSpan startLoc' endLoc', False)       findRelatedSigSpan1 _ _ = Nothing@@ -1015,7 +1045,7 @@ suggestImportDisambiguation ::     DynFlags ->     Maybe T.Text ->-    Annotated ParsedSource ->+    ParsedSource ->     T.Text ->     Diagnostic ->     [(T.Text, [Either TextEdit Rewrite])]@@ -1031,7 +1061,7 @@         suggestions ambiguous modules (isJust local)     | otherwise = []     where-        L _ HsModule {hsmodImports} = astA ps+        L _ HsModule {hsmodImports} = ps          locDic =             fmap (NE.fromList . DL.toList) $@@ -1085,11 +1115,14 @@                         _                 -> False                     ]                 ++ [HideOthers restImports | not (null restImports)]-            ] ++ [ ( renderUniquify mode T.empty symbol True-              , disambiguateSymbol ps fileContents diag symbol mode-              ) | local, not (null targetsWithRestImports)-                , let mode = HideOthers (uncurry (:) (head targetsWithRestImports))-            ]+            ] ++ case targetsWithRestImports of+                    (m,ms):_ | local ->+                        let mode = HideOthers (m:ms)+                        in [( renderUniquify mode T.empty symbol True+                            , disambiguateSymbol ps fileContents diag symbol mode+                            )]+                    _ -> []+         renderUniquify HideOthers {} modName symbol local =             "Use " <> (if local then "local definition" else modName) <> " for " <> symbol <> ", hiding other imports"         renderUniquify (ToQualified _ qual) _ symbol _ =@@ -1126,7 +1159,7 @@     unLoc ideclName  disambiguateSymbol ::-    Annotated ParsedSource ->+    ParsedSource ->     T.Text ->     Diagnostic ->     T.Text ->@@ -1186,7 +1219,7 @@     in [("Fix import of " <> fixedImport, TextEdit _range fixedImport)]   | otherwise = [] -suggestAddRecordFieldImport :: ExportsMap -> DynFlags -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)]+suggestAddRecordFieldImport :: ExportsMap -> DynFlags -> ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)] suggestAddRecordFieldImport exportsMap df ps fileContents Diagnostic {..}   | Just fieldName <- findMissingField _message   , Just (range, indent) <- newImportInsertRange ps fileContents@@ -1207,11 +1240,17 @@  -- | Suggests a constraint for a declaration for which a constraint is missing. suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)]-suggestConstraint df (makeDeltaAst -> parsedModule) diag@Diagnostic {..}+suggestConstraint df ps diag@Diagnostic {..}   | Just missingConstraint <- findMissingConstraint _message-  = let codeAction = if _message =~ ("the type signature for:" :: String)-                        then suggestFunctionConstraint df parsedModule-                        else suggestInstanceConstraint df parsedModule+  = let+#if MIN_VERSION_ghc(9,9,0)+        parsedSource = ps+#else+        parsedSource = makeDeltaAst ps+#endif+        codeAction = if _message =~ ("the type signature for:" :: String)+                        then suggestFunctionConstraint df parsedSource+                        else suggestInstanceConstraint df parsedSource      in codeAction diag missingConstraint   | otherwise = []     where@@ -1330,7 +1369,11 @@  -- | Suggests the removal of a redundant constraint for a type signature. removeRedundantConstraints :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)]+#if MIN_VERSION_ghc(9,9,0)+removeRedundantConstraints df (L _ HsModule {hsmodDecls}) Diagnostic{..}+#else removeRedundantConstraints df (makeDeltaAst -> L _ HsModule {hsmodDecls}) Diagnostic{..}+#endif -- • Redundant constraint: Eq a -- • In the type signature for: --      foo :: forall a. Eq a => a -> a@@ -1395,7 +1438,7 @@  ------------------------------------------------------------------------------------------------- -suggestNewOrExtendImportForClassMethod :: ExportsMap -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, [Either TextEdit Rewrite])]+suggestNewOrExtendImportForClassMethod :: ExportsMap -> ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, [Either TextEdit Rewrite])] suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnostic {_message}   | Just [methodName, className] <-       matchRegexUnifySpaces@@ -1409,7 +1452,7 @@   where     suggest identInfo       | importStyle <- NE.toList $ importStyles identInfo,-        mImportDecl <- findImportDeclByModuleName (hsmodImports . unLoc . astA $ ps) (T.unpack moduleText) =+        mImportDecl <- findImportDeclByModuleName (hsmodImports . unLoc $ ps) (T.unpack moduleText) =         case mImportDecl of           -- extend           Just decl ->@@ -1432,7 +1475,7 @@             | otherwise -> []         where moduleText = moduleNameText identInfo -suggestNewImport :: DynFlags -> ExportsMap -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)]+suggestNewImport :: DynFlags -> ExportsMap -> ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)] suggestNewImport df packageExportsMap ps fileContents Diagnostic{..}   | msg <- unifySpaces _message   , Just thingMissing <- extractNotInScopeName msg@@ -1474,7 +1517,7 @@     qualify q (NotInScopeTypeConstructorOrClass d) = NotInScopeTypeConstructorOrClass (q <> "." <> d)     qualify q (NotInScopeThing d) = NotInScopeThing (q <> "." <> d) -    L _ HsModule {..} = astA ps+    L _ HsModule {..} = ps suggestNewImport _ _ _ _ _ = []  {- |@@ -1591,7 +1634,7 @@ newtype NewImport = NewImport {unNewImport :: T.Text}   deriving (Show, Eq, Ord) -newImportToEdit :: NewImport -> Annotated ParsedSource -> T.Text -> Maybe (T.Text, TextEdit)+newImportToEdit :: NewImport -> ParsedSource -> T.Text -> Maybe (T.Text, TextEdit) newImportToEdit (unNewImport -> imp) ps fileContents   | Just (range, indent) <- newImportInsertRange ps fileContents   = Just (imp, TextEdit range (imp <> "\n" <> T.replicate indent " "))@@ -1605,48 +1648,51 @@ -- * If the file has neither existing imports nor a module declaration, -- the import will be inserted at line zero if there are no pragmas, -- * otherwise inserted one line after the last file-header pragma-newImportInsertRange :: Annotated ParsedSource -> T.Text -> Maybe (Range, Int)+newImportInsertRange :: ParsedSource -> T.Text -> Maybe (Range, Int) newImportInsertRange ps fileContents   |  Just ((l, c), col) <- case hsmodImports of       -- When there is no existing imports, we only cares about the line number, setting column and indent to zero.       [] -> (\line -> ((line, 0), 0)) <$> findPositionNoImports ps fileContents-      _  -> findPositionFromImports (map reLoc hsmodImports) last+      _  -> findPositionFromImports hsmodImports last   , let insertPos = Position (fromIntegral l) (fromIntegral c)     = Just (Range insertPos insertPos, col)   | otherwise = Nothing   where-    L _ HsModule {..} = astA ps+    L _ HsModule {..} = ps  -- | Find the position for a new import when there isn't an existing one. -- * If there is a module declaration, a new import should be inserted under the module declaration (including exports list) -- * Otherwise, a new import should be inserted after any file-header pragma.-findPositionNoImports :: Annotated ParsedSource -> T.Text -> Maybe Int+findPositionNoImports :: ParsedSource -> T.Text -> Maybe Int findPositionNoImports ps fileContents =     maybe (Just (findNextPragmaPosition fileContents)) (findPositionAfterModuleName ps) hsmodName   where-    L _ HsModule {..} = astA ps+    L _ HsModule {..} = ps  -- | find line number right after module ... where-findPositionAfterModuleName :: Annotated ParsedSource+findPositionAfterModuleName :: ParsedSource                             -> LocatedA ModuleName                             -> Maybe Int-findPositionAfterModuleName ps hsmodName' = do+findPositionAfterModuleName ps _hsmodName' = do     -- Note that 'where' keyword and comments are not part of the AST. They belongs to     -- the exact-print information. To locate it, we need to find the previous AST node,     -- calculate the gap between it and 'where', then add them up to produce the absolute     -- position of 'where'.      lineOffset <- whereKeywordLineOffset -- Calculate the gap before 'where' keyword.+#if MIN_VERSION_ghc(9,9,0)+    pure lineOffset+#else+    -- The last AST node before 'where' keyword. Might be module name or export list.+    let prevSrcSpan = maybe (getLoc _hsmodName') getLoc hsmodExports     case prevSrcSpan of         UnhelpfulSpan _ -> Nothing         (RealSrcSpan prevSrcSpan' _) ->             -- add them up produce the absolute location of 'where' keyword             Just $ srcLocLine (realSrcSpanEnd prevSrcSpan') + lineOffset+#endif   where-    L _ HsModule {..} = astA ps--    -- The last AST node before 'where' keyword. Might be module name or export list.-    prevSrcSpan = maybe (getLoc hsmodName') getLoc hsmodExports+    L _ HsModule {..} = ps      -- The relative position of 'where' keyword (in lines, relative to the previous AST node).     -- The exact-print API changed a lot in ghc-9.2, so we need to handle it separately for different compiler versions.@@ -1660,12 +1706,17 @@             -- Find the first 'where'             whereLocation <- listToMaybe . mapMaybe filterWhere $ am_main annsModule             epaLocationToLine whereLocation+#if !MIN_VERSION_ghc(9,9,0)         EpAnnNotUsed -> Nothing+#endif     filterWhere (AddEpAnn AnnWhere loc) = Just loc     filterWhere _                       = Nothing      epaLocationToLine :: EpaLocation -> Maybe Int-#if MIN_VERSION_ghc(9,5,0)+#if MIN_VERSION_ghc(9,9,0)+    epaLocationToLine (EpaSpan sp)+      = fmap (srcLocLine . realSrcSpanEnd) $ srcSpanToRealSrcSpan sp+#elif MIN_VERSION_ghc(9,5,0)     epaLocationToLine (EpaSpan sp _)       = Just . srcLocLine . realSrcSpanEnd $ sp #else@@ -1679,12 +1730,23 @@     epaLocationToLine (EpaDelta (DifferentLine line _) priorComments) = Just (line + sumCommentsOffset priorComments)      sumCommentsOffset :: [LEpaComment] -> Int+#if MIN_VERSION_ghc(9,9,0)+    sumCommentsOffset = sum . fmap (\(L anchor _) -> anchorOpLine anchor)+#else     sumCommentsOffset = sum . fmap (\(L anchor _) -> anchorOpLine (anchor_op anchor))+#endif +#if MIN_VERSION_ghc(9,9,0)+    anchorOpLine :: EpaLocation' a -> Int+    anchorOpLine EpaSpan{}                           = 0+    anchorOpLine (EpaDelta (SameLine _) _)           = 0+    anchorOpLine (EpaDelta (DifferentLine line _) _) = line+#else     anchorOpLine :: AnchorOperation -> Int     anchorOpLine UnchangedAnchor                      = 0     anchorOpLine (MovedAnchor (SameLine _))           = 0     anchorOpLine (MovedAnchor (DifferentLine line _)) = line+#endif  findPositionFromImports :: HasSrcSpan a => t -> (t -> a) -> Maybe ((Int, Int), Int) findPositionFromImports hsField f = case getLoc (f hsField) of@@ -1932,23 +1994,40 @@     concatMap (mapMaybe srcSpanToRange . ranges') lies   where     unqualify = snd . breakOnEnd "."-    b' = wrapOperatorInParens . unqualify $ b+    b' = wrapOperatorInParens $ unqualify b+#if MIN_VERSION_ghc(9,9,0)+    ranges' (L _ (IEThingWith _ thing _  inners _))+#else     ranges' (L _ (IEThingWith _ thing _  inners))+#endif       | T.unpack (printOutputable thing) == b' = []       | otherwise =           [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b']     ranges' _ = []  rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]+#if MIN_VERSION_ghc(9,9,0)+rangesForBinding' b (L (locA -> l) (IEVar _ nm _))+#else rangesForBinding' b (L (locA -> l) (IEVar _ nm))+#endif   | L _ (IEPattern _ (L _ b')) <- nm   , T.unpack (printOutputable b') == b   = [l] rangesForBinding' b (L (locA -> l) x@IEVar{})   | T.unpack (printOutputable x) == b = [l] rangesForBinding' b (L (locA -> l) x@IEThingAbs{}) | T.unpack (printOutputable x) == b = [l]-rangesForBinding' b (L (locA -> l) (IEThingAll _ x)) | T.unpack (printOutputable x) == b = [l]+#if MIN_VERSION_ghc(9,9,0)+rangesForBinding' b (L (locA -> l) (IEThingAll _ x _))+#else+rangesForBinding' b (L (locA -> l) (IEThingAll _ x))+#endif+  | T.unpack (printOutputable x) == b = [l]+#if MIN_VERSION_ghc(9,9,0)+rangesForBinding' b (L (locA -> l) (IEThingWith _ thing _  inners _))+#else rangesForBinding' b (L (locA -> l) (IEThingWith _ thing _  inners))+#endif     | T.unpack (printOutputable thing) == b = [l]     | otherwise =         [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b]
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs view
@@ -28,7 +28,6 @@                                                               (pluginHandlers) import           Development.IDE.Core.Shake import           Development.IDE.GHC.Compat-import           Development.IDE.GHC.Compat.ExactPrint import           Development.IDE.GHC.ExactPrint import           Development.IDE.Plugin.CodeAction.ExactPrint (Rewrite,                                                                rewriteToEdit)@@ -41,7 +40,6 @@ import           Ide.Types import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types-import qualified Language.LSP.Server                          as LSP  type CodeActionTitle = T.Text @@ -53,7 +51,7 @@  ------------------------------------------------------------------------------------------------- -runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams Method_TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult+runGhcideCodeAction :: IdeState -> MessageParams Method_TextDocumentCodeAction -> GhcideCodeAction -> HandlerM Config GhcideCodeActionResult runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = diags}) codeAction = do   let mbFile = toNormalizedFilePath' <$> uriToFilePath uri       runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key@@ -141,7 +139,7 @@     caaParsedModule :: IO (Maybe ParsedModule),     caaContents     :: IO (Maybe T.Text),     caaDf           :: IO (Maybe DynFlags),-    caaAnnSource    :: IO (Maybe (Annotated ParsedSource)),+    caaAnnSource    :: IO (Maybe ParsedSource),     caaTmr          :: IO (Maybe TcModuleResult),     caaHar          :: IO (Maybe HieAstResult),     caaBindings     :: IO (Maybe Bindings),@@ -215,17 +213,7 @@  -- | this instance returns a delta AST, useful for exactprint transforms instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where-#if !MIN_VERSION_ghc(9,3,0)-  toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} ->-    x >>= \case-      Just s -> flip runReaderT caa . runExceptT . toCodeAction . f . astA $ s-      _      -> pure $ Right []-#else-  toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaParsedModule = x} ->-    x >>= \case-      Just s -> flip runReaderT caa . runExceptT . toCodeAction . f . pm_parsed_source $ s-      _      -> pure $ Right []-#endif+  toCodeAction = toCodeAction2 caaAnnSource  instance ToCodeAction r => ToCodeAction (ExportsMap -> r) where   toCodeAction = toCodeAction3 caaExportsMap@@ -254,11 +242,8 @@ instance ToCodeAction r => ToCodeAction (DynFlags -> r) where   toCodeAction = toCodeAction2 caaDf -instance ToCodeAction r => ToCodeAction (Maybe (Annotated ParsedSource) -> r) where+instance ToCodeAction r => ToCodeAction (Maybe ParsedSource -> r) where   toCodeAction = toCodeAction1 caaAnnSource--instance ToCodeAction r => ToCodeAction (Annotated ParsedSource -> r) where-  toCodeAction = toCodeAction2 caaAnnSource  instance ToCodeAction r => ToCodeAction (Maybe TcModuleResult -> r) where   toCodeAction = toCodeAction1 caaTmr
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs view
@@ -31,28 +31,32 @@ import           Language.Haskell.GHC.ExactPrint import           Language.LSP.Protocol.Types -import           Development.IDE.Plugin.CodeAction.Util---- GHC version specific imports. For any supported GHC version, make sure there is no warning in imports. import           Control.Lens                           (_head, _last, over) import           Data.Bifunctor                         (first)-import           Data.Default                           (Default (..))-import           Data.Maybe                             (fromMaybe,-                                                         mapMaybe)+import           Data.Maybe                             (fromMaybe, mapMaybe)+import           Development.IDE.Plugin.CodeAction.Util import           GHC                                    (AddEpAnn (..),                                                          AnnContext (..),                                                          AnnList (..),                                                          AnnParen (..),                                                          DeltaPos (SameLine),                                                          EpAnn (..),-                                                         EpaLocation (EpaDelta),                                                          IsUnicodeSyntax (NormalSyntax),                                                          NameAdornment (NameParens),                                                          TrailingAnn (AddCommaAnn),-                                                         addAnns, ann,                                                          emptyComments, reAnnL) +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] +#if !MIN_VERSION_ghc(9,9,0)+import           Data.Default                           (Default (..))+import           GHC                                    (addAnns, ann)+#endif++#if MIN_VERSION_ghc(9,9,0)+import           GHC                                    (NoAnn (..))+#endif+ ------------------------------------------------------------------------------  -- | Construct a 'Rewrite', replacing the node at the given 'SrcSpan' with the@@ -69,9 +73,13 @@ ------------------------------------------------------------------------------ class ResetEntryDP ann where     resetEntryDP :: GenLocated ann ast -> GenLocated ann ast+#if MIN_VERSION_ghc(9,9,0)+instance {-# OVERLAPPING #-} NoAnn an => ResetEntryDP (EpAnn an) where+    resetEntryDP (L srcAnn x) = setEntryDP (L srcAnn{anns=noAnn} x) (SameLine 0)+#else instance {-# OVERLAPPING #-} Default an => ResetEntryDP (SrcAnn an) where-    -- resetEntryDP = flip setEntryDP (SameLine 0)     resetEntryDP (L srcAnn x) = setEntryDP (L srcAnn{ann=EpAnnNotUsed} x) (SameLine 0)+#endif instance {-# OVERLAPPABLE #-} ResetEntryDP fallback where     resetEntryDP = id @@ -121,10 +129,12 @@ removeConstraint toRemove = go . traceAst "REMOVE_CONSTRAINT_input"   where     go :: LHsType GhcPs -> Rewrite-#if !MIN_VERSION_ghc(9,4,0)-    go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt), hst_body}) = Rewrite (locA l) $ \_ -> do-#else+#if MIN_VERSION_ghc(9,9,0)+    go lHsType@(makeDeltaAst -> L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite (locA lHsType) $ \_ -> do+#elif MIN_VERSION_ghc(9,4,0)     go (L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite (locA l) $ \_ -> do+#else+    go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt), hst_body}) = Rewrite (locA l) $ \_ -> do #endif       let ctxt' = filter (not . toRemove) ctxt           removeStuff = (toRemove <$> headMaybe ctxt) == Just True@@ -161,11 +171,19 @@ #endif     constraint <- liftParseAST df constraintT     constraint <- pure $ setEntryDP constraint (SameLine 1)+#if MIN_VERSION_ghc(9,9,0)+    let l'' = fmap (addParensToCtxt close_dp) l'+#else     let l'' = (fmap.fmap) (addParensToCtxt close_dp) l'+#endif     -- For singleton constraints, the close Paren DP is attached to an HsPar wrapping the constraint     -- we have to reposition it manually into the AnnContext         close_dp = case ctxt of+#if MIN_VERSION_ghc(9,9,0)+            [L _ (HsParTy AnnParen{ap_close} _)] -> Just ap_close+#else             [L _ (HsParTy EpAnn{anns=AnnParen{ap_close}} _)] -> Just ap_close+#endif             _ -> Nothing         ctxt' = over _last (first addComma) $ map dropHsParTy ctxt #if MIN_VERSION_ghc(9,4,0)@@ -187,7 +205,7 @@ #endif         annCtxt = AnnContext (Just (NormalSyntax, epl 1)) [epl 0 | needsParens] [epl 0 | needsParens]         needsParens = hsTypeNeedsParens sigPrec $ unLoc constraint-    ast <- pure $ setEntryDP ast (SameLine 1)+    ast <- pure $ setEntryDP (makeDeltaAst ast) (SameLine 1)      return $ reLocA $ L lTop $ HsQualTy noExtField context ast @@ -259,6 +277,9 @@                                noExtField #endif                                lie+#if MIN_VERSION_ghc(9,9,0)+                               Nothing+#endif      if x `elem` lies       then TransformT $ lift (Left $ thing <> " already imported")@@ -304,9 +325,17 @@   | Just (hide, L l' lies) <- ideclHiding = go hide l' [] lies #endif  where+#if MIN_VERSION_ghc(9,9,0)+  go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie) _)) : _xs)+#else   go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie))) : _xs)+#endif     | parent == unIEWrappedName ie = TransformT $ lift . Left $ child <> " already included in " <> parent <> " imports"+#if MIN_VERSION_ghc(9,9,0)+  go hide l' pre ((L ll' (IEThingAbs _ absIE@(L _ ie) docs)) : xs)+#else   go hide l' pre ((L ll' (IEThingAbs _ absIE@(L _ ie))) : xs)+#endif     -- ThingAbs ie => ThingWith ie child     | parent == unIEWrappedName ie = do       srcChild <- uniqueSrcSpanT@@ -317,20 +346,30 @@ #endif                                              childRdr           x :: LIE GhcPs = L ll' $ IEThingWith-#if MIN_VERSION_ghc(9,7,0)-                                     (Nothing, addAnns mempty [AddEpAnn AnnOpenP (EpaDelta (SameLine 1) []), AddEpAnn AnnCloseP def] emptyComments)+#if MIN_VERSION_ghc(9,9,0)+                                     (Nothing, [AddEpAnn AnnOpenP d1, AddEpAnn AnnCloseP noAnn])+#elif MIN_VERSION_ghc(9,7,0)+                                     (Nothing, addAnns mempty [AddEpAnn AnnOpenP d1, AddEpAnn AnnCloseP def] emptyComments) #else-                                     (addAnns mempty [AddEpAnn AnnOpenP (EpaDelta (SameLine 1) []), AddEpAnn AnnCloseP def] emptyComments)+                                     (addAnns mempty [AddEpAnn AnnOpenP d1, AddEpAnn AnnCloseP def] emptyComments) #endif                                      absIE NoIEWildcard [childLIE]+#if MIN_VERSION_ghc(9,9,0)+                                     docs+#endif + #if MIN_VERSION_ghc(9,5,0)       return $ L l it{ideclImportList = Just (hide, L l' $ reverse pre ++ [x] ++ xs)} #else       return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [x] ++ xs)} #endif +#if MIN_VERSION_ghc(9,9,0)+  go hide l' pre ((L l'' (IEThingWith l''' twIE@(L _ ie) _ lies' docs)) : xs)+#else   go hide l' pre ((L l'' (IEThingWith l''' twIE@(L _ ie) _ lies')) : xs)+#endif     -- ThingWith ie lies' => ThingWith ie (lies' ++ [child])     | parent == unIEWrappedName ie     , child == wildCardSymbol = do@@ -340,7 +379,10 @@         let it' = it{ideclHiding = Just (hide, lies)} #endif             thing = IEThingWith newl twIE (IEWildcard 2) []-#if MIN_VERSION_ghc(9,7,0)+#if MIN_VERSION_ghc(9,9,0)+                                docs+#endif+#if MIN_VERSION_ghc(9,7,0) && !MIN_VERSION_ghc(9,9,0)             newl = fmap (\ann -> ann ++ [AddEpAnn AnnDotdot d0]) <$> l''' #else             newl = (\ann -> ann ++ [AddEpAnn AnnDotdot d0]) <$> l'''@@ -369,7 +411,11 @@         let it' = it{ideclHiding = Just (hide, lies)} #endif             lies = L l' $ reverse pre ++-                [L l'' (IEThingWith l''' twIE NoIEWildcard (over _last fixLast lies' ++ [childLIE]))] ++ xs+                [L l'' (IEThingWith l''' twIE NoIEWildcard (over _last fixLast lies' ++ [childLIE])+#if MIN_VERSION_ghc(9,9,0)+                                    docs+#endif+                       )] ++ xs             fixLast = if hasSibling then first addComma else id         return $ L l it'   go hide l' pre (x : xs) = go hide l' (x : pre) xs@@ -395,12 +441,17 @@                                              noExtField #endif                                              childRdr-#if MIN_VERSION_ghc(9,7,0)+#if MIN_VERSION_ghc(9,9,0)+          listAnn = (Nothing, [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)])+#elif MIN_VERSION_ghc(9,7,0)           listAnn = (Nothing, epAnn srcParent [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)]) #else           listAnn = epAnn srcParent [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)] #endif           x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith listAnn parentLIE NoIEWildcard [childLIE]+#if MIN_VERSION_ghc(9,9,0)+                                                        Nothing -- TODO preserve docs?+#endif            lies' = addCommaInImportList (reverse pre) x #if MIN_VERSION_ghc(9,5,0)@@ -427,9 +478,14 @@     -- check if there is an existing trailing comma     existingTrailingComma = fromMaybe False $ do         L lastItemSrcAnn _ <- lastMaybe lies+#if MIN_VERSION_ghc(9,9,0)+        lastItemAnn <- case lastItemSrcAnn of+            EpAnn _ lastItemAnn _ -> pure lastItemAnn+#else         lastItemAnn <- case ann lastItemSrcAnn of             EpAnn _ lastItemAnn _ -> pure lastItemAnn             _ -> Nothing+#endif         pure $ any isTrailingAnnComma (lann_trailing lastItemAnn)      hasSibling = not $ null lies@@ -465,7 +521,7 @@   case ideclImportList of     Nothing -> Rewrite (locA loc) $ extendHiding symbol lidecl Nothing     Just (EverythingBut, hides) -> Rewrite (locA loc) $ extendHiding symbol lidecl (Just hides)-    Just (Exactly, imports) -> Rewrite (locA loc) $ deleteFromImport symbol lidecl imports+    Just (Exactly, imports) -> Rewrite (locA loc) $ deleteFromImport symbol lidecl $ setEntryDP (makeDeltaAst imports) (SameLine 1) #else   case ideclHiding of     Nothing -> Rewrite (locA loc) $ extendHiding symbol lidecl Nothing@@ -482,9 +538,17 @@ extendHiding symbol (L l idecls) mlies df = do   L l' lies <- case mlies of     Nothing -> do+#if MIN_VERSION_ghc(9,9,0)+        let ann = noAnnSrcSpanDP0+#else         src <- uniqueSrcSpanT         let ann = noAnnSrcSpanDP0 src+#endif+#if MIN_VERSION_ghc(9,9,0)+            ann' = flip fmap ann $ \x -> x+#else             ann' = flip (fmap.fmap) ann $ \x -> x+#endif                 {al_rest = [AddEpAnn AnnHiding (epl 1)]                 ,al_open = Just $ AddEpAnn AnnOpenP (epl 1)                 ,al_close = Just $ AddEpAnn AnnCloseP (epl 0)@@ -508,6 +572,9 @@                              noExtField #endif                              lie+#if MIN_VERSION_ghc(9,9,0)+                             Nothing+#endif   x <- pure $ if hasSibling then first addComma x else x   lies <- pure $ over _head (`setEntryDP` SameLine 1) lies #if MIN_VERSION_ghc(9,5,0)@@ -530,24 +597,35 @@         L l $           idecl #if MIN_VERSION_ghc(9,5,0)-            { ideclImportList = Just (Exactly, edited)+            { ideclImportList = Just (Exactly, edited) } #else-            { ideclHiding = Just (False, edited)+            { ideclHiding = Just (False, edited) } #endif-            }   pure lidecl'  where   deletedLies =     over _last removeTrailingComma $     mapMaybe killLie lies   killLie :: LIE GhcPs -> Maybe (LIE GhcPs)+#if MIN_VERSION_ghc(9,9,0)+  killLie v@(L _ (IEVar _ (L _ (unqualIEWrapName -> nam)) _))+#else   killLie v@(L _ (IEVar _ (L _ (unqualIEWrapName -> nam))))+#endif     | nam == symbol = Nothing     | otherwise = Just v+#if MIN_VERSION_ghc(9,9,0)+  killLie v@(L _ (IEThingAbs _ (L _ (unqualIEWrapName -> nam)) _))+#else   killLie v@(L _ (IEThingAbs _ (L _ (unqualIEWrapName -> nam))))+#endif     | nam == symbol = Nothing     | otherwise = Just v+#if MIN_VERSION_ghc(9,9,0)+  killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons docs))+#else   killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons))+#endif     | nam == symbol = Nothing     | otherwise =       Just $@@ -557,4 +635,7 @@             ty             wild             (filter ((/= symbol) . unqualIEWrapName . unLoc) cons)+#if MIN_VERSION_ghc(9,9,0)+            docs+#endif   killLie v = Just v
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs view
@@ -7,39 +7,51 @@ import           Data.Either.Extra                         (maybeToEither) import qualified Data.Text                                 as T import           Development.IDE.GHC.Compat-import           Development.IDE.GHC.Compat.ExactPrint     (exactPrint,-                                                            makeDeltaAst) import           Development.IDE.GHC.Error                 (spanContainsRange)-import           Development.IDE.GHC.ExactPrint            (genAnchor1,-                                                            modifyMgMatchesT',+import           Development.IDE.GHC.ExactPrint            (modifyMgMatchesT',                                                             modifySigWithM,                                                             modifySmallestDeclWithM) import           Development.IDE.Plugin.Plugins.Diagnostic-import           GHC                                       (EpAnn (..),-                                                            SrcSpanAnn' (SrcSpanAnn),-                                                            SrcSpanAnnA,-                                                            SrcSpanAnnN,-                                                            emptyComments,-                                                            noAnn)-import           GHC.Types.SrcLoc                          (generatedSrcSpan)+import           GHC.Parser.Annotation                     (SrcSpanAnnA,+                                                            SrcSpanAnnN, noAnn) import           Ide.Plugin.Error                          (PluginError (PluginInternalError)) import           Ide.PluginUtils                           (makeDiffTextEdit) import           Language.Haskell.GHC.ExactPrint           (TransformT (..),+                                                            exactPrint,                                                             noAnnSrcSpanDP1,                                                             runTransformT) import           Language.LSP.Protocol.Types +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]+ #if !MIN_VERSION_ghc(9,4,0)-import           GHC                                       (TrailingAnn (..))-import           GHC.Hs                                    (IsUnicodeSyntax (..))-import           Language.Haskell.GHC.ExactPrint.Transform (d1)+import           GHC.Parser.Annotation                     (IsUnicodeSyntax (..),+                                                            TrailingAnn (..))+import           Language.Haskell.GHC.ExactPrint           (d1) #endif -#if MIN_VERSION_ghc(9,4,0)+#if MIN_VERSION_ghc(9,4,0) && !MIN_VERSION_ghc(9,9,0) import           Development.IDE.GHC.ExactPrint            (epl) import           GHC.Parser.Annotation                     (TokenLocation (..)) #endif +#if !MIN_VERSION_ghc(9,9,0)+import           Development.IDE.GHC.Compat.ExactPrint     (makeDeltaAst)+import           Development.IDE.GHC.ExactPrint            (genAnchor1)+import           GHC.Parser.Annotation                     (EpAnn (..),+                                                            SrcSpanAnn' (..),+                                                            emptyComments)+import           GHC.Types.SrcLoc                          (generatedSrcSpan)+#endif++#if MIN_VERSION_ghc(9,9,0)+import           GHC                                       (DeltaPos (..),+                                                            EpUniToken (..),+                                                            IsUnicodeSyntax (NormalSyntax))+import           Language.Haskell.GHC.ExactPrint           (d1, setEntryDP)+#endif++ -- When GHC tells us that a variable is not bound, it will tell us either: --  - there is an unbound variable with a given type --  - there is an unbound variable (GHC provides no type suggestion)@@ -64,11 +76,20 @@ -- returning how many patterns there were in this match prior to the transformation: --      addArgToMatch "foo" `bar arg1 arg2 = ...` --   => (`bar arg1 arg2 foo = ...`, 2)-addArgToMatch :: T.Text -> GenLocated l (Match GhcPs body) -> (GenLocated l (Match GhcPs body), Int)+addArgToMatch :: T.Text -> GenLocated l (Match GhcPs (LocatedA (HsExpr GhcPs))) -> (GenLocated l (Match GhcPs (LocatedA (HsExpr GhcPs))), Int) addArgToMatch name (L locMatch (Match xMatch ctxMatch pats rhs)) =   let unqualName = mkRdrUnqual $ mkVarOcc $ T.unpack name+#if MIN_VERSION_ghc(9,9,0)+      newPat = L noAnnSrcSpanDP1 $ VarPat NoExtField $ L noAnn unqualName+      -- The intention is to move `= ...` (right-hand side with equals) to the right so there's 1 space between+      -- the newly added pattern and the rest+      indentRhs :: GRHSs GhcPs (LocatedA (HsExpr GhcPs)) -> GRHSs GhcPs (LocatedA (HsExpr GhcPs))+      indentRhs rhs@GRHSs{grhssGRHSs} = rhs {grhssGRHSs = fmap (`setEntryDP` (SameLine 1)) grhssGRHSs }+#else       newPat = L (noAnnSrcSpanDP1 generatedSrcSpan) $ VarPat NoExtField (noLocA unqualName)-  in (L locMatch (Match xMatch ctxMatch (pats <> [newPat]) rhs), Prelude.length pats)+      indentRhs = id+#endif+  in (L locMatch (Match xMatch ctxMatch (pats <> [newPat]) (indentRhs rhs)), Prelude.length pats)  -- Attempt to insert a binding pattern into each match for the given LHsDecl; succeeds only if the function is a FunBind. -- Also return:@@ -107,7 +128,12 @@ addArgumentAction :: ParsedModule -> Range -> T.Text -> Maybe T.Text -> Either PluginError [(T.Text, [TextEdit])] addArgumentAction (ParsedModule _ moduleSrc _ _) range name _typ = do     (newSource, _, _) <- runTransformT $ do-      (moduleSrc', join -> matchedDeclNameMay) <- addNameAsLastArgOfMatchingDecl (makeDeltaAst moduleSrc)+      (moduleSrc', join -> matchedDeclNameMay) <- addNameAsLastArgOfMatchingDecl+#if MIN_VERSION_ghc(9,9,0)+        moduleSrc+#else+        (makeDeltaAst moduleSrc)+#endif       case matchedDeclNameMay of           Just (matchedDeclName, numPats) -> modifySigWithM (unLoc matchedDeclName) (addTyHoleToTySigArg numPats) moduleSrc'           Nothing -> pure moduleSrc'@@ -136,16 +162,34 @@ --   0 `foo :: ()` => foo :: _ -> () --   2 `foo :: FunctionTySyn` => foo :: FunctionTySyn --   1 `foo :: () -> () -> Int` => foo :: () -> _ -> () -> Int-addTyHoleToTySigArg :: Int -> LHsSigType GhcPs -> (LHsSigType GhcPs)+addTyHoleToTySigArg :: Int -> LHsSigType GhcPs -> LHsSigType GhcPs addTyHoleToTySigArg loc (L annHsSig (HsSig xHsSig tyVarBndrs lsigTy)) =     let (args, res) = hsTypeToFunTypeAsList lsigTy-#if MIN_VERSION_ghc(9,4,0)+#if MIN_VERSION_ghc(9,9,0)+        wildCardAnn = noAnnSrcSpanDP1+        newArg =+          ( noAnn+          , noExtField+          , HsUnrestrictedArrow (EpUniTok d1 NormalSyntax)+          , L wildCardAnn $ HsWildCardTy noExtField+          )+#elif MIN_VERSION_ghc(9,4,0)         wildCardAnn = SrcSpanAnn (EpAnn genAnchor1 (AnnListItem []) emptyComments) generatedSrcSpan         arrowAnn = TokenLoc (epl 1)-        newArg = (SrcSpanAnn mempty generatedSrcSpan, noAnn, HsUnrestrictedArrow (L arrowAnn HsNormalTok), L wildCardAnn $ HsWildCardTy noExtField)+        newArg =+          ( SrcSpanAnn mempty generatedSrcSpan+          , noAnn+          , HsUnrestrictedArrow (L arrowAnn HsNormalTok)+          , L wildCardAnn $ HsWildCardTy noExtField+          ) #else         wildCardAnn = SrcSpanAnn (EpAnn genAnchor1 (AnnListItem [AddRarrowAnn d1]) emptyComments) generatedSrcSpan-        newArg = (SrcSpanAnn mempty generatedSrcSpan, noAnn, HsUnrestrictedArrow NormalSyntax, L wildCardAnn $ HsWildCardTy noExtField)+        newArg =+          ( SrcSpanAnn mempty generatedSrcSpan+          , noAnn+          , HsUnrestrictedArrow NormalSyntax+          , L wildCardAnn $ HsWildCardTy noExtField+          ) #endif         -- NOTE if the location that the argument wants to be placed at is not one more than the number of arguments         --      in the signature, then we return the original type signature.@@ -156,4 +200,3 @@         insertArg n (a:as) = a : insertArg (n - 1) as         lsigTy' = hsTypeFromFunTypeAsList (insertArg loc args, res)     in L annHsSig (HsSig xHsSig tyVarBndrs lsigTy')-
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs view
@@ -69,7 +69,8 @@             (mrAfter . (=~ t " *Valid (hole fits|substitutions) include"))             validHolesSection       let holeFit = T.strip $ T.takeWhile (/= ':') holeFitLine-      guard (not $ T.null holeFit)+      guard $ not $ holeFit =~ t "Some hole fits suppressed"+      guard $ not $ T.null holeFit       return holeFit     refSuggestions = do -- @[]       -- get the text indented under Valid refinement hole fits
plugins/hls-refactor-plugin/test/Main.hs view
@@ -27,7 +27,6 @@ import           Development.IDE.Test import           Development.IDE.Types.Location import           Development.Shake                        (getDirectoryFilesIO)-import           Ide.Types import qualified Language.LSP.Protocol.Lens               as L import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types              hiding@@ -48,25 +47,22 @@ import           Development.IDE.Plugin.CodeAction        (matchRegExMultipleImports) import           Test.Hls +import qualified Development.IDE.GHC.ExactPrint import qualified Development.IDE.Plugin.CodeAction        as Refactor-import qualified Development.IDE.Plugin.HLS.GhcIde        as GhcIde import qualified Test.AddArgument  main :: IO () main = defaultTestRunner tests -refactorPlugin :: IO (IdePlugins IdeState)+refactorPlugin :: PluginTestDescriptor Development.IDE.GHC.ExactPrint.Log refactorPlugin = do-  exactprintLog <- pluginTestRecorder-  ghcideLog <- pluginTestRecorder-  pure $ IdePlugins $-      [ Refactor.iePluginDescriptor exactprintLog "ghcide-code-actions-imports-exports"-      , Refactor.typeSigsPluginDescriptor exactprintLog "ghcide-code-actions-type-signatures"-      , Refactor.bindingsPluginDescriptor exactprintLog "ghcide-code-actions-bindings"-      , Refactor.fillHolePluginDescriptor exactprintLog "ghcide-code-actions-fill-holes"-      , Refactor.extendImportPluginDescriptor exactprintLog "ghcide-completions-1"-      ] ++ GhcIde.descriptors ghcideLog+  mkPluginTestDescriptor Refactor.iePluginDescriptor "ghcide-code-actions-imports-exports"+      <> mkPluginTestDescriptor Refactor.typeSigsPluginDescriptor "ghcide-code-actions-type-signatures"+      <> mkPluginTestDescriptor Refactor.bindingsPluginDescriptor "ghcide-code-actions-bindings"+      <> mkPluginTestDescriptor Refactor.fillHolePluginDescriptor "ghcide-code-actions-fill-holes"+      <> mkPluginTestDescriptor Refactor.extendImportPluginDescriptor "ghcide-completions-1" + tests :: TestTree tests =   testGroup "refactor"@@ -646,7 +642,7 @@         [ "func :: _"         , "func x = x"         ]-        [ "func :: p -> p"+        [ if ghcVersion >= GHC910 then "func :: t -> t" else "func :: p -> p"         , "func x = x"         ]   , testUseTypeSignature "local signature"@@ -666,9 +662,12 @@         [ "func :: _"         , "func x y = x + y"         ]-        [ if ghcVersion >= GHC98-          then "func :: a -> a -> a" -- since 9.8 GHC no longer does type defaulting (see https://gitlab.haskell.org/ghc/ghc/-/issues/24522)-          else "func :: Integer -> Integer -> Integer"+        [ if ghcVersion >= GHC910 then+              "func :: t -> t -> t"+          else if ghcVersion >= GHC98 then+              "func :: a -> a -> a" -- since 9.8 GHC no longer does type defaulting (see https://gitlab.haskell.org/ghc/ghc/-/issues/24522)+          else+              "func :: Integer -> Integer -> Integer"         , "func x y = x + y"         ]   , testUseTypeSignature "type in parentheses"@@ -696,9 +695,12 @@         [ "func::_"         , "func x y = x + y"         ]-        [ if ghcVersion >= GHC98-          then "func::a -> a -> a" -- since 9.8 GHC no longer does type defaulting (see https://gitlab.haskell.org/ghc/ghc/-/issues/24522)-          else "func::Integer -> Integer -> Integer"+        [ if ghcVersion >= GHC910 then+              "func::t -> t -> t"+          else if ghcVersion >= GHC98 then+              "func::a -> a -> a" -- since 9.8 GHC no longer does type defaulting (see https://gitlab.haskell.org/ghc/ghc/-/issues/24522)+          else+               "func::Integer -> Integer -> Integer"         , "func x y = x + y"         ]   , testGroup "add parens if hole is part of bigger type"@@ -1008,6 +1010,76 @@             , "x = a -- Must use something from module A, but not (@.)"             ]       liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "remove redundant record field import" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "data A = A {"+            , "  a1 :: String,"+            , "  a2 :: Int"+            , "}"+            , "newA = A \"foo\" 42"+            ]+      _docA <- createDoc "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA"+            , "  ( A (a1, a2),"+            , "    newA"+            , "  )"+            , "x = a1 newA"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      action <- pickActionWithTitle "Remove A(a2) from import" =<< getCodeActions docB (R 2 0 5 3)+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA"+            , "  ( A (a1),"+            , "    newA"+            , "  )"+            , "x = a1 newA"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "remove multiple redundant record field imports" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "data A = A {"+            , "  a1 :: String,"+            , "  a2 :: Int,"+            , "  a3 :: Int,"+            , "  a4 :: Int"+            , "}"+            , "newA = A \"foo\" 2 3 4"+            ]+      _docA <- createDoc "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA"+            , "  ( A (a1, a2, a3, a4),"+            , "    newA"+            , "  )"+            , "x = a2 newA"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      action <- pickActionWithTitle "Remove A(a1), A(a3), A(a4) from import" =<< getCodeActions docB (R 2 0 5 3)+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA"+            , "  ( A (a2),"+            , "    newA"+            , "  )"+            , "x = a2 newA"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction   ]  extendImportTests :: TestTree@@ -2644,29 +2716,29 @@   , testSession "postfix hole uses postfix notation of infix operator" $ do       let mkDoc x = T.unlines               [ "module Testing where"-              , "test :: Int -> Int -> Int"-              , "test a1 a2 = " <> x <> " a1 a2"+              , "test :: Int -> Maybe Int -> Maybe Int"+              , "test a ma = " <> x <> " (a +) ma"               ]       doc <- createDoc "Test.hs" "haskell" $ mkDoc "_"       _ <- waitForDiagnostics       actions <- getCodeActions doc (Range (Position 2 13) (Position 2 14))-      chosen <- pickActionWithTitle "replace _ with (+)" actions+      chosen <- pickActionWithTitle "replace _ with (<$>)" actions       executeCodeAction chosen       modifiedCode <- documentContents doc-      liftIO $ mkDoc "(+)" @=? modifiedCode+      liftIO $ mkDoc "(<$>)" @=? modifiedCode   , testSession "filling infix type hole uses infix operator" $ do       let mkDoc x = T.unlines               [ "module Testing where"-              , "test :: Int -> Int -> Int"-              , "test a1 a2 = a1 " <> x <> " a2"+              , "test :: Int -> Maybe Int -> Maybe Int"+              , "test a ma = (a +) " <> x <> " ma"               ]       doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`"       _ <- waitForDiagnostics       actions <- getCodeActions doc (Range (Position 2 16) (Position 2 19))-      chosen <- pickActionWithTitle "replace _ with (+)" actions+      chosen <- pickActionWithTitle "replace _ with (<$>)" actions       executeCodeAction chosen       modifiedCode <- documentContents doc-      liftIO $ mkDoc "+" @=? modifiedCode+      liftIO $ mkDoc "<$>" @=? modifiedCode   ]  addInstanceConstraintTests :: TestTree@@ -3116,6 +3188,7 @@     , "(!!!) a b = a > b"       >:: "(!!!) :: Ord a => a -> a -> Bool"     , "a >>>> b = a + b"        >:: "(>>>>) :: Num a => a -> a -> a"     , "a `haha` b = a b"        >:: "haha :: (t1 -> t2) -> t1 -> t2"+    , "hello = print"           >:: "hello :: GHC.Types.Any -> IO ()" -- Documents current behavior outlined in #806     , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a"     , "pattern Some a <- Just a" >:: "pattern Some :: a -> Maybe a"     , "pattern Some a <- Just a\n  where Some a = Just a" >:: "pattern Some :: a -> Maybe a"@@ -3755,12 +3828,15 @@ run' s = withTempDir $ \dir -> runInDir dir (s dir)  runInDir :: FilePath -> Session a -> IO a-runInDir dir act = do-  plugin <- refactorPlugin-  runSessionWithServer' plugin def def lspTestCaps dir act+runInDir dir act =+    runSessionWithTestConfig def+        { testDirLocation = Left dir+        , testPluginDescriptor = refactorPlugin+        , testConfigCaps = lspTestCaps }+        $ const act  lspTestCaps :: ClientCapabilities-lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing }+lspTestCaps = fullLatestClientCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing }  pattern R :: UInt -> UInt -> UInt -> UInt -> Range pattern R x y x' y' = Range (Position x y) (Position x' y')
plugins/hls-refactor-plugin/test/Test/AddArgument.hs view
@@ -34,7 +34,9 @@       mkGoldenAddArgTest "AddArgWithSigAndDocs" (r 8 0 8 50),       mkGoldenAddArgTest "AddArgFromLet" (r 2 0 2 50),       mkGoldenAddArgTest "AddArgFromWhere" (r 3 0 3 50),-      mkGoldenAddArgTest "AddArgFromWhereComments" (r 3 0 3 50),+      -- TODO can we make this work for GHC 9.10?+      knownBrokenForGhcVersions [GHC910] "In GHC 9.10 end-of-line comment annotation is in different place" $+          mkGoldenAddArgTest "AddArgFromWhereComments" (r 3 0 3 50),       mkGoldenAddArgTest "AddArgWithTypeSynSig" (r 2 0 2 50),       mkGoldenAddArgTest "AddArgWithTypeSynSigContravariant" (r 2 0 2 50),       mkGoldenAddArgTest "AddArgWithLambda" (r 1 0 1 50),
plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs view
@@ -25,7 +25,6 @@ import qualified Data.Map                              as M import           Data.Maybe import           Data.Mod.Word-import           Data.Row import qualified Data.Set                              as S import qualified Data.Text                             as T import           Development.IDE                       (Recorder, WithPriority,@@ -50,7 +49,6 @@ import qualified Language.LSP.Protocol.Lens            as L import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types-import           Language.LSP.Server  instance Hashable (Mod a) where hash n = hash (unMod n) @@ -77,7 +75,7 @@     -- In particular it allows some cases through (e.g. cross-module renames),     -- so that the full rename handler can give more informative error about them.     let renameValid = not $ null namesUnderCursor-    pure $ InL $ PrepareRenameResult $ InR $ InR $ #defaultBehavior .== renameValid+    pure $ InL $ PrepareRenameResult $ InR $ InR $ PrepareRenameDefaultBehavior renameValid  renameProvider :: PluginMethodHandler IdeState Method_TextDocumentRename renameProvider state pluginId (RenameParams _prog (TextDocumentIdentifier uri) pos newNameText) = do@@ -111,19 +109,18 @@             let newName = mkTcOcc $ T.unpack newNameText                 filesRefs = collectWith locToUri refs                 getFileEdit (uri, locations) = do-                    verTxtDocId <- lift $ getVersionedTextDoc (TextDocumentIdentifier uri)+                    verTxtDocId <- lift $ pluginGetVersionedTextDoc (TextDocumentIdentifier uri)                     getSrcEdit state verTxtDocId (replaceRefs newName locations)             fileEdits <- mapM getFileEdit filesRefs             pure $ InL $ fold fileEdits  -- | Limit renaming across modules. failWhenImportOrExport ::-    (MonadLsp config m) =>     IdeState ->     NormalizedFilePath ->     HashSet Location ->     [Name] ->-    ExceptT PluginError m ()+    ExceptT PluginError (HandlerM config) () failWhenImportOrExport state nfp refLocs names = do     pm <- runActionE "Rename.GetParsedModule" state          (useE GetParsedModule nfp)@@ -141,17 +138,16 @@  -- | Apply a function to a `ParsedSource` for a given `Uri` to compute a `WorkspaceEdit`. getSrcEdit ::-    (MonadLsp config m) =>     IdeState ->     VersionedTextDocumentIdentifier ->     (ParsedSource -> ParsedSource) ->-    ExceptT PluginError m WorkspaceEdit+    ExceptT PluginError (HandlerM config) WorkspaceEdit getSrcEdit state verTxtDocId updatePs = do-    ccs <- lift getClientCapabilities+    ccs <- lift pluginGetClientCapabilities     nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri)     annAst <- runActionE "Rename.GetAnnotatedParsedSource" state         (useE GetAnnotatedParsedSource nfp)-    let ps = astA annAst+    let ps = annAst         src = T.pack $ exactPrint ps         res = T.pack $ exactPrint (updatePs ps)     pure $ diffText ccs (verTxtDocId, src) res IncludeDeletions
plugins/hls-rename-plugin/test/Main.hs view
@@ -1,12 +1,12 @@-{-# LANGUAGE OverloadedLabels  #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds                #-}+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE OverloadedStrings        #-}  module Main (main) where  import           Control.Lens               ((^.)) import           Data.Aeson import qualified Data.Map                   as M-import           Data.Row                   ((.+), (.==)) import           Data.Text                  (Text, pack) import           Ide.Plugin.Config import qualified Ide.Plugin.Rename          as Rename@@ -70,7 +70,7 @@     , goldenWithRename "Type variable" "TypeVariable" $ \doc ->         rename doc (Position 0 13) "b"     , goldenWithRename "Rename within comment" "Comment" $ \doc -> do-        let expectedError = ResponseError+        let expectedError = TResponseError                 (InR ErrorCodes_InvalidParams)                 "rename: Invalid Params: No symbol to rename at given position"                 Nothing@@ -81,9 +81,11 @@         expectNoMoreDiagnostics 3 doc "typecheck"          -- Update the document so it doesn't compile-        let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 2 13) (Position 2 17)-                                                         .+ #rangeLength .== Nothing-                                                         .+ #text .== "A"+        let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial+              { _range = Range (Position 2 13) (Position 2 17)+              , _rangeLength = Nothing+              , _text = "A"+              }         changeDoc doc [change]         diags@(tcDiag : _) <- waitForDiagnosticsFrom doc @@ -101,9 +103,11 @@           renameErr ^. L.message @?= "rename: Rule Failed: GetHieAst"          -- Update the document so it compiles-        let change' = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 2 13) (Position 2 14)-                                                          .+ #rangeLength .== Nothing-                                                          .+ #text .== "Int"+        let change' = TextDocumentContentChangeEvent $  InL TextDocumentContentChangePartial+              { _range = Range (Position 2 13) (Position 2 14)+              , _rangeLength = Nothing+              , _text = "Int"+              }         changeDoc doc [change']         expectNoMoreDiagnostics 3 doc "typecheck" @@ -116,7 +120,7 @@     goldenWithHaskellDoc (def { plugins = M.fromList [("rename", def { plcConfig = "crossModule" .= True })] })        renamePlugin title testDataDir path "expected" "hs" act -renameExpectError :: ResponseError -> TextDocumentIdentifier -> Position -> Text -> Session ()+renameExpectError :: (TResponseError Method_TextDocumentRename) -> TextDocumentIdentifier -> Position -> Text -> Session () renameExpectError expectedError doc pos newName = do   let params = RenameParams Nothing doc pos newName   rsp <- request SMethod_TextDocumentRename params@@ -132,7 +136,7 @@   TextDocumentIdentifier ->   Position ->   String ->-  Session ResponseError+  Session (TResponseError Method_TextDocumentRename) expectRenameError doc pos newName = do   let params = RenameParams Nothing doc pos (pack newName)   rsp <- request SMethod_TextDocumentRename params@@ -143,4 +147,8 @@  runRenameSession :: FilePath -> Session a -> IO a runRenameSession subdir = failIfSessionTimeout-  . runSessionWithServerAndCaps def renamePlugin codeActionNoResolveCaps (testDataDir </> subdir)+  .  runSessionWithTestConfig def+  { testDirLocation = Left $ testDataDir </> subdir+  , testPluginDescriptor = renamePlugin+  , testConfigCaps = codeActionNoResolveCaps }+  . const
plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs view
@@ -98,10 +98,7 @@ import qualified Language.LSP.Protocol.Lens           as L import           Language.LSP.Protocol.Message        as LSP import           Language.LSP.Protocol.Types          as LSP-import           Language.LSP.Server                  (ProgressCancellable (Cancellable),-                                                       sendNotification,-                                                       sendRequest,-                                                       withIndefiniteProgress)+import           Language.LSP.Server                  (ProgressCancellable (Cancellable)) import           Retrie                               (Annotated (astA),                                                        AnnotatedModule,                                                        Fixity (Fixity),@@ -129,7 +126,6 @@                                                        listify, mkQ) import           Retrie.Types import           Retrie.Universe                      (Universe)-import           System.Directory                     (makeAbsolute)  #if MIN_VERSION_ghc(9,3,0) import           GHC.Types.PkgQual@@ -175,7 +171,7 @@  runRetrieCmd :: Recorder (WithPriority Log) ->  CommandFunction IdeState RunRetrieParams runRetrieCmd recorder state token RunRetrieParams{originatingFile = uri, ..} = ExceptT $-  withIndefiniteProgress description token Cancellable $ \_updater -> do+  pluginWithIndefiniteProgress description token Cancellable $ \_updater -> do     _ <- runExceptT $ do         nfp <- getNormalizedFilePathE uri         (session, _) <-@@ -193,12 +189,12 @@                 nfp                 restrictToOriginatingFile         unless (null errors) $-            lift $ sendNotification SMethod_WindowShowMessage $+            lift $ pluginSendNotification SMethod_WindowShowMessage $                     ShowMessageParams MessageType_Warning $                     T.unlines $                         "## Found errors during rewrite:" :                         ["-" <> T.pack (show e) | e <- errors]-        _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (\_ -> pure ())+        _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (\_ -> pure ())         return ()     return $ Right $ InR Null @@ -223,7 +219,7 @@         useE GetAnnotatedParsedSource nfpSource     let fromRange = rangeToRealSrcSpan nfpSource $ getLocationRange inlineFromThisLocation         intoRange = rangeToRealSrcSpan nfp $ getLocationRange inlineIntoThisLocation-    inlineRewrite <- liftIO $ constructInlineFromIdentifer astSrc fromRange+    inlineRewrite <- liftIO $ constructInlineFromIdentifer (unsafeMkA astSrc 0) fromRange     when (null inlineRewrite) $ throwError $ PluginInternalError "Empty rewrite"     (session, _) <- runActionE "retrie" state $       useWithStaleE GhcSessionDeps nfp@@ -239,7 +235,7 @@                 ourReplacement = [ r                     | r@Replacement{..} <- replacements                     , RealSrcSpan intoRange Nothing `GHC.isSubspanOf` replLocation]-            _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit+            _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit                 (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())             return $ InR Null @@ -349,7 +345,11 @@   -- so that we can include adding the required imports in the retrie command   let rn = tmrRenamed tm   case rn of+#if MIN_VERSION_ghc(9,9,0)+    (HsGroup{hs_valds, hs_ruleds, hs_tyclds}, _, _, _, _) -> do+#else     (HsGroup{hs_valds, hs_ruleds, hs_tyclds}, _, _, _) -> do+#endif       topLevelBinds <- case hs_valds of         ValBinds{} -> throwError $ PluginInternalError "getBinds: ValBinds not supported"         XValBindsLR (GHC.NValBinds binds _sigs :: GHC.NHsValBindsLR GhcRn) ->@@ -744,7 +744,12 @@ #if MIN_VERSION_ghc(9,5,0)     ideclImportList = Nothing     ideclExt = GHCGHC.XImportDeclPass-      { ideclAnn = GHCGHC.EpAnnNotUsed+      { ideclAnn =+#if MIN_VERSION_ghc(9,9,0)+        GHCGHC.noAnn+#else+        GHCGHC.EpAnnNotUsed+#endif       , ideclSourceText = ideclSourceSrc       , ideclImplicit = ideclImplicit       }@@ -762,7 +767,8 @@  getCPPmodule :: Recorder (WithPriority Log) -> IdeState -> HscEnv -> FilePath -> IO (FixityEnv, CPP AnnotatedModule) getCPPmodule recorder state session t = do-    nt <- toNormalizedFilePath' <$> makeAbsolute t+    -- TODO: is it safe to drop this makeAbsolute?+    let nt = toNormalizedFilePath' $ (toAbsolute $ rootDir state) t     let getParsedModule f contents = do           modSummary <- msrModSummary <$>             useOrFail state "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary nt
plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs view
@@ -1,58 +1,38 @@-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE OverloadedLabels  #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds                #-}+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE OverloadedStrings        #-}  import           Control.Lens                       ((^.), (^?))-import           Control.Monad.IO.Class             (liftIO) import           Data.Aeson                         (KeyValue (..), Object) import qualified Data.Aeson.KeyMap                  as KV import           Data.Default import           Data.Functor                       (void)+import qualified Data.List                          as T import           Data.Map.Strict                    as Map hiding (map) import           Data.String                        (fromString) import           Data.Text                          hiding (length, map,                                                      unlines) import qualified Data.Text                          as Text import qualified Data.Text.Utf16.Rope.Mixed         as Rope+import           Data.Version                       (Version (..)) import           Development.IDE                    (Pretty)--import           Data.Row                           ((.==))-import           Data.Row.Records                   ((.+))-import           Development.IDE.GHC.Compat         (GhcVersion (..),-                                                     ghcVersion) import           Development.IDE.Plugin.Test        (WaitForIdeRuleResult (..))-import           Development.IDE.Test               (waitForBuildQueue) import           Ide.Plugin.SemanticTokens import           Ide.Plugin.SemanticTokens.Mappings import           Ide.Plugin.SemanticTokens.Types import           Ide.Types import qualified Language.LSP.Protocol.Lens         as L import           Language.LSP.Protocol.Types-import           Language.LSP.Test                  (Session,-                                                     SessionConfig (ignoreConfigurationRequests),-                                                     openDoc, request) import qualified Language.LSP.Test                  as Test import           Language.LSP.VFS                   (VirtualFile (..)) import           System.FilePath-import           Test.Hls                           (HasCallStack,-                                                     PluginTestDescriptor,-                                                     SMethod (SMethod_TextDocumentSemanticTokensFullDelta),-                                                     TestName, TestTree,-                                                     changeDoc,-                                                     defaultTestRunner,-                                                     documentContents, fullCaps,-                                                     goldenGitDiff,-                                                     mkPluginTestDescriptor,-                                                     pluginTestRecorder,-                                                     runSessionWithServerInTmpDir,-                                                     runSessionWithServerInTmpDir',-                                                     testCase, testGroup,-                                                     waitForAction, (@?=))+import           System.Info                        (compilerVersion)+import           Test.Hls import qualified Test.Hls.FileSystem                as FS import           Test.Hls.FileSystem                (file, text)  testDataDir :: FilePath-testDataDir = "plugins" </> "hls-semantic-tokens-plugin" </> "test" </> "testdata"+testDataDir = "plugins" </> "hls-semantic-tokens-plugin" </> "test" </> "testdata" </> testVersionDir  mkFs :: [FS.FileTree] -> FS.VirtualFileTree mkFs = FS.mkVirtualFileTree testDataDir@@ -72,14 +52,24 @@                   }             } -goldenWithHaskellAndCapsOutPut :: Pretty b => Config -> PluginTestDescriptor b -> TestName -> FS.VirtualFileTree -> FilePath -> String -> (TextDocumentIdentifier -> Session String) -> TestTree+-- if 9_10 and after we change the directory to the testdata/before_9_10 directory+-- if 9_10 and after we change the directory to the testdata/after_9_10 directory++testVersionDir :: FilePath+testVersionDir+      | compilerVersion >= Version [9, 10] [] = "after_9_10"+      | otherwise = "before_9_10"++goldenWithHaskellAndCapsOutPut :: (Pretty b) => Config -> PluginTestDescriptor b -> TestName -> FS.VirtualFileTree -> FilePath -> String -> (TextDocumentIdentifier -> Session String) -> TestTree goldenWithHaskellAndCapsOutPut config plugin title tree path desc act =   goldenGitDiff title (FS.vftOriginalRoot tree </> path <.> desc) $-    runSessionWithServerInTmpDir config plugin tree $-      fromString <$> do-        doc <- openDoc (path <.> "hs") "haskell"-        void waitForBuildQueue-        act doc+    fromString+      <$> ( runSessionWithServerInTmpDir config plugin tree $+              do+                doc <- openDoc (path <.> "hs") "haskell"+                void waitForBuildQueue+                act doc+          )  goldenWithSemanticTokensWithDefaultConfig :: TestName -> FilePath -> TestTree goldenWithSemanticTokensWithDefaultConfig title path =@@ -92,9 +82,9 @@     "expected"     (docSemanticTokensString def) -docSemanticTokensString :: SemanticTokensConfig-> TextDocumentIdentifier -> Session String+docSemanticTokensString :: SemanticTokensConfig -> TextDocumentIdentifier -> Session String docSemanticTokensString cf doc = do-  xs  <- map (lspTokenHsToken cf) <$> docLspSemanticTokensString doc+  xs <- map (lspTokenHsToken cf) <$> docLspSemanticTokensString doc   return $ unlines . map show $ xs  docLspSemanticTokensString :: (HasCallStack) => TextDocumentIdentifier -> Session [SemanticTokenOriginal Language.LSP.Protocol.Types.SemanticTokenTypes]@@ -107,7 +97,6 @@       either (error . show) pure $ recoverLspSemanticTokens vfs tokens     _noTokens -> error "No tokens found" - -- | Pass a param and return the response from `semanticTokensFull` -- getSemanticTokensFullDelta :: TextDocumentIdentifier -> Session _ getSemanticTokensFullDelta :: TextDocumentIdentifier -> Text -> Session (SemanticTokens |? (SemanticTokensDelta |? Null))@@ -118,7 +107,6 @@     Right x -> return x     _       -> error "No tokens found" - semanticTokensClassTests :: TestTree semanticTokensClassTests =   testGroup@@ -139,44 +127,50 @@     ]  mkSemanticConfig :: Object -> Config-mkSemanticConfig setting = def{plugins = Map.insert "SemanticTokens" conf (plugins def)}-    where-      conf = def{plcConfig = setting }--+mkSemanticConfig setting = def {plugins = Map.insert "SemanticTokens" conf (plugins def)}+  where+    conf = def {plcConfig = setting}  directFile :: FilePath -> Text -> [FS.FileTree] directFile fp content =-  [ FS.directCradle [Text.pack fp]-  , file fp (text content)+  [ FS.directCradle [Text.pack fp],+    file fp (text content)   ]  semanticTokensConfigTest :: TestTree-semanticTokensConfigTest = testGroup "semantic token config test" [-        testCase "function to variable" $ do-            let content = Text.unlines ["module Hello where", "go _ = 1"]-            let fs = mkFs $ directFile "Hello.hs" content-            let funcVar = KV.fromList ["functionToken" .= var]-                var :: String-                var = "variable"-            do-                recorder <- pluginTestRecorder-                Test.Hls.runSessionWithServerInTmpDir' (semanticTokensPlugin recorder)-                    (mkSemanticConfig funcVar)-                    def {ignoreConfigurationRequests = False}-                    fullCaps-                    fs $ do-                    -- modifySemantic funcVar-                    void waitForBuildQueue-                    doc <- openDoc "Hello.hs" "haskell"-                    void waitForBuildQueue-                    result1 <- docLspSemanticTokensString doc-                    liftIO $ unlines (map show result1) @?= "2:1-3 SemanticTokenTypes_Variable \"go\"\n"+semanticTokensConfigTest =+  testGroup+    "semantic token config test"+    [ testCase "function to variable" $ do+        let content = Text.unlines ["module Hello where", "go _ = 1"]+        let fs = mkFs $ directFile "Hello.hs" content+        let funcVar = KV.fromList ["functionToken" .= var]+            var :: String+            var = "variable"+        Test.Hls.runSessionWithTestConfig def+          { testPluginDescriptor = semanticTokensPlugin+          , testConfigSession = def+            { ignoreConfigurationRequests = False+            }+          , testConfigCaps = fullLatestClientCaps+          , testDirLocation = Right fs+          , testLspConfig = mkSemanticConfig funcVar+          }+        $ const $ do+            -- modifySemantic funcVar+            void waitForBuildQueue+            doc <- openDoc "Hello.hs" "haskell"+            void waitForBuildQueue+            result1 <- docLspSemanticTokensString doc+            liftIO $ unlines (map show result1) @?=+                T.unlines (["1:8-13 SemanticTokenTypes_Namespace \"Hello\"" | compilerVersion >= Version [9, 10] []]+                        ++ ["2:1-3 SemanticTokenTypes_Variable \"go\""])     ] + semanticTokensFullDeltaTests :: TestTree semanticTokensFullDeltaTests =-  testGroup "semanticTokensFullDeltaTests" $+  testGroup "semanticTokensFullDeltaTests"     [ testCase "null delta since unchanged" $ do         let file1 = "TModuleA.hs"         let expectDelta = InR (InL (SemanticTokensDelta (Just "1") []))@@ -185,11 +179,12 @@           _ <- waitForAction "TypeCheck" doc1           _ <- Test.getSemanticTokens doc1           delta <- getSemanticTokensFullDelta doc1 "0"-          liftIO $ delta @?= expectDelta--      , testCase "add tokens" $ do+          liftIO $ delta @?= expectDelta,+      testCase "add tokens" $ do         let file1 = "TModuleA.hs"-        let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 20 0 (Just [2,0,3,8,0])]))+        let expectDelta+                | compilerVersion >= Version [9, 10] [] = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 25 0 (Just [2, 0, 3, 8, 0])]))+                | otherwise = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 20 0 (Just [2, 0, 3, 8, 0])]))         --                                                                                         r c l t m         --                                      where r = row, c = column, l = length, t = token, m = modifier         Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do@@ -197,28 +192,31 @@           _ <- waitForAction "TypeCheck" doc1           _ <- Test.getSemanticTokens doc1           -- open the file and append a line to it-          let change = TextDocumentContentChangeEvent-                $ InL $ #range .== Range (Position 4 0) (Position 4 6)-                .+ #rangeLength .== Nothing-                .+ #text .== "foo = 1"+          let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial+                { _range = Range (Position 4 0) (Position 4 6)+                , _rangeLength = Nothing+                , _text = "foo = 1"+                }           changeDoc doc1 [change]           _ <- waitForAction "TypeCheck" doc1           delta <- getSemanticTokensFullDelta doc1 "0"-          liftIO $ delta @?= expectDelta--      , testCase "remove tokens" $ do+          liftIO $ delta @?= expectDelta,+      testCase "remove tokens" $ do         let file1 = "TModuleA.hs"-        let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 0 20 (Just [])]))+        let expectDelta+                | compilerVersion >= Version [9, 10] [] = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 5 20 (Just [])]))+                | otherwise = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 0 20 (Just [])]))         -- delete all tokens         Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do           doc1 <- openDoc file1 "haskell"           _ <- waitForAction "TypeCheck" doc1           _ <- Test.getSemanticTokens doc1           -- open the file and append a line to it-          let change = TextDocumentContentChangeEvent-                $ InL $ #range .== Range (Position 2 0) (Position 2 28)-                .+ #rangeLength .== Nothing-                .+ #text .== Text.replicate 28 " "+          let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial+                { _range = Range (Position 2 0) (Position 2 28)+                , _rangeLength = Nothing+                , _text = Text.replicate 28 " "+                }           changeDoc doc1 [change]           _ <- waitForAction "TypeCheck" doc1           delta <- getSemanticTokensFullDelta doc1 "0"@@ -244,16 +242,22 @@             Left _                         -> error "TypeCheck2 failed"            result <- docSemanticTokensString def doc2-          let expect = unlines [-                    "3:8-16 TModule \"TModuleA\""-                    , "4:18-26 TModule \"TModuleA\""-                    , "6:1-3 TVariable \"go\""-                    , "6:6-10 TDataConstructor \"Game\""-                    , "8:1-5 TVariable \"a\\66560bb\""-                    , "8:8-17 TModule \"TModuleA.\""-                    , "8:17-20 TRecordField \"a\\66560b\""-                    , "8:21-23 TVariable \"go\""-                ]+          let expect =+                unlines+                  (+                    -- > 9.10 have module name in the token+                    (["1:8-16 TModule \"TModuleB\"" | compilerVersion >= Version [9, 10] []])+                      +++                    [+                    "3:8-16 TModule \"TModuleA\"",+                    "4:18-26 TModule \"TModuleA\"",+                    "6:1-3 TVariable \"go\"",+                    "6:6-10 TDataConstructor \"Game\"",+                    "8:1-5 TVariable \"a\\66560bb\"",+                    "8:8-17 TModule \"TModuleA.\"",+                    "8:17-20 TRecordField \"a\\66560b\"",+                    "8:21-23 TVariable \"go\""+                  ])           liftIO $ result @?= expect,       goldenWithSemanticTokensWithDefaultConfig "mixed constancy test result generated from one ghc version" "T1",       goldenWithSemanticTokensWithDefaultConfig "pattern bind" "TPatternSynonym",@@ -262,7 +266,7 @@       goldenWithSemanticTokensWithDefaultConfig "TQualifiedName" "TQualifiedName"     ]       -- not supported in ghc92-    ++ [goldenWithSemanticTokensWithDefaultConfig "TDoc" "TDoc" | ghcVersion > GHC92]+      ++ [goldenWithSemanticTokensWithDefaultConfig "TDoc" "TDoc" | ghcVersion > GHC92]  semanticTokensDataTypeTests :: TestTree semanticTokensDataTypeTests =
− plugins/hls-semantic-tokens-plugin/test/testdata/T1.expected 
@@ -1,81 +0,0 @@-9:6-9 TTypeConstructor "Foo"-9:12-15 TDataConstructor "Foo"-9:18-21 TRecordField "foo"-9:25-28 TTypeConstructor "Int"-11:7-10 TClass "Boo"-11:11-12 TTypeVariable "a"-12:3-6 TClassMethod "boo"-12:10-11 TTypeVariable "a"-12:15-16 TTypeVariable "a"-14:10-13 TClass "Boo"-14:14-17 TTypeConstructor "Int"-15:5-8 TClassMethod "boo"-15:9-10 TVariable "x"-15:13-14 TVariable "x"-15:15-16 TOperator "+"-17:6-8 TTypeConstructor "Dd"-17:11-13 TDataConstructor "Dd"-17:14-17 TTypeConstructor "Int"-19:9-12 TPatternSynonym "One"-19:15-18 TDataConstructor "Foo"-21:1-4 TVariable "ggg"-21:7-10 TPatternSynonym "One"-23:6-9 TTypeConstructor "Doo"-23:12-15 TDataConstructor "Doo"-23:16-24 TModule "Prelude."-23:24-27 TTypeConstructor "Int"-24:6-10 TTypeSynonym "Bar1"-24:13-16 TTypeConstructor "Int"-25:6-10 TTypeSynonym "Bar2"-25:13-16 TTypeConstructor "Doo"-27:1-3 TFunction "bb"-27:8-11 TClass "Boo"-27:12-13 TTypeVariable "a"-27:18-19 TTypeVariable "a"-27:23-24 TTypeVariable "a"-28:1-3 TFunction "bb"-28:4-5 TVariable "x"-28:9-12 TClassMethod "boo"-28:13-14 TVariable "x"-29:1-3 TFunction "aa"-29:7-11 TTypeVariable "cool"-29:15-18 TTypeConstructor "Int"-29:22-26 TTypeVariable "cool"-30:1-3 TFunction "aa"-30:4-5 TVariable "x"-30:9-10 TVariable "c"-30:14-16 TFunction "aa"-30:17-18 TVariable "x"-30:19-20 TVariable "c"-31:12-14 TVariable "xx"-31:16-18 TVariable "yy"-32:11-13 TVariable "dd"-34:2-4 TVariable "zz"-34:6-8 TVariable "kk"-35:1-3 TFunction "cc"-35:7-10 TTypeConstructor "Foo"-35:15-18 TTypeConstructor "Int"-35:20-23 TTypeConstructor "Int"-35:28-31 TTypeConstructor "Int"-36:1-3 TFunction "cc"-36:4-5 TVariable "f"-36:7-9 TVariable "gg"-36:11-13 TVariable "vv"-37:10-12 TVariable "gg"-38:14-17 TRecordField "foo"-38:18-19 TOperator "$"-38:20-21 TVariable "f"-38:24-27 TRecordField "foo"-39:14-17 TRecordField "foo"-39:18-19 TOperator "$"-39:20-21 TVariable "f"-39:24-27 TRecordField "foo"-41:1-3 TFunction "go"-41:6-9 TRecordField "foo"-42:1-4 TFunction "add"-42:8-16 TModule "Prelude."-42:16-17 TOperator "+"-47:1-5 TVariable "main"-47:9-11 TTypeConstructor "IO"-48:1-5 TVariable "main"-48:8-16 TFunction "putStrLn"
− plugins/hls-semantic-tokens-plugin/test/testdata/T1.hs 
@@ -1,48 +0,0 @@--- patter syn-{-# LANGUAGE PatternSynonyms #-}--module Main where---- import Data.Set (Set, insert)---data Foo = Foo { foo :: Int }--class Boo a where-  boo :: a -> a--instance Boo Int where-    boo x = x + 1--data Dd = Dd Int--pattern One = Foo 1--ggg = One--data Doo = Doo Prelude.Int-type Bar1 = Int-type Bar2 = Doo--bb :: (Boo a) => a -> a-bb x  = boo x-aa :: cool -> Int -> cool-aa x = \c -> aa x c-    where (xx, yy) = (1, 2)-          dd = 1--(zz, kk) = (1, 2)-cc :: Foo -> (Int, Int) -> Int-cc f (gg, vv)=-    case gg of-        1 -> foo $ f { foo = 1 }-        2 -> foo $ f { foo = 1 }--go = foo-add = (Prelude.+)---- sub :: Int -> Int -> Int--- sub x y = add x y--main :: IO ()-main = putStrLn "Hello, Haskell!"
− plugins/hls-semantic-tokens-plugin/test/testdata/TClass.expected 
@@ -1,5 +0,0 @@-4:7-10 TClass "Foo"-4:11-12 TTypeVariable "a"-5:3-6 TClassMethod "foo"-5:10-11 TTypeVariable "a"-5:15-18 TTypeConstructor "Int"
− plugins/hls-semantic-tokens-plugin/test/testdata/TClass.hs 
@@ -1,6 +0,0 @@-module TClass where---class Foo a where-  foo :: a -> Int-
− plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.expected 
@@ -1,3 +0,0 @@-4:6-9 TTypeConstructor "Foo"-4:12-15 TDataConstructor "Foo"-4:26-30 TClass "Show"
− plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE StandaloneDeriving #-}-module TClassImportedDeriving where--- deriving method source span of Show occurrence-data Foo = Foo deriving (Show)---- standalone deriving method not in the same position--- deriving instance Eq Foo---- a :: Foo -> Foo -> Bool--- a = (==)
− plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.expected 
@@ -1,12 +0,0 @@-5:13-18 TTypeFamily "XList"-5:19-20 TTypeVariable "a"-8:15-20 TTypeFamily "XList"-8:21-25 TTypeConstructor "Char"-8:28-33 TDataConstructor "XCons"-8:35-39 TTypeConstructor "Char"-8:42-47 TTypeFamily "XList"-8:48-52 TTypeConstructor "Char"-8:56-60 TDataConstructor "XNil"-11:15-20 TTypeFamily "XList"-11:26-35 TDataConstructor "XListUnit"-11:37-40 TTypeConstructor "Int"
− plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.hs 
@@ -1,11 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-module TDatafamily where---- Declare a list-like data family-data family XList a---- Declare a list-like instance for Char-data instance XList Char = XCons !Char !(XList Char) | XNil---- Declare a number-like instance for ()-data instance XList () = XListUnit !Int
− plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.expected 
@@ -1,4 +0,0 @@-3:6-9 TTypeConstructor "Foo"-3:12-15 TDataConstructor "Foo"-3:16-19 TTypeConstructor "Int"-3:30-32 TClass "Eq"
− plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.hs 
@@ -1,3 +0,0 @@-module TDataType where--data Foo = Foo Int deriving (Eq)
− plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.expected 
@@ -1,5 +0,0 @@-3:8-17 TModule "System.IO"-5:1-3 TVariable "go"-5:7-9 TTypeConstructor "IO"-6:1-3 TVariable "go"-6:6-11 TFunction "print"
− plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.hs 
@@ -1,6 +0,0 @@-module TDatatypeImported where--import System.IO--go :: IO ()-go = print 1
− plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.expected 
@@ -1,5 +0,0 @@-4:5-10 TVariable "hello"-5:1-6 TVariable "hello"-5:10-13 TTypeConstructor "Int"-6:1-6 TVariable "hello"-6:9-15 TClassMethod "length"
− plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.hs 
@@ -1,9 +0,0 @@-module TDoc where---- |--- `hello`-hello :: Int-hello = length "Hello, Haskell!"---
− plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.expected 
@@ -1,11 +0,0 @@-3:1-2 TFunction "f"-3:13-14 TTypeVariable "a"-3:16-17 TTypeVariable "a"-3:21-22 TTypeVariable "a"-4:1-2 TFunction "f"-4:3-4 TVariable "x"-4:7-8 TVariable "x"-6:1-2 TVariable "x"-6:6-7 TTypeVariable "a"-7:1-2 TVariable "x"-7:5-14 TVariable "undefined"
− plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.hs 
@@ -1,7 +0,0 @@-module TFunction where--f :: forall a. a -> a-f x = x--x :: a-x = undefined
− plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.expected 
@@ -1,5 +0,0 @@-3:1-2 TVariable "y"-3:6-9 TTypeConstructor "Int"-4:1-2 TVariable "y"-4:9-10 TFunction "f"-4:11-12 TVariable "x"
− plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.hs 
@@ -1,4 +0,0 @@-module TFunctionLet where--y :: Int-y = let f x = 1 in 1
− plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.expected 
@@ -1,7 +0,0 @@-3:1-2 TFunction "f"-3:6-9 TTypeConstructor "Int"-3:13-16 TTypeConstructor "Int"-4:1-2 TFunction "f"-4:7-8 TFunction "g"-6:5-6 TFunction "g"-6:7-8 TVariable "x"
− plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.hs 
@@ -1,8 +0,0 @@-module TFunctionLocal where--f :: Int -> Int-f 1 = g 1-  where-    g x = 1--
− plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.expected 
@@ -1,17 +0,0 @@-3:6-8 TTypeSynonym "T1"-3:11-14 TTypeConstructor "Int"-3:18-21 TTypeConstructor "Int"-4:6-8 TTypeSynonym "T2"-4:18-19 TTypeVariable "a"-4:21-22 TTypeVariable "a"-4:26-27 TTypeVariable "a"-5:1-3 TFunction "f1"-5:7-9 TTypeSynonym "T1"-6:1-3 TFunction "f1"-6:4-5 TVariable "x"-6:8-9 TVariable "x"-7:1-3 TFunction "f2"-7:7-9 TTypeSynonym "T2"-8:1-3 TFunction "f2"-8:4-5 TVariable "x"-8:8-9 TVariable "x"
− plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.hs 
@@ -1,9 +0,0 @@-module TFunctionUnderTypeSynonym where--type T1 = Int -> Int-type T2 = forall a. a -> a-f1 :: T1-f1 x = x-f2 :: T2-f2 x = x-
− plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.expected 
@@ -1,13 +0,0 @@-5:6-9 TTypeConstructor "Lam"-6:3-7 TDataConstructor "Lift"-6:11-12 TTypeVariable "a"-6:36-39 TTypeConstructor "Lam"-6:40-41 TTypeVariable "a"-7:3-6 TDataConstructor "Lam"-7:12-15 TTypeConstructor "Lam"-7:16-17 TTypeVariable "a"-7:21-24 TTypeConstructor "Lam"-7:25-26 TTypeVariable "b"-7:36-39 TTypeConstructor "Lam"-7:41-42 TTypeVariable "a"-7:46-47 TTypeVariable "b"
− plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GADTs #-}-module TGADT where--data Lam :: * -> * where-  Lift :: a                     -> Lam a        -- ^ lifted value-  Lam  :: (Lam a -> Lam b)      -> Lam (a -> b) -- ^ lambda abstraction
− plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.expected 
@@ -1,7 +0,0 @@-4:6-9 TTypeConstructor "Foo"-4:12-15 TDataConstructor "Foo"-4:16-19 TTypeConstructor "Int"-5:10-14 TClass "Show"-5:15-18 TTypeConstructor "Foo"-6:5-9 TClassMethod "show"-6:12-21 TVariable "undefined"
− plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.hs 
@@ -1,6 +0,0 @@-module TInstanceClassMethodBind where---data Foo = Foo Int-instance Show Foo where-    show = undefined
− plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.expected 
@@ -1,2 +0,0 @@-4:1-3 TFunction "go"-4:8-12 TClassMethod "show"
− plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.hs 
@@ -1,5 +0,0 @@-module TInstanceClassMethodUse where---go  =  show-
− plugins/hls-semantic-tokens-plugin/test/testdata/TModuleA.hs 
@@ -1,5 +0,0 @@-module TModuleA where--data Game = Game {a𐐀b :: Int}--
− plugins/hls-semantic-tokens-plugin/test/testdata/TModuleB.hs 
@@ -1,8 +0,0 @@-module TModuleB where--import TModuleA-import qualified TModuleA--go = Game 1--a𐐀bb = TModuleA.a𐐀b go
− plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.expected 
@@ -1,6 +0,0 @@-3:1-2 TVariable "x"-3:7-9 TClass "Eq"-3:10-11 TTypeVariable "a"-3:16-17 TTypeVariable "a"-4:1-2 TVariable "x"-4:5-14 TVariable "undefined"
− plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.hs 
@@ -1,5 +0,0 @@-module TNoneFunctionWithConstraint where--x :: (Eq a) => a-x = undefined-
− plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.expected 
@@ -1,33 +0,0 @@-4:1-3 TFunction "go"-4:4-5 TFunction "f"-4:6-7 TVariable "x"-4:10-11 TFunction "f"-4:11-12 TOperator "$"-4:12-13 TVariable "x"-6:2-6 TOperator "$$$$"-7:1-2 TVariable "x"-7:7-11 TOperator "$$$$"-8:6-7 TTypeVariable "a"-8:8-11 TOperator ":+:"-8:12-13 TTypeVariable "b"-8:16-19 TDataConstructor "Add"-8:20-21 TTypeVariable "a"-8:22-23 TTypeVariable "b"-9:7-10 TOperator ":-:"-9:12-13 TTypeVariable "a"-9:14-15 TTypeVariable "b"-9:19-20 TTypeVariable "a"-9:22-23 TTypeVariable "b"-11:1-4 TFunction "add"-11:8-11 TTypeConstructor "Int"-11:12-15 TOperator ":+:"-11:16-19 TTypeConstructor "Int"-11:23-26 TTypeConstructor "Int"-11:27-30 TOperator ":-:"-11:31-34 TTypeConstructor "Int"-13:1-4 TFunction "add"-13:6-9 TDataConstructor "Add"-13:10-11 TVariable "x"-13:12-13 TVariable "y"-13:18-19 TVariable "x"-13:21-22 TVariable "y"
− plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.hs 
@@ -1,13 +0,0 @@-module TOperator where---- imported operator-go f x = f$x--- operator defined in local module-($$$$) = b-x = 1 $$$$ 2-data a :+: b = Add a b-type (:-:) a b = (a, b)--- type take precedence over operator-add :: Int :+: Int -> Int :-: Int--- class method take precedence over operator-add (Add x y) = (x, y)
− plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.expected 
@@ -1,2 +0,0 @@-4:1-2 TFunction "g"-4:4-11 TDataConstructor "Nothing"
− plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.hs 
@@ -1,6 +0,0 @@-module TPatternMatch where---g (Nothing, _) = 1--
− plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.expected 
@@ -1,1 +0,0 @@-5:9-12 TPatternSynonym "Foo"
− plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-module TPatternSynonym where---pattern Foo = 1--
− plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.expected 
@@ -1,7 +0,0 @@-3:2-3 TVariable "a"-3:5-6 TVariable "b"-5:1-2 TFunction "f"-5:3-4 TFunction "g"-5:5-6 TVariable "y"-5:9-10 TFunction "g"-5:11-12 TVariable "y"
− plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.hs 
@@ -1,9 +0,0 @@-module TVariable where--(a, b) = (1, 2)--f g y = g y----
− plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.expected 
@@ -1,12 +0,0 @@-3:18-27 TModule "Data.List"-6:1-2 TVariable "a"-6:5-13 TModule "Prelude."-6:13-22 TVariable "undefined"-7:1-2 TVariable "b"-7:8-18 TModule "Data.List."-7:18-22 TClassMethod "elem"-8:1-2 TVariable "c"-8:6-14 TModule "Prelude."-8:14-15 TOperator "+"-9:1-2 TVariable "d"-9:6-7 TOperator "+"
− plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.hs 
@@ -1,9 +0,0 @@-module TQualifiedName where--import qualified Data.List---a = Prelude.undefined-b = 1 `Data.List.elem` [1, 2]-c = (Prelude.+) 1 1-d = (+) 1 1
− plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.expected 
@@ -1,4 +0,0 @@-4:6-9 TTypeConstructor "Foo"-4:12-15 TDataConstructor "Foo"-4:18-21 TRecordField "foo"-4:25-28 TTypeConstructor "Int"
− plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.hs 
@@ -1,7 +0,0 @@-module TRecord where---data Foo = Foo { foo :: Int }---
− plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.expected 
@@ -1,4 +0,0 @@-5:6-9 TTypeConstructor "Foo"-5:12-15 TDataConstructor "Foo"-5:18-21 TRecordField "boo"-5:26-32 TTypeSynonym "String"
− plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE DuplicateRecordFields      #-}--module TRecordDuplicateRecordFields where--data Foo = Foo { boo :: !String }
− plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.expected 
@@ -1,8 +0,0 @@-4:13-16 TTypeFamily "Foo"-4:17-18 TTypeVariable "a"-5:3-6 TTypeFamily "Foo"-5:7-10 TTypeConstructor "Int"-5:13-16 TTypeConstructor "Int"-6:3-6 TTypeFamily "Foo"-6:7-8 TTypeVariable "a"-6:11-17 TTypeSynonym "String"
− plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.hs 
@@ -1,6 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-module TTypefamily where--type family Foo a where-  Foo Int = Int-  Foo a = String
− plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.expected 
@@ -1,1 +0,0 @@-3:1-4 TVariable "a\66560b"
− plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.hs 
@@ -1,5 +0,0 @@-module TUnicodeSyntax where--a𐐀b = "a𐐀b"--
− plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.expected 
@@ -1,4 +0,0 @@-4:1-6 TVariable "hello"-4:10-13 TTypeConstructor "Int"-5:1-6 TVariable "hello"-5:9-15 TClassMethod "length"
− plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.hs 
@@ -1,8 +0,0 @@-module TValBind where---hello :: Int-hello = length "Hello, Haskell!"---
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/T1.expected view
@@ -0,0 +1,82 @@+4:8-12 TModule "Main"+9:6-9 TTypeConstructor "Foo"+9:12-15 TDataConstructor "Foo"+9:18-21 TRecordField "foo"+9:25-28 TTypeConstructor "Int"+11:7-10 TClass "Boo"+11:11-12 TTypeVariable "a"+12:3-6 TClassMethod "boo"+12:10-11 TTypeVariable "a"+12:15-16 TTypeVariable "a"+14:10-13 TClass "Boo"+14:14-17 TTypeConstructor "Int"+15:5-8 TClassMethod "boo"+15:9-10 TVariable "x"+15:13-14 TVariable "x"+15:15-16 TOperator "+"+17:6-8 TTypeConstructor "Dd"+17:11-13 TDataConstructor "Dd"+17:14-17 TTypeConstructor "Int"+19:9-12 TPatternSynonym "One"+19:15-18 TDataConstructor "Foo"+21:1-4 TVariable "ggg"+21:7-10 TPatternSynonym "One"+23:6-9 TTypeConstructor "Doo"+23:12-15 TDataConstructor "Doo"+23:16-24 TModule "Prelude."+23:24-27 TTypeConstructor "Int"+24:6-10 TTypeSynonym "Bar1"+24:13-16 TTypeConstructor "Int"+25:6-10 TTypeSynonym "Bar2"+25:13-16 TTypeConstructor "Doo"+27:1-3 TFunction "bb"+27:8-11 TClass "Boo"+27:12-13 TTypeVariable "a"+27:18-19 TTypeVariable "a"+27:23-24 TTypeVariable "a"+28:1-3 TFunction "bb"+28:4-5 TVariable "x"+28:9-12 TClassMethod "boo"+28:13-14 TVariable "x"+29:1-3 TFunction "aa"+29:7-11 TTypeVariable "cool"+29:15-18 TTypeConstructor "Int"+29:22-26 TTypeVariable "cool"+30:1-3 TFunction "aa"+30:4-5 TVariable "x"+30:9-10 TVariable "c"+30:14-16 TFunction "aa"+30:17-18 TVariable "x"+30:19-20 TVariable "c"+31:12-14 TVariable "xx"+31:16-18 TVariable "yy"+32:11-13 TVariable "dd"+34:2-4 TVariable "zz"+34:6-8 TVariable "kk"+35:1-3 TFunction "cc"+35:7-10 TTypeConstructor "Foo"+35:15-18 TTypeConstructor "Int"+35:20-23 TTypeConstructor "Int"+35:28-31 TTypeConstructor "Int"+36:1-3 TFunction "cc"+36:4-5 TVariable "f"+36:7-9 TVariable "gg"+36:11-13 TVariable "vv"+37:10-12 TVariable "gg"+38:14-17 TRecordField "foo"+38:18-19 TOperator "$"+38:20-21 TVariable "f"+38:24-27 TRecordField "foo"+39:14-17 TRecordField "foo"+39:18-19 TOperator "$"+39:20-21 TVariable "f"+39:24-27 TRecordField "foo"+41:1-3 TFunction "go"+41:6-9 TRecordField "foo"+42:1-4 TFunction "add"+42:8-16 TModule "Prelude."+42:16-17 TOperator "+"+47:1-5 TVariable "main"+47:9-11 TTypeConstructor "IO"+48:1-5 TVariable "main"+48:8-16 TFunction "putStrLn"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/T1.hs view
@@ -0,0 +1,48 @@+-- patter syn+{-# LANGUAGE PatternSynonyms #-}++module Main where++-- import Data.Set (Set, insert)+++data Foo = Foo { foo :: Int }++class Boo a where+  boo :: a -> a++instance Boo Int where+    boo x = x + 1++data Dd = Dd Int++pattern One = Foo 1++ggg = One++data Doo = Doo Prelude.Int+type Bar1 = Int+type Bar2 = Doo++bb :: (Boo a) => a -> a+bb x  = boo x+aa :: cool -> Int -> cool+aa x = \c -> aa x c+    where (xx, yy) = (1, 2)+          dd = 1++(zz, kk) = (1, 2)+cc :: Foo -> (Int, Int) -> Int+cc f (gg, vv)=+    case gg of+        1 -> foo $ f { foo = 1 }+        2 -> foo $ f { foo = 1 }++go = foo+add = (Prelude.+)++-- sub :: Int -> Int -> Int+-- sub x y = add x y++main :: IO ()+main = putStrLn "Hello, Haskell!"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClass.expected view
@@ -0,0 +1,6 @@+1:8-14 TModule "TClass"+4:7-10 TClass "Foo"+4:11-12 TTypeVariable "a"+5:3-6 TClassMethod "foo"+5:10-11 TTypeVariable "a"+5:15-18 TTypeConstructor "Int"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClass.hs view
@@ -0,0 +1,6 @@+module TClass where+++class Foo a where+  foo :: a -> Int+
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClassImportedDeriving.expected view
@@ -0,0 +1,4 @@+2:8-30 TModule "TClassImportedDeriving"+4:6-9 TTypeConstructor "Foo"+4:12-15 TDataConstructor "Foo"+4:26-30 TClass "Show"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClassImportedDeriving.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE StandaloneDeriving #-}+module TClassImportedDeriving where+-- deriving method source span of Show occurrence+data Foo = Foo deriving (Show)++-- standalone deriving method not in the same position+-- deriving instance Eq Foo++-- a :: Foo -> Foo -> Bool+-- a = (==)
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataFamily.expected view
@@ -0,0 +1,13 @@+2:8-19 TModule "TDatafamily"+5:13-18 TTypeFamily "XList"+5:19-20 TTypeVariable "a"+8:15-20 TTypeFamily "XList"+8:21-25 TTypeConstructor "Char"+8:28-33 TDataConstructor "XCons"+8:35-39 TTypeConstructor "Char"+8:42-47 TTypeFamily "XList"+8:48-52 TTypeConstructor "Char"+8:56-60 TDataConstructor "XNil"+11:15-20 TTypeFamily "XList"+11:26-35 TDataConstructor "XListUnit"+11:37-40 TTypeConstructor "Int"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataFamily.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TypeFamilies #-}+module TDatafamily where++-- Declare a list-like data family+data family XList a++-- Declare a list-like instance for Char+data instance XList Char = XCons !Char !(XList Char) | XNil++-- Declare a number-like instance for ()+data instance XList () = XListUnit !Int
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataType.expected view
@@ -0,0 +1,5 @@+1:8-17 TModule "TDataType"+3:6-9 TTypeConstructor "Foo"+3:12-15 TDataConstructor "Foo"+3:16-19 TTypeConstructor "Int"+3:30-32 TClass "Eq"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataType.hs view
@@ -0,0 +1,3 @@+module TDataType where++data Foo = Foo Int deriving (Eq)
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDatatypeImported.expected view
@@ -0,0 +1,6 @@+1:8-25 TModule "TDatatypeImported"+3:8-17 TModule "System.IO"+5:1-3 TVariable "go"+5:7-9 TTypeConstructor "IO"+6:1-3 TVariable "go"+6:6-11 TFunction "print"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDatatypeImported.hs view
@@ -0,0 +1,6 @@+module TDatatypeImported where++import System.IO++go :: IO ()+go = print 1
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDoc.expected view
@@ -0,0 +1,6 @@+1:8-12 TModule "TDoc"+4:5-10 TVariable "hello"+5:1-6 TVariable "hello"+5:10-13 TTypeConstructor "Int"+6:1-6 TVariable "hello"+6:9-15 TClassMethod "length"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDoc.hs view
@@ -0,0 +1,9 @@+module TDoc where++-- |+-- `hello`+hello :: Int+hello = length "Hello, Haskell!"+++
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunction.expected view
@@ -0,0 +1,12 @@+1:8-17 TModule "TFunction"+3:1-2 TFunction "f"+3:13-14 TTypeVariable "a"+3:16-17 TTypeVariable "a"+3:21-22 TTypeVariable "a"+4:1-2 TFunction "f"+4:3-4 TVariable "x"+4:7-8 TVariable "x"+6:1-2 TVariable "x"+6:6-7 TTypeVariable "a"+7:1-2 TVariable "x"+7:5-14 TVariable "undefined"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunction.hs view
@@ -0,0 +1,7 @@+module TFunction where++f :: forall a. a -> a+f x = x++x :: a+x = undefined
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLet.expected view
@@ -0,0 +1,6 @@+1:8-20 TModule "TFunctionLet"+3:1-2 TVariable "y"+3:6-9 TTypeConstructor "Int"+4:1-2 TVariable "y"+4:9-10 TFunction "f"+4:11-12 TVariable "x"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLet.hs view
@@ -0,0 +1,4 @@+module TFunctionLet where++y :: Int+y = let f x = 1 in 1
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLocal.expected view
@@ -0,0 +1,8 @@+1:8-22 TModule "TFunctionLocal"+3:1-2 TFunction "f"+3:6-9 TTypeConstructor "Int"+3:13-16 TTypeConstructor "Int"+4:1-2 TFunction "f"+4:7-8 TFunction "g"+6:5-6 TFunction "g"+6:7-8 TVariable "x"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLocal.hs view
@@ -0,0 +1,8 @@+module TFunctionLocal where++f :: Int -> Int+f 1 = g 1+  where+    g x = 1++
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionUnderTypeSynonym.expected view
@@ -0,0 +1,18 @@+1:8-33 TModule "TFunctionUnderTypeSynonym"+3:6-8 TTypeSynonym "T1"+3:11-14 TTypeConstructor "Int"+3:18-21 TTypeConstructor "Int"+4:6-8 TTypeSynonym "T2"+4:18-19 TTypeVariable "a"+4:21-22 TTypeVariable "a"+4:26-27 TTypeVariable "a"+5:1-3 TFunction "f1"+5:7-9 TTypeSynonym "T1"+6:1-3 TFunction "f1"+6:4-5 TVariable "x"+6:8-9 TVariable "x"+7:1-3 TFunction "f2"+7:7-9 TTypeSynonym "T2"+8:1-3 TFunction "f2"+8:4-5 TVariable "x"+8:8-9 TVariable "x"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionUnderTypeSynonym.hs view
@@ -0,0 +1,9 @@+module TFunctionUnderTypeSynonym where++type T1 = Int -> Int+type T2 = forall a. a -> a+f1 :: T1+f1 x = x+f2 :: T2+f2 x = x+
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TGADT.expected view
@@ -0,0 +1,14 @@+3:8-13 TModule "TGADT"+5:6-9 TTypeConstructor "Lam"+6:3-7 TDataConstructor "Lift"+6:11-12 TTypeVariable "a"+6:36-39 TTypeConstructor "Lam"+6:40-41 TTypeVariable "a"+7:3-6 TDataConstructor "Lam"+7:12-15 TTypeConstructor "Lam"+7:16-17 TTypeVariable "a"+7:21-24 TTypeConstructor "Lam"+7:25-26 TTypeVariable "b"+7:36-39 TTypeConstructor "Lam"+7:41-42 TTypeVariable "a"+7:46-47 TTypeVariable "b"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TGADT.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs #-}+module TGADT where++data Lam :: * -> * where+  Lift :: a                     -> Lam a        -- ^ lifted value+  Lam  :: (Lam a -> Lam b)      -> Lam (a -> b) -- ^ lambda abstraction
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodBind.expected view
@@ -0,0 +1,8 @@+1:8-32 TModule "TInstanceClassMethodBind"+4:6-9 TTypeConstructor "Foo"+4:12-15 TDataConstructor "Foo"+4:16-19 TTypeConstructor "Int"+5:10-14 TClass "Show"+5:15-18 TTypeConstructor "Foo"+6:5-9 TClassMethod "show"+6:12-21 TVariable "undefined"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodBind.hs view
@@ -0,0 +1,6 @@+module TInstanceClassMethodBind where+++data Foo = Foo Int+instance Show Foo where+    show = undefined
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodUse.expected view
@@ -0,0 +1,3 @@+1:8-31 TModule "TInstanceClassMethodUse"+4:1-3 TFunction "go"+4:8-12 TClassMethod "show"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodUse.hs view
@@ -0,0 +1,5 @@+module TInstanceClassMethodUse where+++go  =  show+
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TModuleA.hs view
@@ -0,0 +1,5 @@+module TModuleA where++data Game = Game {a𐐀b :: Int}++
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TModuleB.hs view
@@ -0,0 +1,8 @@+module TModuleB where++import TModuleA+import qualified TModuleA++go = Game 1++a𐐀bb = TModuleA.a𐐀b go
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TNoneFunctionWithConstraint.expected view
@@ -0,0 +1,7 @@+1:8-35 TModule "TNoneFunctionWithConstraint"+3:1-2 TVariable "x"+3:7-9 TClass "Eq"+3:10-11 TTypeVariable "a"+3:16-17 TTypeVariable "a"+4:1-2 TVariable "x"+4:5-14 TVariable "undefined"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TNoneFunctionWithConstraint.hs view
@@ -0,0 +1,5 @@+module TNoneFunctionWithConstraint where++x :: (Eq a) => a+x = undefined+
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TOperator.expected view
@@ -0,0 +1,34 @@+1:8-17 TModule "TOperator"+4:1-3 TFunction "go"+4:4-5 TFunction "f"+4:6-7 TVariable "x"+4:10-11 TFunction "f"+4:11-12 TOperator "$"+4:12-13 TVariable "x"+6:2-6 TOperator "$$$$"+7:1-2 TVariable "x"+7:7-11 TOperator "$$$$"+8:6-7 TTypeVariable "a"+8:8-11 TOperator ":+:"+8:12-13 TTypeVariable "b"+8:16-19 TDataConstructor "Add"+8:20-21 TTypeVariable "a"+8:22-23 TTypeVariable "b"+9:7-10 TOperator ":-:"+9:12-13 TTypeVariable "a"+9:14-15 TTypeVariable "b"+9:19-20 TTypeVariable "a"+9:22-23 TTypeVariable "b"+11:1-4 TFunction "add"+11:8-11 TTypeConstructor "Int"+11:12-15 TOperator ":+:"+11:16-19 TTypeConstructor "Int"+11:23-26 TTypeConstructor "Int"+11:27-30 TOperator ":-:"+11:31-34 TTypeConstructor "Int"+13:1-4 TFunction "add"+13:6-9 TDataConstructor "Add"+13:10-11 TVariable "x"+13:12-13 TVariable "y"+13:18-19 TVariable "x"+13:21-22 TVariable "y"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TOperator.hs view
@@ -0,0 +1,13 @@+module TOperator where++-- imported operator+go f x = f$x+-- operator defined in local module+($$$$) = b+x = 1 $$$$ 2+data a :+: b = Add a b+type (:-:) a b = (a, b)+-- type take precedence over operator+add :: Int :+: Int -> Int :-: Int+-- class method take precedence over operator+add (Add x y) = (x, y)
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternMatch.expected view
@@ -0,0 +1,3 @@+1:8-21 TModule "TPatternMatch"+4:1-2 TFunction "g"+4:4-11 TDataConstructor "Nothing"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternMatch.hs view
@@ -0,0 +1,6 @@+module TPatternMatch where+++g (Nothing, _) = 1++
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternSynonym.expected view
@@ -0,0 +1,2 @@+2:8-23 TModule "TPatternSynonym"+5:9-12 TPatternSynonym "Foo"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternSynonym.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PatternSynonyms #-}+module TPatternSynonym where+++pattern Foo = 1++
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternbind.expected view
@@ -0,0 +1,8 @@+1:8-17 TModule "TVariable"+3:2-3 TVariable "a"+3:5-6 TVariable "b"+5:1-2 TFunction "f"+5:3-4 TFunction "g"+5:5-6 TVariable "y"+5:9-10 TFunction "g"+5:11-12 TVariable "y"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternbind.hs view
@@ -0,0 +1,9 @@+module TVariable where++(a, b) = (1, 2)++f g y = g y++++
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TQualifiedName.expected view
@@ -0,0 +1,13 @@+1:8-22 TModule "TQualifiedName"+3:18-27 TModule "Data.List"+6:1-2 TVariable "a"+6:5-13 TModule "Prelude."+6:13-22 TVariable "undefined"+7:1-2 TVariable "b"+7:8-18 TModule "Data.List."+7:18-22 TClassMethod "elem"+8:1-2 TVariable "c"+8:6-14 TModule "Prelude."+8:14-15 TOperator "+"+9:1-2 TVariable "d"+9:6-7 TOperator "+"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TQualifiedName.hs view
@@ -0,0 +1,9 @@+module TQualifiedName where++import qualified Data.List+++a = Prelude.undefined+b = 1 `Data.List.elem` [1, 2]+c = (Prelude.+) 1 1+d = (+) 1 1
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecord.expected view
@@ -0,0 +1,5 @@+1:8-15 TModule "TRecord"+4:6-9 TTypeConstructor "Foo"+4:12-15 TDataConstructor "Foo"+4:18-21 TRecordField "foo"+4:25-28 TTypeConstructor "Int"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecord.hs view
@@ -0,0 +1,7 @@+module TRecord where+++data Foo = Foo { foo :: Int }+++
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecordDuplicateRecordFields.expected view
@@ -0,0 +1,5 @@+3:8-36 TModule "TRecordDuplicateRecordFields"+5:6-9 TTypeConstructor "Foo"+5:12-15 TDataConstructor "Foo"+5:18-21 TRecordField "boo"+5:26-32 TTypeSynonym "String"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecordDuplicateRecordFields.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE DuplicateRecordFields      #-}++module TRecordDuplicateRecordFields where++data Foo = Foo { boo :: !String }
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TTypefamily.expected view
@@ -0,0 +1,9 @@+2:8-19 TModule "TTypefamily"+4:13-16 TTypeFamily "Foo"+4:17-18 TTypeVariable "a"+5:3-6 TTypeFamily "Foo"+5:7-10 TTypeConstructor "Int"+5:13-16 TTypeConstructor "Int"+6:3-6 TTypeFamily "Foo"+6:7-8 TTypeVariable "a"+6:11-17 TTypeSynonym "String"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TTypefamily.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TypeFamilies #-}+module TTypefamily where++type family Foo a where+  Foo Int = Int+  Foo a = String
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TUnicodeSyntax.expected view
@@ -0,0 +1,2 @@+1:8-22 TModule "TUnicodeSyntax"+3:1-4 TVariable "a\66560b"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TUnicodeSyntax.hs view
@@ -0,0 +1,5 @@+module TUnicodeSyntax where++a𐐀b = "a𐐀b"++
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TValBind.expected view
@@ -0,0 +1,5 @@+1:8-16 TModule "TValBind"+4:1-6 TVariable "hello"+4:10-13 TTypeConstructor "Int"+5:1-6 TVariable "hello"+5:9-15 TClassMethod "length"
+ plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TValBind.hs view
@@ -0,0 +1,8 @@+module TValBind where+++hello :: Int+hello = length "Hello, Haskell!"+++
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/T1.expected view
@@ -0,0 +1,81 @@+9:6-9 TTypeConstructor "Foo"+9:12-15 TDataConstructor "Foo"+9:18-21 TRecordField "foo"+9:25-28 TTypeConstructor "Int"+11:7-10 TClass "Boo"+11:11-12 TTypeVariable "a"+12:3-6 TClassMethod "boo"+12:10-11 TTypeVariable "a"+12:15-16 TTypeVariable "a"+14:10-13 TClass "Boo"+14:14-17 TTypeConstructor "Int"+15:5-8 TClassMethod "boo"+15:9-10 TVariable "x"+15:13-14 TVariable "x"+15:15-16 TOperator "+"+17:6-8 TTypeConstructor "Dd"+17:11-13 TDataConstructor "Dd"+17:14-17 TTypeConstructor "Int"+19:9-12 TPatternSynonym "One"+19:15-18 TDataConstructor "Foo"+21:1-4 TVariable "ggg"+21:7-10 TPatternSynonym "One"+23:6-9 TTypeConstructor "Doo"+23:12-15 TDataConstructor "Doo"+23:16-24 TModule "Prelude."+23:24-27 TTypeConstructor "Int"+24:6-10 TTypeSynonym "Bar1"+24:13-16 TTypeConstructor "Int"+25:6-10 TTypeSynonym "Bar2"+25:13-16 TTypeConstructor "Doo"+27:1-3 TFunction "bb"+27:8-11 TClass "Boo"+27:12-13 TTypeVariable "a"+27:18-19 TTypeVariable "a"+27:23-24 TTypeVariable "a"+28:1-3 TFunction "bb"+28:4-5 TVariable "x"+28:9-12 TClassMethod "boo"+28:13-14 TVariable "x"+29:1-3 TFunction "aa"+29:7-11 TTypeVariable "cool"+29:15-18 TTypeConstructor "Int"+29:22-26 TTypeVariable "cool"+30:1-3 TFunction "aa"+30:4-5 TVariable "x"+30:9-10 TVariable "c"+30:14-16 TFunction "aa"+30:17-18 TVariable "x"+30:19-20 TVariable "c"+31:12-14 TVariable "xx"+31:16-18 TVariable "yy"+32:11-13 TVariable "dd"+34:2-4 TVariable "zz"+34:6-8 TVariable "kk"+35:1-3 TFunction "cc"+35:7-10 TTypeConstructor "Foo"+35:15-18 TTypeConstructor "Int"+35:20-23 TTypeConstructor "Int"+35:28-31 TTypeConstructor "Int"+36:1-3 TFunction "cc"+36:4-5 TVariable "f"+36:7-9 TVariable "gg"+36:11-13 TVariable "vv"+37:10-12 TVariable "gg"+38:14-17 TRecordField "foo"+38:18-19 TOperator "$"+38:20-21 TVariable "f"+38:24-27 TRecordField "foo"+39:14-17 TRecordField "foo"+39:18-19 TOperator "$"+39:20-21 TVariable "f"+39:24-27 TRecordField "foo"+41:1-3 TFunction "go"+41:6-9 TRecordField "foo"+42:1-4 TFunction "add"+42:8-16 TModule "Prelude."+42:16-17 TOperator "+"+47:1-5 TVariable "main"+47:9-11 TTypeConstructor "IO"+48:1-5 TVariable "main"+48:8-16 TFunction "putStrLn"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/T1.hs view
@@ -0,0 +1,48 @@+-- patter syn+{-# LANGUAGE PatternSynonyms #-}++module Main where++-- import Data.Set (Set, insert)+++data Foo = Foo { foo :: Int }++class Boo a where+  boo :: a -> a++instance Boo Int where+    boo x = x + 1++data Dd = Dd Int++pattern One = Foo 1++ggg = One++data Doo = Doo Prelude.Int+type Bar1 = Int+type Bar2 = Doo++bb :: (Boo a) => a -> a+bb x  = boo x+aa :: cool -> Int -> cool+aa x = \c -> aa x c+    where (xx, yy) = (1, 2)+          dd = 1++(zz, kk) = (1, 2)+cc :: Foo -> (Int, Int) -> Int+cc f (gg, vv)=+    case gg of+        1 -> foo $ f { foo = 1 }+        2 -> foo $ f { foo = 1 }++go = foo+add = (Prelude.+)++-- sub :: Int -> Int -> Int+-- sub x y = add x y++main :: IO ()+main = putStrLn "Hello, Haskell!"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClass.expected view
@@ -0,0 +1,5 @@+4:7-10 TClass "Foo"+4:11-12 TTypeVariable "a"+5:3-6 TClassMethod "foo"+5:10-11 TTypeVariable "a"+5:15-18 TTypeConstructor "Int"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClass.hs view
@@ -0,0 +1,6 @@+module TClass where+++class Foo a where+  foo :: a -> Int+
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClassImportedDeriving.expected view
@@ -0,0 +1,3 @@+4:6-9 TTypeConstructor "Foo"+4:12-15 TDataConstructor "Foo"+4:26-30 TClass "Show"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClassImportedDeriving.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE StandaloneDeriving #-}+module TClassImportedDeriving where+-- deriving method source span of Show occurrence+data Foo = Foo deriving (Show)++-- standalone deriving method not in the same position+-- deriving instance Eq Foo++-- a :: Foo -> Foo -> Bool+-- a = (==)
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataFamily.expected view
@@ -0,0 +1,12 @@+5:13-18 TTypeFamily "XList"+5:19-20 TTypeVariable "a"+8:15-20 TTypeFamily "XList"+8:21-25 TTypeConstructor "Char"+8:28-33 TDataConstructor "XCons"+8:35-39 TTypeConstructor "Char"+8:42-47 TTypeFamily "XList"+8:48-52 TTypeConstructor "Char"+8:56-60 TDataConstructor "XNil"+11:15-20 TTypeFamily "XList"+11:26-35 TDataConstructor "XListUnit"+11:37-40 TTypeConstructor "Int"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataFamily.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TypeFamilies #-}+module TDatafamily where++-- Declare a list-like data family+data family XList a++-- Declare a list-like instance for Char+data instance XList Char = XCons !Char !(XList Char) | XNil++-- Declare a number-like instance for ()+data instance XList () = XListUnit !Int
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataType.expected view
@@ -0,0 +1,4 @@+3:6-9 TTypeConstructor "Foo"+3:12-15 TDataConstructor "Foo"+3:16-19 TTypeConstructor "Int"+3:30-32 TClass "Eq"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataType.hs view
@@ -0,0 +1,3 @@+module TDataType where++data Foo = Foo Int deriving (Eq)
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDatatypeImported.expected view
@@ -0,0 +1,5 @@+3:8-17 TModule "System.IO"+5:1-3 TVariable "go"+5:7-9 TTypeConstructor "IO"+6:1-3 TVariable "go"+6:6-11 TFunction "print"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDatatypeImported.hs view
@@ -0,0 +1,6 @@+module TDatatypeImported where++import System.IO++go :: IO ()+go = print 1
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDoc.expected view
@@ -0,0 +1,5 @@+4:5-10 TVariable "hello"+5:1-6 TVariable "hello"+5:10-13 TTypeConstructor "Int"+6:1-6 TVariable "hello"+6:9-15 TClassMethod "length"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDoc.hs view
@@ -0,0 +1,9 @@+module TDoc where++-- |+-- `hello`+hello :: Int+hello = length "Hello, Haskell!"+++
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunction.expected view
@@ -0,0 +1,11 @@+3:1-2 TFunction "f"+3:13-14 TTypeVariable "a"+3:16-17 TTypeVariable "a"+3:21-22 TTypeVariable "a"+4:1-2 TFunction "f"+4:3-4 TVariable "x"+4:7-8 TVariable "x"+6:1-2 TVariable "x"+6:6-7 TTypeVariable "a"+7:1-2 TVariable "x"+7:5-14 TVariable "undefined"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunction.hs view
@@ -0,0 +1,7 @@+module TFunction where++f :: forall a. a -> a+f x = x++x :: a+x = undefined
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLet.expected view
@@ -0,0 +1,5 @@+3:1-2 TVariable "y"+3:6-9 TTypeConstructor "Int"+4:1-2 TVariable "y"+4:9-10 TFunction "f"+4:11-12 TVariable "x"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLet.hs view
@@ -0,0 +1,4 @@+module TFunctionLet where++y :: Int+y = let f x = 1 in 1
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLocal.expected view
@@ -0,0 +1,7 @@+3:1-2 TFunction "f"+3:6-9 TTypeConstructor "Int"+3:13-16 TTypeConstructor "Int"+4:1-2 TFunction "f"+4:7-8 TFunction "g"+6:5-6 TFunction "g"+6:7-8 TVariable "x"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLocal.hs view
@@ -0,0 +1,8 @@+module TFunctionLocal where++f :: Int -> Int+f 1 = g 1+  where+    g x = 1++
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionUnderTypeSynonym.expected view
@@ -0,0 +1,17 @@+3:6-8 TTypeSynonym "T1"+3:11-14 TTypeConstructor "Int"+3:18-21 TTypeConstructor "Int"+4:6-8 TTypeSynonym "T2"+4:18-19 TTypeVariable "a"+4:21-22 TTypeVariable "a"+4:26-27 TTypeVariable "a"+5:1-3 TFunction "f1"+5:7-9 TTypeSynonym "T1"+6:1-3 TFunction "f1"+6:4-5 TVariable "x"+6:8-9 TVariable "x"+7:1-3 TFunction "f2"+7:7-9 TTypeSynonym "T2"+8:1-3 TFunction "f2"+8:4-5 TVariable "x"+8:8-9 TVariable "x"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionUnderTypeSynonym.hs view
@@ -0,0 +1,9 @@+module TFunctionUnderTypeSynonym where++type T1 = Int -> Int+type T2 = forall a. a -> a+f1 :: T1+f1 x = x+f2 :: T2+f2 x = x+
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TGADT.expected view
@@ -0,0 +1,13 @@+5:6-9 TTypeConstructor "Lam"+6:3-7 TDataConstructor "Lift"+6:11-12 TTypeVariable "a"+6:36-39 TTypeConstructor "Lam"+6:40-41 TTypeVariable "a"+7:3-6 TDataConstructor "Lam"+7:12-15 TTypeConstructor "Lam"+7:16-17 TTypeVariable "a"+7:21-24 TTypeConstructor "Lam"+7:25-26 TTypeVariable "b"+7:36-39 TTypeConstructor "Lam"+7:41-42 TTypeVariable "a"+7:46-47 TTypeVariable "b"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TGADT.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs #-}+module TGADT where++data Lam :: * -> * where+  Lift :: a                     -> Lam a        -- ^ lifted value+  Lam  :: (Lam a -> Lam b)      -> Lam (a -> b) -- ^ lambda abstraction
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodBind.expected view
@@ -0,0 +1,7 @@+4:6-9 TTypeConstructor "Foo"+4:12-15 TDataConstructor "Foo"+4:16-19 TTypeConstructor "Int"+5:10-14 TClass "Show"+5:15-18 TTypeConstructor "Foo"+6:5-9 TClassMethod "show"+6:12-21 TVariable "undefined"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodBind.hs view
@@ -0,0 +1,6 @@+module TInstanceClassMethodBind where+++data Foo = Foo Int+instance Show Foo where+    show = undefined
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodUse.expected view
@@ -0,0 +1,2 @@+4:1-3 TFunction "go"+4:8-12 TClassMethod "show"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodUse.hs view
@@ -0,0 +1,5 @@+module TInstanceClassMethodUse where+++go  =  show+
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TModuleA.hs view
@@ -0,0 +1,5 @@+module TModuleA where++data Game = Game {a𐐀b :: Int}++
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TModuleB.hs view
@@ -0,0 +1,8 @@+module TModuleB where++import TModuleA+import qualified TModuleA++go = Game 1++a𐐀bb = TModuleA.a𐐀b go
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TNoneFunctionWithConstraint.expected view
@@ -0,0 +1,6 @@+3:1-2 TVariable "x"+3:7-9 TClass "Eq"+3:10-11 TTypeVariable "a"+3:16-17 TTypeVariable "a"+4:1-2 TVariable "x"+4:5-14 TVariable "undefined"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TNoneFunctionWithConstraint.hs view
@@ -0,0 +1,5 @@+module TNoneFunctionWithConstraint where++x :: (Eq a) => a+x = undefined+
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TOperator.expected view
@@ -0,0 +1,33 @@+4:1-3 TFunction "go"+4:4-5 TFunction "f"+4:6-7 TVariable "x"+4:10-11 TFunction "f"+4:11-12 TOperator "$"+4:12-13 TVariable "x"+6:2-6 TOperator "$$$$"+7:1-2 TVariable "x"+7:7-11 TOperator "$$$$"+8:6-7 TTypeVariable "a"+8:8-11 TOperator ":+:"+8:12-13 TTypeVariable "b"+8:16-19 TDataConstructor "Add"+8:20-21 TTypeVariable "a"+8:22-23 TTypeVariable "b"+9:7-10 TOperator ":-:"+9:12-13 TTypeVariable "a"+9:14-15 TTypeVariable "b"+9:19-20 TTypeVariable "a"+9:22-23 TTypeVariable "b"+11:1-4 TFunction "add"+11:8-11 TTypeConstructor "Int"+11:12-15 TOperator ":+:"+11:16-19 TTypeConstructor "Int"+11:23-26 TTypeConstructor "Int"+11:27-30 TOperator ":-:"+11:31-34 TTypeConstructor "Int"+13:1-4 TFunction "add"+13:6-9 TDataConstructor "Add"+13:10-11 TVariable "x"+13:12-13 TVariable "y"+13:18-19 TVariable "x"+13:21-22 TVariable "y"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TOperator.hs view
@@ -0,0 +1,13 @@+module TOperator where++-- imported operator+go f x = f$x+-- operator defined in local module+($$$$) = b+x = 1 $$$$ 2+data a :+: b = Add a b+type (:-:) a b = (a, b)+-- type take precedence over operator+add :: Int :+: Int -> Int :-: Int+-- class method take precedence over operator+add (Add x y) = (x, y)
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternMatch.expected view
@@ -0,0 +1,2 @@+4:1-2 TFunction "g"+4:4-11 TDataConstructor "Nothing"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternMatch.hs view
@@ -0,0 +1,6 @@+module TPatternMatch where+++g (Nothing, _) = 1++
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternSynonym.expected view
@@ -0,0 +1,1 @@+5:9-12 TPatternSynonym "Foo"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternSynonym.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PatternSynonyms #-}+module TPatternSynonym where+++pattern Foo = 1++
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternbind.expected view
@@ -0,0 +1,7 @@+3:2-3 TVariable "a"+3:5-6 TVariable "b"+5:1-2 TFunction "f"+5:3-4 TFunction "g"+5:5-6 TVariable "y"+5:9-10 TFunction "g"+5:11-12 TVariable "y"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternbind.hs view
@@ -0,0 +1,9 @@+module TVariable where++(a, b) = (1, 2)++f g y = g y++++
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TQualifiedName.expected view
@@ -0,0 +1,12 @@+3:18-27 TModule "Data.List"+6:1-2 TVariable "a"+6:5-13 TModule "Prelude."+6:13-22 TVariable "undefined"+7:1-2 TVariable "b"+7:8-18 TModule "Data.List."+7:18-22 TClassMethod "elem"+8:1-2 TVariable "c"+8:6-14 TModule "Prelude."+8:14-15 TOperator "+"+9:1-2 TVariable "d"+9:6-7 TOperator "+"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TQualifiedName.hs view
@@ -0,0 +1,9 @@+module TQualifiedName where++import qualified Data.List+++a = Prelude.undefined+b = 1 `Data.List.elem` [1, 2]+c = (Prelude.+) 1 1+d = (+) 1 1
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecord.expected view
@@ -0,0 +1,4 @@+4:6-9 TTypeConstructor "Foo"+4:12-15 TDataConstructor "Foo"+4:18-21 TRecordField "foo"+4:25-28 TTypeConstructor "Int"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecord.hs view
@@ -0,0 +1,7 @@+module TRecord where+++data Foo = Foo { foo :: Int }+++
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecordDuplicateRecordFields.expected view
@@ -0,0 +1,4 @@+5:6-9 TTypeConstructor "Foo"+5:12-15 TDataConstructor "Foo"+5:18-21 TRecordField "boo"+5:26-32 TTypeSynonym "String"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecordDuplicateRecordFields.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE DuplicateRecordFields      #-}++module TRecordDuplicateRecordFields where++data Foo = Foo { boo :: !String }
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TTypefamily.expected view
@@ -0,0 +1,8 @@+4:13-16 TTypeFamily "Foo"+4:17-18 TTypeVariable "a"+5:3-6 TTypeFamily "Foo"+5:7-10 TTypeConstructor "Int"+5:13-16 TTypeConstructor "Int"+6:3-6 TTypeFamily "Foo"+6:7-8 TTypeVariable "a"+6:11-17 TTypeSynonym "String"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TTypefamily.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TypeFamilies #-}+module TTypefamily where++type family Foo a where+  Foo Int = Int+  Foo a = String
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TUnicodeSyntax.expected view
@@ -0,0 +1,1 @@+3:1-4 TVariable "a\66560b"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TUnicodeSyntax.hs view
@@ -0,0 +1,5 @@+module TUnicodeSyntax where++a𐐀b = "a𐐀b"++
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TValBind.expected view
@@ -0,0 +1,4 @@+4:1-6 TVariable "hello"+4:10-13 TTypeConstructor "Int"+5:1-6 TVariable "hello"+5:9-15 TClassMethod "length"
+ plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TValBind.hs view
@@ -0,0 +1,8 @@+module TValBind where+++hello :: Int+hello = length "Hello, Haskell!"+++
plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs view
@@ -5,70 +5,68 @@ {-# LANGUAGE LambdaCase            #-} {-# LANGUAGE MagicHash             #-} {-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PatternSynonyms       #-} {-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE ViewPatterns          #-}-{-# LANGUAGE PatternSynonyms       #-} -module Ide.Plugin.Splice-    ( descriptor,-    )-where+module Ide.Plugin.Splice (descriptor) where -import           Control.Applicative             (Alternative ((<|>)))-import           Control.Arrow                   ( Arrow(first) )-import           Control.Exception              ( SomeException )-import qualified Control.Foldl                   as L-import           Control.Lens                    (Identity (..), ix, view, (%~),-                                                  (<&>), (^.))-import           Control.Monad                   ( guard, unless, forM )-import           Control.Monad.Error.Class       ( MonadError(throwError) )-import           Control.Monad.Extra             (eitherM)-import qualified Control.Monad.Fail              as Fail-import           Control.Monad.IO.Unlift         ( MonadIO(..), askRunInIO )-import           Control.Monad.Trans.Class       ( MonadTrans(lift) )-import           Control.Monad.Trans.Except      ( ExceptT(..), runExceptT )+import           Control.Applicative                   (Alternative ((<|>)))+import           Control.Arrow                         (Arrow (first))+import           Control.Exception                     (SomeException)+import qualified Control.Foldl                         as L+import           Control.Lens                          (Identity (..), ix, view,+                                                        (%~), (<&>), (^.))+import           Control.Monad                         (forM, guard, unless)+import           Control.Monad.Error.Class             (MonadError (throwError))+import           Control.Monad.Extra                   (eitherM)+import qualified Control.Monad.Fail                    as Fail+import           Control.Monad.IO.Unlift               (MonadIO (..),+                                                        askRunInIO)+import           Control.Monad.Trans.Class             (MonadTrans (lift))+import           Control.Monad.Trans.Except            (ExceptT (..),+                                                        runExceptT) import           Control.Monad.Trans.Maybe-import           Data.Aeson                      hiding (Null)-import qualified Data.Bifunctor                  as B (first)-import           Data.Foldable                   (Foldable (foldl'))+import           Data.Aeson                            hiding (Null)+import qualified Data.Bifunctor                        as B (first) import           Data.Function import           Data.Generics-import qualified Data.Kind                       as Kinds-import           Data.List                       (sortOn)-import           Data.Maybe                      (fromMaybe, listToMaybe,-                                                  mapMaybe)-import qualified Data.Text                       as T+import qualified Data.Kind                             as Kinds+import           Data.List                             (sortOn)+import           Data.Maybe                            (fromMaybe, listToMaybe,+                                                        mapMaybe)+import qualified Data.Text                             as T import           Development.IDE import           Development.IDE.Core.PluginUtils-import           Development.IDE.GHC.Compat      as Compat hiding (getLoc)+import           Development.IDE.GHC.Compat            as Compat import           Development.IDE.GHC.Compat.ExactPrint-import qualified Development.IDE.GHC.Compat.Util as Util+import qualified Development.IDE.GHC.Compat.Util       as Util import           Development.IDE.GHC.ExactPrint-import           Language.Haskell.GHC.ExactPrint.Transform (TransformT(TransformT))--#if MIN_VERSION_ghc(9,4,1)--import           GHC.Data.Bag (Bag)+import           GHC.Exts+import qualified GHC.Types.Error                       as Error+import           Ide.Plugin.Error                      (PluginError (PluginInternalError))+import           Ide.Plugin.Splice.Types+import           Ide.Types+import qualified Language.LSP.Protocol.Lens            as J+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types +#if !MIN_VERSION_base(4,20,0)+import           Data.Foldable                         (Foldable (foldl')) #endif -import           GHC.Exts-+#if MIN_VERSION_ghc(9,4,1)+import           GHC.Data.Bag                          (Bag)+#endif -import           GHC.Parser.Annotation (SrcSpanAnn'(..))-import qualified GHC.Types.Error as Error+#if MIN_VERSION_ghc(9,9,0)+import           GHC.Parser.Annotation                 (EpAnn (..))+#else+import           GHC.Parser.Annotation                 (SrcSpanAnn' (..))+#endif  -import           Ide.Plugin.Splice.Types-import           Ide.Types-import           Language.Haskell.GHC.ExactPrint (uniqueSrcSpanT)-import           Language.LSP.Server-import           Language.LSP.Protocol.Types-import           Language.LSP.Protocol.Message-import qualified Language.LSP.Protocol.Lens         as J-import Ide.Plugin.Error (PluginError(PluginInternalError))- descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId =     (defaultPluginDescriptor plId "Provides a code action to evaluate a TemplateHaskell splice")@@ -95,10 +93,10 @@     ExpandStyle ->     CommandFunction IdeState ExpandSpliceParams expandTHSplice _eStyle ideState _ params@ExpandSpliceParams {..} = ExceptT $ do-    clientCapabilities <- getClientCapabilities+    clientCapabilities <- pluginGetClientCapabilities     rio <- askRunInIO     let reportEditor :: ReportEditor-        reportEditor msgTy msgs = liftIO $ rio $ sendNotification SMethod_WindowShowMessage (ShowMessageParams msgTy (T.unlines msgs))+        reportEditor msgTy msgs = liftIO $ rio $ pluginSendNotification SMethod_WindowShowMessage (ShowMessageParams msgTy (T.unlines msgs))         expandManually :: NormalizedFilePath -> ExceptT PluginError IO WorkspaceEdit         expandManually fp = do             mresl <-@@ -195,7 +193,7 @@       Nothing -> pure $ Right $ InR Null       Just (Left err) -> pure $ Left $ err       Just (Right edit) -> do-        _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ())+        _ <- pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ())         pure $ Right $ InR Null      where@@ -207,7 +205,7 @@     :: IdeState     -> NormalizedFilePath     -> ParsedModule-    -> ExceptT PluginError IO (Annotated ParsedSource, HscEnv, DynFlags)+    -> ExceptT PluginError IO (ParsedSource, HscEnv, DynFlags) setupHscEnv ideState fp pm = do     hscEnvEq <- runActionE "expandTHSplice.fallback.ghcSessionDeps" ideState $                     useE GhcSessionDeps fp@@ -223,10 +221,10 @@         platform = targetPlatform dflags3         dflags3a = setWays hostFullWays dflags3         dflags3b =-            foldl gopt_set dflags3a $+            foldl' gopt_set dflags3a $                 concatMap (wayGeneralFlags platform) hostFullWays         dflags3c =-            foldl gopt_unset dflags3b $+            foldl' gopt_unset dflags3b $                 concatMap (wayUnsetGeneralFlags platform) hostFullWays         dflags4 =             dflags3c@@ -245,7 +243,7 @@             let minStart =                     case L.fold (L.premap (view J.range) L.minimum) eds of                         Nothing -> error "impossible"-                        Just v -> v+                        Just v  -> v             in adjustLine minStart <$> eds          adjustATextEdits :: Traversable f => f (TextEdit |? AnnotatedTextEdit) -> f (TextEdit |? AnnotatedTextEdit)@@ -273,8 +271,13 @@ -- `GenLocated`. In GHC >= 9.2 this will be a SrcSpanAnn', with annotations; -- earlier it will just be a plain `SrcSpan`. {-# COMPLETE AsSrcSpan #-}+#if MIN_VERSION_ghc(9,9,0)+pattern AsSrcSpan :: SrcSpan -> EpAnn ann+pattern AsSrcSpan locA <- (getLoc -> locA)+#else pattern AsSrcSpan :: SrcSpan -> SrcSpanAnn' a pattern AsSrcSpan locA <- SrcSpanAnn {locA}+#endif  findSubSpansDesc :: SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)] findSubSpansDesc srcSpan =@@ -305,7 +308,7 @@ #if MIN_VERSION_ghc(9,5,0)     type SpliceOf HsExpr = HsSpliceCompat     matchSplice _ (HsUntypedSplice _ spl) = Just (UntypedSplice spl)-    matchSplice _ (HsTypedSplice _ spl) = Just (TypedSplice spl)+    matchSplice _ (HsTypedSplice _ spl)   = Just (TypedSplice spl) #else     type SpliceOf HsExpr = HsSplice     matchSplice _ (HsSpliceE _ spl) = Just spl@@ -356,7 +359,7 @@     ClientCapabilities ->     ReportEditor ->     Range ->-    Annotated ParsedSource ->+    ParsedSource ->     HscEnv ->     TcGblEnv ->     RealSrcSpan ->@@ -394,7 +397,7 @@                                                             (fst <$> expandSplice astP spl)                                                     )                                         Just <$> case eExpr of-                                            Left x -> pure $ L _spn x+                                            Left x  -> pure $ L _spn x                                             Right y -> unRenamedE dflags y                                     _ -> pure Nothing             let (warns, errs) =@@ -471,7 +474,7 @@ -- TODO: Declaration Splices won't appear in HieAst; perhaps we must just use Parsed/Renamed ASTs? codeAction :: PluginMethodHandler IdeState Method_TextDocumentCodeAction codeAction state plId (CodeActionParams _ _ docId ran _) = do-    verTxtDocId <- lift $ getVersionedTextDoc docId+    verTxtDocId <- lift $ pluginGetVersionedTextDoc docId     liftIO $ fmap (fromMaybe ( InL [])) $         runMaybeT $ do             fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri@@ -506,12 +509,12 @@                         | spanIsRelevant l ->                             case expr of #if MIN_VERSION_ghc(9,5,0)-                                HsTypedSplice{} -> Here (spLoc, Expr)+                                HsTypedSplice{}   -> Here (spLoc, Expr)                                 HsUntypedSplice{} -> Here (spLoc, Expr) #else-                                HsSpliceE {} -> Here (spLoc, Expr)+                                HsSpliceE {}      -> Here (spLoc, Expr) #endif-                                _            -> Continue+                                _                 -> Continue                     _ -> Stop                 )                 `extQ` \case
plugins/hls-splice-plugin/test/Main.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE OverloadedLabels      #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE ViewPatterns          #-} module Main@@ -8,7 +7,6 @@  import           Control.Monad           (void) import           Data.List               (find)-import           Data.Row import           Data.Text               (Text) import qualified Data.Text               as T import qualified Data.Text.IO            as T@@ -89,13 +87,15 @@          { _start = Position 0 0          , _end = Position (fromIntegral $ length lns + 1) 1          }-     waitForAllProgressDone -- cradle-     waitForAllProgressDone-     alt <- liftIO $ T.readFile (fp <.> "error.hs")++     void waitForDiagnostics+     void waitForBuildQueue+     alt <- liftIO $ T.readFile (testDataDir </> fp <.> "error.hs")      void $ applyEdit doc $ TextEdit theRange alt-     changeDoc doc [TextDocumentContentChangeEvent $ InL $ #range .== theRange-                                                        .+ #rangeLength .== Nothing-                                                        .+ #text .== alt]+     changeDoc doc [TextDocumentContentChangeEvent $ InL+        TextDocumentContentChangePartial {_range = theRange, _rangeLength = Nothing, _text = alt}+        ]+      void waitForDiagnostics      -- wait for the entire build to finish      void waitForBuildQueue
plugins/hls-stan-plugin/test/Main.hs view
@@ -75,4 +75,11 @@  runStanSession :: FilePath -> Session a -> IO a runStanSession subdir =-  failIfSessionTimeout . runSessionWithServer def stanPlugin (testDir </> subdir)+  failIfSessionTimeout+  . runSessionWithTestConfig def{+    testConfigCaps=codeActionNoResolveCaps+    , testShiftRoot=True+    , testPluginDescriptor=stanPlugin+    , testDirLocation=Left (testDir </> subdir)+    }+  . const
src/Ide/Main.hs view
@@ -131,7 +131,7 @@         log Info $ LogLspStart ghcideArgs (map pluginId $ ipMap idePlugins)      let args = (if argsTesting then IDEMain.testing else IDEMain.defaultArguments)-                    (cmapWithPrio LogIDEMain recorder) idePlugins+                    (cmapWithPrio LogIDEMain recorder) dir idePlugins      let telemetryRecorder = telemetryRecorder' & cmapWithPrio pretty
test/functional/Config.hs view
@@ -68,8 +68,11 @@         testPluginDiagnostics = [("Foo.hs", [(DiagnosticSeverity_Error, (0,0), "testplugin")])]          runConfigSession subdir session = do-          recorder <- pluginTestRecorder-          failIfSessionTimeout $ runSessionWithServer' @() (plugin recorder) def (def {ignoreConfigurationRequests=False}) fullCaps ("test/testdata" </> subdir) session+          failIfSessionTimeout $+            runSessionWithTestConfig def+                { testConfigSession=def {ignoreConfigurationRequests=False}, testShiftRoot=True+                , testPluginDescriptor=plugin, testDirLocation=Left ("test/testdata" </> subdir) }+                (const session)          testPluginId = "testplugin"         -- A disabled-by-default plugin that creates diagnostics
test/functional/Format.hs view
@@ -23,18 +23,18 @@  providerTests :: TestTree providerTests = testGroup "lsp formatting provider"-    [ testCase "respects none" $ runSessionWithConfig (formatConfig "none") hlsLspCommand fullCaps "test/testdata/format" $ do+    [ testCase "respects none" $ runSessionWithConfig (formatConfig "none") hlsLspCommand fullLatestClientCaps "test/testdata/format" $ do         void configurationRequest         doc <- openDoc "Format.hs" "haskell"         resp <- request SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing)         liftIO $ case resp ^. L.result of-          result@(Left (ResponseError reason message Nothing)) -> case reason of+          result@(Left (TResponseError reason message Nothing)) -> case reason of             (InR ErrorCodes_MethodNotFound) -> pure () -- No formatter             (InR ErrorCodes_InvalidRequest) | "No plugin" `T.isPrefixOf` message -> pure ()             _ -> assertFailure $ "strange response from formatting provider:" ++ show result           result -> assertFailure $ "strange response from formatting provider:" ++ show result -    , requiresOrmoluPlugin . requiresFloskellPlugin $ testCase "can change on the fly" $ runSessionWithConfig (formatConfig "none") hlsLspCommand fullCaps "test/testdata/format" $ do+    , requiresOrmoluPlugin . requiresFloskellPlugin $ testCase "can change on the fly" $ runSessionWithConfig (formatConfig "none") hlsLspCommand fullLatestClientCaps "test/testdata/format" $ do         void configurationRequest         formattedOrmolu <- liftIO $ T.readFile "test/testdata/format/Format.ormolu.formatted.hs"         formattedFloskell <- liftIO $ T.readFile "test/testdata/format/Format.floskell.formatted.hs"
test/functional/FunctionalBadProject.hs view
@@ -12,13 +12,13 @@ tests :: TestTree tests = testGroup "behaviour on malformed projects"     [ testCase "Missing module diagnostic" $ do-        runSession hlsLspCommand fullCaps "test/testdata/missingModuleTest/missingModule/" $ do+        runSession hlsLspCommand fullLatestClientCaps "test/testdata/missingModuleTest/missingModule/" $ do             doc <- openDoc "src/MyLib.hs" "haskell"             [diag] <- waitForDiagnosticsFrom doc             liftIO $ assertBool "missing module name" $ "MyLib" `T.isInfixOf` (diag ^. L.message)             liftIO $ assertBool "module missing context" $ "may not be listed" `T.isInfixOf` (diag ^. L.message)     , testCase "Missing module diagnostic - no matching prefix" $ do-        runSession hlsLspCommand fullCaps "test/testdata/missingModuleTest/noPrefixMatch/" $ do+        runSession hlsLspCommand fullLatestClientCaps "test/testdata/missingModuleTest/noPrefixMatch/" $ do             doc <- openDoc "app/Other.hs" "haskell"             [diag] <- waitForDiagnosticsFrom doc             liftIO $ assertBool "missing module name" $
test/functional/HieBios.hs view
@@ -11,7 +11,7 @@ tests :: TestTree tests = testGroup "hie-bios"   [ testCase "loads main-is module" $ do-    runSession hlsLspCommand fullCaps "test/testdata/hieBiosMainIs" $ do+    runSession hlsLspCommand fullLatestClientCaps "test/testdata/hieBiosMainIs" $ do       _ <- openDoc "Main.hs" "haskell"       (diag:_) <- waitForDiagnostics       liftIO $ "Top-level binding with no type signature:" `T.isInfixOf` (diag ^. L.message)
test/functional/Progress.hs view
@@ -29,16 +29,17 @@             runSession hlsLspCommand progressCaps "test/testdata/diagnostics" $ do                 let path = "Foo.hs"                 _ <- openDoc path "haskell"-                expectProgressMessages [pack ("Setting up diagnostics (for " ++ path ++ ")"), "Processing", "Indexing"] []+                expectProgressMessages [pack ("Setting up diagnostics (for " ++ path ++ ")"), "Processing", "Indexing"] [] []         , requiresEvalPlugin $ testCase "eval plugin sends progress reports" $             runSession hlsLspCommand progressCaps "plugins/hls-eval-plugin/test/testdata" $ do-              doc <- openDoc "T1.hs" "haskell"+              doc <- openDoc "TIO.hs" "haskell"               lspId <- sendRequest SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) -              (codeLensResponse, activeProgressTokens) <- expectProgressMessagesTill+              (codeLensResponse, createdProgressTokens, activeProgressTokens) <- expectProgressMessagesTill                 (responseForId SMethod_TextDocumentCodeLens lspId)-                ["Setting up testdata (for T1.hs)", "Processing"]+                ["Setting up testdata (for TIO.hs)", "Processing"]                 []+                []                -- this is a test so exceptions result in fails               let response = getMessageResult codeLensResponse@@ -52,31 +53,31 @@                           (command ^. L.command)                           (decode $ encode $ fromJust $ command ^. L.arguments) -                      expectProgressMessages ["Evaluating"] activeProgressTokens+                      expectProgressMessages ["Evaluating"] createdProgressTokens activeProgressTokens                   _ -> error $ "Unexpected response result: " ++ show response         , requiresOrmoluPlugin $ testCase "ormolu plugin sends progress notifications" $ do             runSessionWithConfig (def { ignoreConfigurationRequests = False }) hlsLspCommand progressCaps "test/testdata/format" $ do                 void configurationRequest                 setHlsConfig (formatLspConfig "ormolu")                 doc <- openDoc "Format.hs" "haskell"-                expectProgressMessages ["Setting up format (for Format.hs)", "Processing", "Indexing"] []+                expectProgressMessages ["Setting up format (for Format.hs)", "Processing", "Indexing"] [] []                 _ <- sendRequest SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing)-                expectProgressMessages ["Formatting Format.hs"] []+                expectProgressMessages ["Formatting Format.hs"] [] []         , requiresFourmoluPlugin $ testCase "fourmolu plugin sends progress notifications" $ do             runSessionWithConfig (def { ignoreConfigurationRequests = False }) hlsLspCommand progressCaps "test/testdata/format" $ do                 void configurationRequest                 setHlsConfig (formatLspConfig "fourmolu")                 doc <- openDoc "Format.hs" "haskell"-                expectProgressMessages ["Setting up format (for Format.hs)", "Processing", "Indexing"] []+                expectProgressMessages ["Setting up format (for Format.hs)", "Processing", "Indexing"] [] []                 _ <- sendRequest SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing)-                expectProgressMessages ["Formatting Format.hs"] []+                expectProgressMessages ["Formatting Format.hs"] [] []         ]  formatLspConfig :: Text -> Config formatLspConfig provider = def { formattingProvider = provider }  progressCaps :: ClientCapabilities-progressCaps = fullCaps{_window = Just (WindowClientCapabilities (Just True) Nothing Nothing)}+progressCaps = fullLatestClientCaps{_window = Just (WindowClientCapabilities (Just True) Nothing Nothing)}  data ProgressMessage   = ProgressCreate WorkDoneProgressCreateParams@@ -113,57 +114,59 @@ interestingMessage theMessage =   fmap InterestingMessage theMessage <|> fmap ProgressMessage progressMessage -expectProgressMessagesTill :: Session a -> [Text] -> [ProgressToken] -> Session (a, [ProgressToken])-expectProgressMessagesTill stopMessage expectedTitles activeProgressTokens = do+expectProgressMessagesTill :: Session a -> [Text] -> [ProgressToken] -> [ProgressToken] -> Session (a, [ProgressToken], [ProgressToken])+expectProgressMessagesTill stopMessage expectedTitles createdProgressTokens activeProgressTokens = do   message <- skipManyTill anyMessage (interestingMessage stopMessage)   case message of     InterestingMessage a -> do       liftIO $ null expectedTitles @? "Expected titles not empty " <> show expectedTitles-      pure (a, activeProgressTokens)+      pure (a, createdProgressTokens, activeProgressTokens)     ProgressMessage progressMessage ->       updateExpectProgressStateAndRecurseWith         (expectProgressMessagesTill stopMessage)         progressMessage         expectedTitles+        createdProgressTokens         activeProgressTokens  {- | Test that the server is correctly producing a sequence of progress related- messages. Each create must be pair with a corresponding begin and end,+ messages. Creates can be dangling, but should be paired with a corresponding begin and end,  optionally with some progress in between. Tokens must match. The begin  messages have titles describing the work that is in-progress, we check that  the titles we see are those we expect. -}-expectProgressMessages :: [Text] -> [ProgressToken] -> Session ()-expectProgressMessages [] [] = pure ()-expectProgressMessages expectedTitles activeProgressTokens = do+expectProgressMessages :: [Text] -> [ProgressToken] -> [ProgressToken] -> Session ()+expectProgressMessages [] _ [] = pure ()+expectProgressMessages expectedTitles createdProgressTokens activeProgressTokens = do   message <- skipManyTill anyMessage progressMessage-  updateExpectProgressStateAndRecurseWith expectProgressMessages message expectedTitles activeProgressTokens+  updateExpectProgressStateAndRecurseWith expectProgressMessages message expectedTitles createdProgressTokens activeProgressTokens -updateExpectProgressStateAndRecurseWith :: ([Text] -> [ProgressToken] -> Session a)+updateExpectProgressStateAndRecurseWith :: ([Text] -> [ProgressToken] -> [ProgressToken] -> Session a)                                         -> ProgressMessage                                         -> [Text]                                         -> [ProgressToken]+                                        -> [ProgressToken]                                         -> Session a-updateExpectProgressStateAndRecurseWith f progressMessage expectedTitles activeProgressTokens = do+updateExpectProgressStateAndRecurseWith f progressMessage expectedTitles createdProgressTokens activeProgressTokens = do   case progressMessage of     ProgressCreate params -> do-      f expectedTitles ((params ^. L.token): activeProgressTokens)+      f expectedTitles ((params ^. L.token): createdProgressTokens) activeProgressTokens     ProgressBegin token params -> do-      liftIO $ token `expectedIn` activeProgressTokens-      f (delete (params ^. L.title) expectedTitles) activeProgressTokens+      liftIO $ token `expectedIn` createdProgressTokens+      f (delete (params ^. L.title) expectedTitles) (delete token createdProgressTokens) (token:activeProgressTokens)     ProgressReport token _ -> do       liftIO $ token `expectedIn` activeProgressTokens-      f expectedTitles activeProgressTokens+      f expectedTitles createdProgressTokens activeProgressTokens     ProgressEnd token _ -> do       liftIO $ token `expectedIn` activeProgressTokens-      f expectedTitles (delete token activeProgressTokens)+      f expectedTitles createdProgressTokens (delete token activeProgressTokens)   expectedIn :: (Foldable t, Eq a, Show a) => a -> t a -> Assertion expectedIn a as = a `elem` as @? "Unexpected " ++ show a -getMessageResult :: TResponseMessage m -> MessageResult m+getMessageResult :: Show (ErrorData m) => TResponseMessage m -> MessageResult m getMessageResult rsp =   case rsp ^. L.result of-    Right x -> x-    Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) err+    Right x  -> x+    Left err -> throw $ UnexpectedResponseError (fromJust $ rsp ^. L.id) err
− test/testdata/hieBiosMainIs/dist-newstyle/cache/plan.json 
@@ -1,1 +0,0 @@-{"cabal-version":"3.10.2.0","cabal-lib-version":"3.10.2.1","compiler-id":"ghc-9.8.1","os":"linux","arch":"x86_64","install-plan":[{"type":"pre-existing","id":"base-4.19.0.0-c1f2","pkg-name":"base","pkg-version":"4.19.0.0","depends":["ghc-bignum-1.3-d2d5","ghc-prim-0.11.0-b1d6","rts-1.0.2"]},{"type":"pre-existing","id":"ghc-bignum-1.3-d2d5","pkg-name":"ghc-bignum","pkg-version":"1.3","depends":["ghc-prim-0.11.0-b1d6"]},{"type":"pre-existing","id":"ghc-prim-0.11.0-b1d6","pkg-name":"ghc-prim","pkg-version":"0.11.0","depends":["rts-1.0.2"]},{"type":"configured","id":"hieBiosMainIs-0.1.0.0-inplace-hieBiosMainIs","pkg-name":"hieBiosMainIs","pkg-version":"0.1.0.0","flags":{},"style":"local","pkg-src":{"type":"local","path":"/home/zubin/haskell-language-server/test/testdata/hieBiosMainIs/."},"dist-dir":"/home/zubin/haskell-language-server/test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.8.1/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs","build-info":"/home/zubin/haskell-language-server/test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.8.1/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs/build-info.json","depends":["base-4.19.0.0-c1f2"],"exe-depends":[],"component-name":"exe:hieBiosMainIs","bin-file":"/home/zubin/haskell-language-server/test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.8.1/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs/build/hieBiosMainIs/hieBiosMainIs"},{"type":"pre-existing","id":"rts-1.0.2","pkg-name":"rts","pkg-version":"1.0.2","depends":[]}]}
− test/testdata/missingModuleTest/missingModule/dist-newstyle/cache/plan.json 
@@ -1,1 +0,0 @@-{"cabal-version":"3.10.2.0","cabal-lib-version":"3.10.2.1","compiler-id":"ghc-9.8.1","os":"linux","arch":"x86_64","install-plan":[{"type":"pre-existing","id":"base-4.19.0.0-c1f2","pkg-name":"base","pkg-version":"4.19.0.0","depends":["ghc-bignum-1.3-d2d5","ghc-prim-0.11.0-b1d6","rts-1.0.2"]},{"type":"pre-existing","id":"ghc-bignum-1.3-d2d5","pkg-name":"ghc-bignum","pkg-version":"1.3","depends":["ghc-prim-0.11.0-b1d6"]},{"type":"pre-existing","id":"ghc-prim-0.11.0-b1d6","pkg-name":"ghc-prim","pkg-version":"0.11.0","depends":["rts-1.0.2"]},{"type":"configured","id":"missingModule-0.1.0.0-inplace","pkg-name":"missingModule","pkg-version":"0.1.0.0","flags":{},"style":"local","pkg-src":{"type":"local","path":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/missingModule/."},"dist-dir":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/missingModule/dist-newstyle/build/x86_64-linux/ghc-9.8.1/missingModule-0.1.0.0","build-info":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/missingModule/dist-newstyle/build/x86_64-linux/ghc-9.8.1/missingModule-0.1.0.0/build-info.json","depends":["base-4.19.0.0-c1f2"],"exe-depends":[],"component-name":"lib"},{"type":"pre-existing","id":"rts-1.0.2","pkg-name":"rts","pkg-version":"1.0.2","depends":[]}]}
− test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/cache/plan.json 
@@ -1,1 +0,0 @@-{"cabal-version":"3.10.2.0","cabal-lib-version":"3.10.2.1","compiler-id":"ghc-9.8.1","os":"linux","arch":"x86_64","install-plan":[{"type":"pre-existing","id":"base-4.19.0.0-c1f2","pkg-name":"base","pkg-version":"4.19.0.0","depends":["ghc-bignum-1.3-d2d5","ghc-prim-0.11.0-b1d6","rts-1.0.2"]},{"type":"pre-existing","id":"ghc-bignum-1.3-d2d5","pkg-name":"ghc-bignum","pkg-version":"1.3","depends":["ghc-prim-0.11.0-b1d6"]},{"type":"pre-existing","id":"ghc-prim-0.11.0-b1d6","pkg-name":"ghc-prim","pkg-version":"0.11.0","depends":["rts-1.0.2"]},{"type":"configured","id":"noPrefixMatch-0.1.0.0-inplace-testExe","pkg-name":"noPrefixMatch","pkg-version":"0.1.0.0","flags":{},"style":"local","pkg-src":{"type":"local","path":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/noPrefixMatch/."},"dist-dir":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/build/x86_64-linux/ghc-9.8.1/noPrefixMatch-0.1.0.0/x/testExe","build-info":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/build/x86_64-linux/ghc-9.8.1/noPrefixMatch-0.1.0.0/x/testExe/build-info.json","depends":["base-4.19.0.0-c1f2"],"exe-depends":[],"component-name":"exe:testExe","bin-file":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/build/x86_64-linux/ghc-9.8.1/noPrefixMatch-0.1.0.0/x/testExe/build/testExe/testExe"},{"type":"pre-existing","id":"rts-1.0.2","pkg-name":"rts","pkg-version":"1.0.2","depends":[]}]}
test/utils/Test/Hls/Command.hs view
@@ -22,10 +22,10 @@   pure testExe  hlsLspCommand :: String-hlsLspCommand = hlsExeCommand ++ " --lsp -d -j4"+hlsLspCommand = hlsExeCommand ++ " --lsp --test -d -j4"  hlsWrapperLspCommand :: String-hlsWrapperLspCommand = hlsWrapperExeCommand ++ " --lsp -d -j4"+hlsWrapperLspCommand = hlsWrapperExeCommand ++ " --lsp --test -d -j4"  hlsWrapperExeCommand :: String {-# NOINLINE hlsWrapperExeCommand #-}