diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -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 diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -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" diff --git a/ghcide-bench/exe/Main.hs b/ghcide-bench/exe/Main.hs new file mode 100644 --- /dev/null +++ b/ghcide-bench/exe/Main.hs @@ -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 diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs new file mode 100644 --- /dev/null +++ b/ghcide-bench/src/Experiments.hs @@ -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 diff --git a/ghcide-bench/src/Experiments/Types.hs b/ghcide-bench/src/Experiments/Types.hs new file mode 100644 --- /dev/null +++ b/ghcide-bench/src/Experiments/Types.hs @@ -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] diff --git a/ghcide-bench/test/Main.hs b/ghcide-bench/test/Main.hs new file mode 100644 --- /dev/null +++ b/ghcide-bench/test/Main.hs @@ -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 diff --git a/ghcide/test/exe/AsyncTests.hs b/ghcide/test/exe/AsyncTests.hs --- a/ghcide/test/exe/AsyncTests.hs +++ b/ghcide/test/exe/AsyncTests.hs @@ -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 diff --git a/ghcide/test/exe/BootTests.hs b/ghcide/test/exe/BootTests.hs --- a/ghcide/test/exe/BootTests.hs +++ b/ghcide/test/exe/BootTests.hs @@ -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 diff --git a/ghcide/test/exe/CPPTests.hs b/ghcide/test/exe/CPPTests.hs --- a/ghcide/test/exe/CPPTests.hs +++ b/ghcide/test/exe/CPPTests.hs @@ -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 =" diff --git a/ghcide/test/exe/ClientSettingsTests.hs b/ghcide/test/exe/ClientSettingsTests.hs --- a/ghcide/test/exe/ClientSettingsTests.hs +++ b/ghcide/test/exe/ClientSettingsTests.hs @@ -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 diff --git a/ghcide/test/exe/CodeLensTests.hs b/ghcide/test/exe/CodeLensTests.hs --- a/ghcide/test/exe/CodeLensTests.hs +++ b/ghcide/test/exe/CodeLensTests.hs @@ -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 = _" diff --git a/ghcide/test/exe/CompletionTests.hs b/ghcide/test/exe/CompletionTests.hs --- a/ghcide/test/exe/CompletionTests.hs +++ b/ghcide/test/exe/CompletionTests.hs @@ -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 diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -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") diff --git a/ghcide/test/exe/CradleTests.hs b/ghcide/test/exe/CradleTests.hs --- a/ghcide/test/exe/CradleTests.hs +++ b/ghcide/test/exe/CradleTests.hs @@ -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", [])] diff --git a/ghcide/test/exe/DependentFileTest.hs b/ghcide/test/exe/DependentFileTest.hs --- a/ghcide/test/exe/DependentFileTest.hs +++ b/ghcide/test/exe/DependentFileTest.hs @@ -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", [])] diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs --- a/ghcide/test/exe/DiagnosticTests.hs +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -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 diff --git a/ghcide/test/exe/ExceptionTests.hs b/ghcide/test/exe/ExceptionTests.hs --- a/ghcide/test/exe/ExceptionTests.hs +++ b/ghcide/test/exe/ExceptionTests.hs @@ -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) diff --git a/ghcide/test/exe/FindDefinitionAndHoverTests.hs b/ghcide/test/exe/FindDefinitionAndHoverTests.hs --- a/ghcide/test/exe/FindDefinitionAndHoverTests.hs +++ b/ghcide/test/exe/FindDefinitionAndHoverTests.hs @@ -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 diff --git a/ghcide/test/exe/GarbageCollectionTests.hs b/ghcide/test/exe/GarbageCollectionTests.hs --- a/ghcide/test/exe/GarbageCollectionTests.hs +++ b/ghcide/test/exe/GarbageCollectionTests.hs @@ -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 diff --git a/ghcide/test/exe/HighlightTests.hs b/ghcide/test/exe/HighlightTests.hs --- a/ghcide/test/exe/HighlightTests.hs +++ b/ghcide/test/exe/HighlightTests.hs @@ -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) diff --git a/ghcide/test/exe/IfaceTests.hs b/ghcide/test/exe/IfaceTests.hs --- a/ghcide/test/exe/IfaceTests.hs +++ b/ghcide/test/exe/IfaceTests.hs @@ -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 diff --git a/ghcide/test/exe/InitializeResponseTests.hs b/ghcide/test/exe/InitializeResponseTests.hs --- a/ghcide/test/exe/InitializeResponseTests.hs +++ b/ghcide/test/exe/InitializeResponseTests.hs @@ -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 diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -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 ] diff --git a/ghcide/test/exe/NonLspCommandLine.hs b/ghcide/test/exe/NonLspCommandLine.hs --- a/ghcide/test/exe/NonLspCommandLine.hs +++ b/ghcide/test/exe/NonLspCommandLine.hs @@ -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) diff --git a/ghcide/test/exe/OpenCloseTest.hs b/ghcide/test/exe/OpenCloseTest.hs --- a/ghcide/test/exe/OpenCloseTest.hs +++ b/ghcide/test/exe/OpenCloseTest.hs @@ -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 diff --git a/ghcide/test/exe/OutlineTests.hs b/ghcide/test/exe/OutlineTests.hs --- a/ghcide/test/exe/OutlineTests.hs +++ b/ghcide/test/exe/OutlineTests.hs @@ -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) diff --git a/ghcide/test/exe/PluginSimpleTests.hs b/ghcide/test/exe/PluginSimpleTests.hs --- a/ghcide/test/exe/PluginSimpleTests.hs +++ b/ghcide/test/exe/PluginSimpleTests.hs @@ -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'}]}" diff --git a/ghcide/test/exe/PositionMappingTests.hs b/ghcide/test/exe/PositionMappingTests.hs --- a/ghcide/test/exe/PositionMappingTests.hs +++ b/ghcide/test/exe/PositionMappingTests.hs @@ -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 diff --git a/ghcide/test/exe/PreprocessorTests.hs b/ghcide/test/exe/PreprocessorTests.hs --- a/ghcide/test/exe/PreprocessorTests.hs +++ b/ghcide/test/exe/PreprocessorTests.hs @@ -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 #-}" diff --git a/ghcide/test/exe/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs --- a/ghcide/test/exe/ReferenceTests.hs +++ b/ghcide/test/exe/ReferenceTests.hs @@ -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 diff --git a/ghcide/test/exe/RootUriTests.hs b/ghcide/test/exe/RootUriTests.hs --- a/ghcide/test/exe/RootUriTests.hs +++ b/ghcide/test/exe/RootUriTests.hs @@ -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 + } + + diff --git a/ghcide/test/exe/SafeTests.hs b/ghcide/test/exe/SafeTests.hs --- a/ghcide/test/exe/SafeTests.hs +++ b/ghcide/test/exe/SafeTests.hs @@ -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 #-}" diff --git a/ghcide/test/exe/SymlinkTests.hs b/ghcide/test/exe/SymlinkTests.hs --- a/ghcide/test/exe/SymlinkTests.hs +++ b/ghcide/test/exe/SymlinkTests.hs @@ -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 diff --git a/ghcide/test/exe/THTests.hs b/ghcide/test/exe/THTests.hs --- a/ghcide/test/exe/THTests.hs +++ b/ghcide/test/exe/THTests.hs @@ -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")] diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs deleted file mode 100644 --- a/ghcide/test/exe/TestUtils.hs +++ /dev/null @@ -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 diff --git a/ghcide/test/exe/UnitTests.hs b/ghcide/test/exe/UnitTests.hs --- a/ghcide/test/exe/UnitTests.hs +++ b/ghcide/test/exe/UnitTests.hs @@ -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 diff --git a/ghcide/test/exe/WatchedFileTests.hs b/ghcide/test/exe/WatchedFileTests.hs --- a/ghcide/test/exe/WatchedFileTests.hs +++ b/ghcide/test/exe/WatchedFileTests.hs @@ -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" diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -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 @@ -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 diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs @@ -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)) diff --git a/plugins/hls-cabal-gild-plugin/test/testdata/lib_testdata.formatted_document.cabal b/plugins/hls-cabal-gild-plugin/test/testdata/lib_testdata.formatted_document.cabal --- a/plugins/hls-cabal-gild-plugin/test/testdata/lib_testdata.formatted_document.cabal +++ b/plugins/hls-cabal-gild-plugin/test/testdata/lib_testdata.formatted_document.cabal @@ -17,4 +17,5 @@ testdata, hs-source-dirs: app - default-language: Haskell2010 + default-language: + Haskell2010 diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -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 diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Paths.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Paths.hs --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Paths.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Paths.hs @@ -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] diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs @@ -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 diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Data.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Data.hs --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Data.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Data.hs @@ -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) ] diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs @@ -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) diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs @@ -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 diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs @@ -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 diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Orphans.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Orphans.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Orphans.hs @@ -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 diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs @@ -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 diff --git a/plugins/hls-cabal-plugin/test/Completer.hs b/plugins/hls-cabal-plugin/test/Completer.hs --- a/plugins/hls-cabal-plugin/test/Completer.hs +++ b/plugins/hls-cabal-plugin/test/Completer.hs @@ -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 @?== [], diff --git a/plugins/hls-cabal-plugin/test/Context.hs b/plugins/hls-cabal-plugin/test/Context.hs --- a/plugins/hls-cabal-plugin/test/Context.hs +++ b/plugins/hls-cabal-plugin/test/Context.hs @@ -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 + ^ +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 +|] diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs --- a/plugins/hls-cabal-plugin/test/Main.hs +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -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'"] diff --git a/plugins/hls-cabal-plugin/test/testdata/completer.cabal b/plugins/hls-cabal-plugin/test/testdata/completer.cabal --- a/plugins/hls-cabal-plugin/test/testdata/completer.cabal +++ b/plugins/hls-cabal-plugin/test/testdata/completer.cabal @@ -10,3 +10,5 @@ library lib + +co diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -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 diff --git a/plugins/hls-change-type-signature-plugin/test/Main.hs b/plugins/hls-change-type-signature-plugin/test/Main.hs --- a/plugins/hls-change-type-signature-plugin/test/Main.hs +++ b/plugins/hls-change-type-signature-plugin/test/Main.hs @@ -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 diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -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 diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs @@ -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= diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs @@ -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 - diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs @@ -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 diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs --- a/plugins/hls-class-plugin/test/Main.hs +++ b/plugins/hls-class-plugin/test/Main.hs @@ -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 diff --git a/plugins/hls-class-plugin/test/testdata/T5.expected.hs b/plugins/hls-class-plugin/test/testdata/T5.expected.hs --- a/plugins/hls-class-plugin/test/testdata/T5.expected.hs +++ b/plugins/hls-class-plugin/test/testdata/T5.expected.hs @@ -1,4 +1,4 @@ -module T1 where +module T5 where data X = X diff --git a/plugins/hls-class-plugin/test/testdata/T5.hs b/plugins/hls-class-plugin/test/testdata/T5.hs --- a/plugins/hls-class-plugin/test/testdata/T5.hs +++ b/plugins/hls-class-plugin/test/testdata/T5.hs @@ -1,4 +1,4 @@ -module T1 where +module T5 where data X = X diff --git a/plugins/hls-class-plugin/test/testdata/T7.expected.hs b/plugins/hls-class-plugin/test/testdata/T7.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T7.expected.hs @@ -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 = () diff --git a/plugins/hls-class-plugin/test/testdata/T7.hs b/plugins/hls-class-plugin/test/testdata/T7.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T7.hs @@ -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 = () diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs --- a/plugins/hls-code-range-plugin/test/Main.hs +++ b/plugins/hls-code-range-plugin/test/Main.hs @@ -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 "" diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -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)] diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -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)] diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs @@ -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 + diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -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) diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -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) diff --git a/plugins/hls-eval-plugin/test/testdata/T15.expected.hs b/plugins/hls-eval-plugin/test/testdata/T15.expected.hs deleted file mode 100644 --- a/plugins/hls-eval-plugin/test/testdata/T15.expected.hs +++ /dev/null @@ -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 diff --git a/plugins/hls-eval-plugin/test/testdata/T15.hs b/plugins/hls-eval-plugin/test/testdata/T15.hs deleted file mode 100644 --- a/plugins/hls-eval-plugin/test/testdata/T15.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -module T15 where - -foo :: Show a => a -> String -foo = show - --- >>> :type +v foo @Int diff --git a/plugins/hls-eval-plugin/test/testdata/TIO.expected.hs b/plugins/hls-eval-plugin/test/testdata/TIO.expected.hs --- a/plugins/hls-eval-plugin/test/testdata/TIO.expected.hs +++ b/plugins/hls-eval-plugin/test/testdata/TIO.expected.hs @@ -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" -} diff --git a/plugins/hls-eval-plugin/test/testdata/TIO.hs b/plugins/hls-eval-plugin/test/testdata/TIO.hs --- a/plugins/hls-eval-plugin/test/testdata/TIO.hs +++ b/plugins/hls-eval-plugin/test/testdata/TIO.hs @@ -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" -} diff --git a/plugins/hls-eval-plugin/test/testdata/TPropertyError.expected.hs b/plugins/hls-eval-plugin/test/testdata/TPropertyError.expected.hs deleted file mode 100644 --- a/plugins/hls-eval-plugin/test/testdata/TPropertyError.expected.hs +++ /dev/null @@ -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): --- [] diff --git a/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc910.expected.hs b/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc910.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc910.expected.hs @@ -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 :1:27 in interactive:Ghci2 +-- [] diff --git a/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc92.expected.hs b/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc92.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc92.expected.hs @@ -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): +-- [] diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -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 diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -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 diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -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 diff --git a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs --- a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs +++ b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs @@ -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 diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs @@ -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 ()) diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs @@ -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 diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -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 diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -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" diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -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 diff --git a/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs b/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs --- a/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs +++ b/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs @@ -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 diff --git a/plugins/hls-notes-plugin/test/NotesTest.hs b/plugins/hls-notes-plugin/test/NotesTest.hs --- a/plugins/hls-notes-plugin/test/NotesTest.hs +++ b/plugins/hls-notes-plugin/test/NotesTest.hs @@ -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 diff --git a/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs b/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs --- a/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs +++ b/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs @@ -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 diff --git a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs --- a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs +++ b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs @@ -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" diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -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 diff --git a/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs b/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs --- a/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs +++ b/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs @@ -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 #-} diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs @@ -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' diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs @@ -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 diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -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 _ = "" - -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 _ = "" +#else +instance Show HsModule where + show _ = "" +#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{} = diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -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] diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -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 diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -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 diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs @@ -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') - diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs @@ -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 diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -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') diff --git a/plugins/hls-refactor-plugin/test/Test/AddArgument.hs b/plugins/hls-refactor-plugin/test/Test/AddArgument.hs --- a/plugins/hls-refactor-plugin/test/Test/AddArgument.hs +++ b/plugins/hls-refactor-plugin/test/Test/AddArgument.hs @@ -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), diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -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 diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -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 diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -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 diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -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 = diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/T1.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/T1.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/T1.expected +++ /dev/null @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/T1.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/T1.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/T1.hs +++ /dev/null @@ -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!" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.expected +++ /dev/null @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.hs +++ /dev/null @@ -1,6 +0,0 @@ -module TClass where - - -class Foo a where - foo :: a -> Int - diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.expected +++ /dev/null @@ -1,3 +0,0 @@ -4:6-9 TTypeConstructor "Foo" -4:12-15 TDataConstructor "Foo" -4:26-30 TClass "Show" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.hs +++ /dev/null @@ -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 = (==) diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.expected +++ /dev/null @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.hs +++ /dev/null @@ -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 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.expected +++ /dev/null @@ -1,4 +0,0 @@ -3:6-9 TTypeConstructor "Foo" -3:12-15 TDataConstructor "Foo" -3:16-19 TTypeConstructor "Int" -3:30-32 TClass "Eq" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.hs +++ /dev/null @@ -1,3 +0,0 @@ -module TDataType where - -data Foo = Foo Int deriving (Eq) diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.expected +++ /dev/null @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.hs +++ /dev/null @@ -1,6 +0,0 @@ -module TDatatypeImported where - -import System.IO - -go :: IO () -go = print 1 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.expected +++ /dev/null @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.hs +++ /dev/null @@ -1,9 +0,0 @@ -module TDoc where - --- | --- `hello` -hello :: Int -hello = length "Hello, Haskell!" - - - diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.expected +++ /dev/null @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.hs +++ /dev/null @@ -1,7 +0,0 @@ -module TFunction where - -f :: forall a. a -> a -f x = x - -x :: a -x = undefined diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.expected +++ /dev/null @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.hs +++ /dev/null @@ -1,4 +0,0 @@ -module TFunctionLet where - -y :: Int -y = let f x = 1 in 1 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.expected +++ /dev/null @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.hs +++ /dev/null @@ -1,8 +0,0 @@ -module TFunctionLocal where - -f :: Int -> Int -f 1 = g 1 - where - g x = 1 - - diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.expected +++ /dev/null @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.hs +++ /dev/null @@ -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 - diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.expected +++ /dev/null @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.hs +++ /dev/null @@ -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 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.expected +++ /dev/null @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.hs +++ /dev/null @@ -1,6 +0,0 @@ -module TInstanceClassMethodBind where - - -data Foo = Foo Int -instance Show Foo where - show = undefined diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.expected +++ /dev/null @@ -1,2 +0,0 @@ -4:1-3 TFunction "go" -4:8-12 TClassMethod "show" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.hs +++ /dev/null @@ -1,5 +0,0 @@ -module TInstanceClassMethodUse where - - -go = show - diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleA.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleA.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleA.hs +++ /dev/null @@ -1,5 +0,0 @@ -module TModuleA where - -data Game = Game {a𐐀b :: Int} - - diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleB.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleB.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleB.hs +++ /dev/null @@ -1,8 +0,0 @@ -module TModuleB where - -import TModuleA -import qualified TModuleA - -go = Game 1 - -a𐐀bb = TModuleA.a𐐀b go diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.expected +++ /dev/null @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.hs +++ /dev/null @@ -1,5 +0,0 @@ -module TNoneFunctionWithConstraint where - -x :: (Eq a) => a -x = undefined - diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.expected +++ /dev/null @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.hs +++ /dev/null @@ -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) diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.expected +++ /dev/null @@ -1,2 +0,0 @@ -4:1-2 TFunction "g" -4:4-11 TDataConstructor "Nothing" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.hs +++ /dev/null @@ -1,6 +0,0 @@ -module TPatternMatch where - - -g (Nothing, _) = 1 - - diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.expected +++ /dev/null @@ -1,1 +0,0 @@ -5:9-12 TPatternSynonym "Foo" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module TPatternSynonym where - - -pattern Foo = 1 - - diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.expected +++ /dev/null @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.hs +++ /dev/null @@ -1,9 +0,0 @@ -module TVariable where - -(a, b) = (1, 2) - -f g y = g y - - - - diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.expected +++ /dev/null @@ -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 "+" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.hs +++ /dev/null @@ -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 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.expected +++ /dev/null @@ -1,4 +0,0 @@ -4:6-9 TTypeConstructor "Foo" -4:12-15 TDataConstructor "Foo" -4:18-21 TRecordField "foo" -4:25-28 TTypeConstructor "Int" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.hs +++ /dev/null @@ -1,7 +0,0 @@ -module TRecord where - - -data Foo = Foo { foo :: Int } - - - diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.expected +++ /dev/null @@ -1,4 +0,0 @@ -5:6-9 TTypeConstructor "Foo" -5:12-15 TDataConstructor "Foo" -5:18-21 TRecordField "boo" -5:26-32 TTypeSynonym "String" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} - -module TRecordDuplicateRecordFields where - -data Foo = Foo { boo :: !String } diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.expected +++ /dev/null @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module TTypefamily where - -type family Foo a where - Foo Int = Int - Foo a = String diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.expected +++ /dev/null @@ -1,1 +0,0 @@ -3:1-4 TVariable "a\66560b" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.hs +++ /dev/null @@ -1,5 +0,0 @@ -module TUnicodeSyntax where - -a𐐀b = "a𐐀b" - - diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.expected deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.expected +++ /dev/null @@ -1,4 +0,0 @@ -4:1-6 TVariable "hello" -4:10-13 TTypeConstructor "Int" -5:1-6 TVariable "hello" -5:9-15 TClassMethod "length" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.hs deleted file mode 100644 --- a/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.hs +++ /dev/null @@ -1,8 +0,0 @@ -module TValBind where - - -hello :: Int -hello = length "Hello, Haskell!" - - - diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/T1.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/T1.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/T1.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/T1.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/T1.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/T1.hs @@ -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!" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClass.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClass.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClass.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClass.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClass.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClass.hs @@ -0,0 +1,6 @@ +module TClass where + + +class Foo a where + foo :: a -> Int + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClassImportedDeriving.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClassImportedDeriving.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClassImportedDeriving.expected @@ -0,0 +1,4 @@ +2:8-30 TModule "TClassImportedDeriving" +4:6-9 TTypeConstructor "Foo" +4:12-15 TDataConstructor "Foo" +4:26-30 TClass "Show" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClassImportedDeriving.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClassImportedDeriving.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClassImportedDeriving.hs @@ -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 = (==) diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataFamily.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataFamily.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataFamily.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataFamily.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataFamily.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataFamily.hs @@ -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 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataType.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataType.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataType.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataType.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataType.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataType.hs @@ -0,0 +1,3 @@ +module TDataType where + +data Foo = Foo Int deriving (Eq) diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDatatypeImported.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDatatypeImported.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDatatypeImported.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDatatypeImported.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDatatypeImported.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDatatypeImported.hs @@ -0,0 +1,6 @@ +module TDatatypeImported where + +import System.IO + +go :: IO () +go = print 1 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDoc.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDoc.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDoc.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDoc.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDoc.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDoc.hs @@ -0,0 +1,9 @@ +module TDoc where + +-- | +-- `hello` +hello :: Int +hello = length "Hello, Haskell!" + + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunction.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunction.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunction.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunction.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunction.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunction.hs @@ -0,0 +1,7 @@ +module TFunction where + +f :: forall a. a -> a +f x = x + +x :: a +x = undefined diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLet.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLet.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLet.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLet.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLet.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLet.hs @@ -0,0 +1,4 @@ +module TFunctionLet where + +y :: Int +y = let f x = 1 in 1 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLocal.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLocal.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLocal.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLocal.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLocal.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLocal.hs @@ -0,0 +1,8 @@ +module TFunctionLocal where + +f :: Int -> Int +f 1 = g 1 + where + g x = 1 + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionUnderTypeSynonym.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionUnderTypeSynonym.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionUnderTypeSynonym.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionUnderTypeSynonym.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionUnderTypeSynonym.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionUnderTypeSynonym.hs @@ -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 + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TGADT.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TGADT.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TGADT.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TGADT.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TGADT.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TGADT.hs @@ -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 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodBind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodBind.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodBind.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodBind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodBind.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodBind.hs @@ -0,0 +1,6 @@ +module TInstanceClassMethodBind where + + +data Foo = Foo Int +instance Show Foo where + show = undefined diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodUse.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodUse.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodUse.expected @@ -0,0 +1,3 @@ +1:8-31 TModule "TInstanceClassMethodUse" +4:1-3 TFunction "go" +4:8-12 TClassMethod "show" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodUse.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodUse.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodUse.hs @@ -0,0 +1,5 @@ +module TInstanceClassMethodUse where + + +go = show + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TModuleA.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TModuleA.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TModuleA.hs @@ -0,0 +1,5 @@ +module TModuleA where + +data Game = Game {a𐐀b :: Int} + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TModuleB.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TModuleB.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TModuleB.hs @@ -0,0 +1,8 @@ +module TModuleB where + +import TModuleA +import qualified TModuleA + +go = Game 1 + +a𐐀bb = TModuleA.a𐐀b go diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TNoneFunctionWithConstraint.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TNoneFunctionWithConstraint.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TNoneFunctionWithConstraint.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TNoneFunctionWithConstraint.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TNoneFunctionWithConstraint.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TNoneFunctionWithConstraint.hs @@ -0,0 +1,5 @@ +module TNoneFunctionWithConstraint where + +x :: (Eq a) => a +x = undefined + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TOperator.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TOperator.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TOperator.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TOperator.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TOperator.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TOperator.hs @@ -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) diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternMatch.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternMatch.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternMatch.expected @@ -0,0 +1,3 @@ +1:8-21 TModule "TPatternMatch" +4:1-2 TFunction "g" +4:4-11 TDataConstructor "Nothing" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternMatch.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternMatch.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternMatch.hs @@ -0,0 +1,6 @@ +module TPatternMatch where + + +g (Nothing, _) = 1 + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternSynonym.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternSynonym.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternSynonym.expected @@ -0,0 +1,2 @@ +2:8-23 TModule "TPatternSynonym" +5:9-12 TPatternSynonym "Foo" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternSynonym.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternSynonym.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternSynonym.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +module TPatternSynonym where + + +pattern Foo = 1 + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternbind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternbind.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternbind.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternbind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternbind.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternbind.hs @@ -0,0 +1,9 @@ +module TVariable where + +(a, b) = (1, 2) + +f g y = g y + + + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TQualifiedName.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TQualifiedName.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TQualifiedName.expected @@ -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 "+" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TQualifiedName.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TQualifiedName.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TQualifiedName.hs @@ -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 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecord.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecord.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecord.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecord.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecord.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecord.hs @@ -0,0 +1,7 @@ +module TRecord where + + +data Foo = Foo { foo :: Int } + + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecordDuplicateRecordFields.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecordDuplicateRecordFields.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecordDuplicateRecordFields.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecordDuplicateRecordFields.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecordDuplicateRecordFields.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecordDuplicateRecordFields.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module TRecordDuplicateRecordFields where + +data Foo = Foo { boo :: !String } diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TTypefamily.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TTypefamily.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TTypefamily.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TTypefamily.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TTypefamily.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TTypefamily.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +module TTypefamily where + +type family Foo a where + Foo Int = Int + Foo a = String diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TUnicodeSyntax.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TUnicodeSyntax.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TUnicodeSyntax.expected @@ -0,0 +1,2 @@ +1:8-22 TModule "TUnicodeSyntax" +3:1-4 TVariable "a\66560b" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TUnicodeSyntax.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TUnicodeSyntax.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TUnicodeSyntax.hs @@ -0,0 +1,5 @@ +module TUnicodeSyntax where + +a𐐀b = "a𐐀b" + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TValBind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TValBind.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TValBind.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TValBind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TValBind.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TValBind.hs @@ -0,0 +1,8 @@ +module TValBind where + + +hello :: Int +hello = length "Hello, Haskell!" + + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/T1.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/T1.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/T1.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/T1.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/T1.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/T1.hs @@ -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!" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClass.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClass.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClass.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClass.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClass.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClass.hs @@ -0,0 +1,6 @@ +module TClass where + + +class Foo a where + foo :: a -> Int + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClassImportedDeriving.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClassImportedDeriving.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClassImportedDeriving.expected @@ -0,0 +1,3 @@ +4:6-9 TTypeConstructor "Foo" +4:12-15 TDataConstructor "Foo" +4:26-30 TClass "Show" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClassImportedDeriving.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClassImportedDeriving.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClassImportedDeriving.hs @@ -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 = (==) diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataFamily.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataFamily.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataFamily.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataFamily.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataFamily.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataFamily.hs @@ -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 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataType.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataType.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataType.expected @@ -0,0 +1,4 @@ +3:6-9 TTypeConstructor "Foo" +3:12-15 TDataConstructor "Foo" +3:16-19 TTypeConstructor "Int" +3:30-32 TClass "Eq" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataType.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataType.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataType.hs @@ -0,0 +1,3 @@ +module TDataType where + +data Foo = Foo Int deriving (Eq) diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDatatypeImported.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDatatypeImported.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDatatypeImported.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDatatypeImported.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDatatypeImported.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDatatypeImported.hs @@ -0,0 +1,6 @@ +module TDatatypeImported where + +import System.IO + +go :: IO () +go = print 1 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDoc.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDoc.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDoc.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDoc.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDoc.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDoc.hs @@ -0,0 +1,9 @@ +module TDoc where + +-- | +-- `hello` +hello :: Int +hello = length "Hello, Haskell!" + + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunction.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunction.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunction.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunction.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunction.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunction.hs @@ -0,0 +1,7 @@ +module TFunction where + +f :: forall a. a -> a +f x = x + +x :: a +x = undefined diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLet.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLet.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLet.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLet.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLet.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLet.hs @@ -0,0 +1,4 @@ +module TFunctionLet where + +y :: Int +y = let f x = 1 in 1 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLocal.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLocal.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLocal.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLocal.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLocal.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLocal.hs @@ -0,0 +1,8 @@ +module TFunctionLocal where + +f :: Int -> Int +f 1 = g 1 + where + g x = 1 + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionUnderTypeSynonym.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionUnderTypeSynonym.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionUnderTypeSynonym.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionUnderTypeSynonym.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionUnderTypeSynonym.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionUnderTypeSynonym.hs @@ -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 + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TGADT.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TGADT.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TGADT.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TGADT.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TGADT.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TGADT.hs @@ -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 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodBind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodBind.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodBind.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodBind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodBind.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodBind.hs @@ -0,0 +1,6 @@ +module TInstanceClassMethodBind where + + +data Foo = Foo Int +instance Show Foo where + show = undefined diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodUse.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodUse.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodUse.expected @@ -0,0 +1,2 @@ +4:1-3 TFunction "go" +4:8-12 TClassMethod "show" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodUse.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodUse.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodUse.hs @@ -0,0 +1,5 @@ +module TInstanceClassMethodUse where + + +go = show + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TModuleA.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TModuleA.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TModuleA.hs @@ -0,0 +1,5 @@ +module TModuleA where + +data Game = Game {a𐐀b :: Int} + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TModuleB.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TModuleB.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TModuleB.hs @@ -0,0 +1,8 @@ +module TModuleB where + +import TModuleA +import qualified TModuleA + +go = Game 1 + +a𐐀bb = TModuleA.a𐐀b go diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TNoneFunctionWithConstraint.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TNoneFunctionWithConstraint.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TNoneFunctionWithConstraint.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TNoneFunctionWithConstraint.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TNoneFunctionWithConstraint.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TNoneFunctionWithConstraint.hs @@ -0,0 +1,5 @@ +module TNoneFunctionWithConstraint where + +x :: (Eq a) => a +x = undefined + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TOperator.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TOperator.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TOperator.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TOperator.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TOperator.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TOperator.hs @@ -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) diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternMatch.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternMatch.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternMatch.expected @@ -0,0 +1,2 @@ +4:1-2 TFunction "g" +4:4-11 TDataConstructor "Nothing" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternMatch.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternMatch.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternMatch.hs @@ -0,0 +1,6 @@ +module TPatternMatch where + + +g (Nothing, _) = 1 + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternSynonym.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternSynonym.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternSynonym.expected @@ -0,0 +1,1 @@ +5:9-12 TPatternSynonym "Foo" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternSynonym.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternSynonym.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternSynonym.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +module TPatternSynonym where + + +pattern Foo = 1 + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternbind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternbind.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternbind.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternbind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternbind.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternbind.hs @@ -0,0 +1,9 @@ +module TVariable where + +(a, b) = (1, 2) + +f g y = g y + + + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TQualifiedName.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TQualifiedName.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TQualifiedName.expected @@ -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 "+" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TQualifiedName.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TQualifiedName.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TQualifiedName.hs @@ -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 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecord.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecord.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecord.expected @@ -0,0 +1,4 @@ +4:6-9 TTypeConstructor "Foo" +4:12-15 TDataConstructor "Foo" +4:18-21 TRecordField "foo" +4:25-28 TTypeConstructor "Int" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecord.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecord.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecord.hs @@ -0,0 +1,7 @@ +module TRecord where + + +data Foo = Foo { foo :: Int } + + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecordDuplicateRecordFields.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecordDuplicateRecordFields.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecordDuplicateRecordFields.expected @@ -0,0 +1,4 @@ +5:6-9 TTypeConstructor "Foo" +5:12-15 TDataConstructor "Foo" +5:18-21 TRecordField "boo" +5:26-32 TTypeSynonym "String" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecordDuplicateRecordFields.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecordDuplicateRecordFields.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecordDuplicateRecordFields.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module TRecordDuplicateRecordFields where + +data Foo = Foo { boo :: !String } diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TTypefamily.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TTypefamily.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TTypefamily.expected @@ -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" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TTypefamily.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TTypefamily.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TTypefamily.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +module TTypefamily where + +type family Foo a where + Foo Int = Int + Foo a = String diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TUnicodeSyntax.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TUnicodeSyntax.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TUnicodeSyntax.expected @@ -0,0 +1,1 @@ +3:1-4 TVariable "a\66560b" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TUnicodeSyntax.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TUnicodeSyntax.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TUnicodeSyntax.hs @@ -0,0 +1,5 @@ +module TUnicodeSyntax where + +a𐐀b = "a𐐀b" + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TValBind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TValBind.expected new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TValBind.expected @@ -0,0 +1,4 @@ +4:1-6 TVariable "hello" +4:10-13 TTypeConstructor "Int" +5:1-6 TVariable "hello" +5:9-15 TClassMethod "length" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TValBind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TValBind.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TValBind.hs @@ -0,0 +1,8 @@ +module TValBind where + + +hello :: Int +hello = length "Hello, Haskell!" + + + diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -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 diff --git a/plugins/hls-splice-plugin/test/Main.hs b/plugins/hls-splice-plugin/test/Main.hs --- a/plugins/hls-splice-plugin/test/Main.hs +++ b/plugins/hls-splice-plugin/test/Main.hs @@ -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 diff --git a/plugins/hls-stan-plugin/test/Main.hs b/plugins/hls-stan-plugin/test/Main.hs --- a/plugins/hls-stan-plugin/test/Main.hs +++ b/plugins/hls-stan-plugin/test/Main.hs @@ -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 diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -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 diff --git a/test/functional/Config.hs b/test/functional/Config.hs --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -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 diff --git a/test/functional/Format.hs b/test/functional/Format.hs --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -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" diff --git a/test/functional/FunctionalBadProject.hs b/test/functional/FunctionalBadProject.hs --- a/test/functional/FunctionalBadProject.hs +++ b/test/functional/FunctionalBadProject.hs @@ -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" $ diff --git a/test/functional/HieBios.hs b/test/functional/HieBios.hs --- a/test/functional/HieBios.hs +++ b/test/functional/HieBios.hs @@ -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) diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -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 diff --git a/test/testdata/hieBiosMainIs/dist-newstyle/cache/plan.json b/test/testdata/hieBiosMainIs/dist-newstyle/cache/plan.json deleted file mode 100644 --- a/test/testdata/hieBiosMainIs/dist-newstyle/cache/plan.json +++ /dev/null @@ -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":[]}]} diff --git a/test/testdata/missingModuleTest/missingModule/dist-newstyle/cache/plan.json b/test/testdata/missingModuleTest/missingModule/dist-newstyle/cache/plan.json deleted file mode 100644 --- a/test/testdata/missingModuleTest/missingModule/dist-newstyle/cache/plan.json +++ /dev/null @@ -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":[]}]} diff --git a/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/cache/plan.json b/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/cache/plan.json deleted file mode 100644 --- a/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/cache/plan.json +++ /dev/null @@ -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":[]}]} diff --git a/test/utils/Test/Hls/Command.hs b/test/utils/Test/Hls/Command.hs --- a/test/utils/Test/Hls/Command.hs +++ b/test/utils/Test/Hls/Command.hs @@ -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 #-}