diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,267 @@ # Changelog for haskell-language-server +## 1.8.0.0 + +- Binaries for GHC 9.2.3 and GHC 9.2.4 +- Initial support for GHC 9.4 with binaries for GHC 9.4.1 and GHC 9.4.2 +- Startup time and performance improvements on projects using Template Haskell by serializing intermediate core (#2813) +- Memory usage improvements due to using a packed representation for filepaths (#3067, @kokobd) +- Improvements for hls-class-plugin (#2920, @July541) +- The new hls-gadt-plugin (#2899, @July541) +- Moving code actions from ghcide to the new hls-refactor-plugin (#3091, @wz1000) +- Many more improvements and bug fixes thanks to our contributors! + +### Pull requests merged for 1.8.0.0 + +- Alternate Number Format Plugin buildable with GHC 9.4 +([#3138](https://github.com/haskell/haskell-language-server/pull/3138)) by @drsooch +- Enable a bunch of plugins that build with ghc 9.4 +([#3136](https://github.com/haskell/haskell-language-server/pull/3136)) by @pepeiborra +- Enable support for 9.4 on windows +([#3132](https://github.com/haskell/haskell-language-server/pull/3132)) by @wz1000 +- flake.nix Add ghcide-bench to sourceDirs +([#3125](https://github.com/haskell/haskell-language-server/pull/3125)) by @akshaymankar +- Update hls-retrie-plugin to be usable with 9.2.4. +([#3120](https://github.com/haskell/haskell-language-server/pull/3120)) by @drsooch +- Add link to homepage and issues for `hie-compat` +([#3119](https://github.com/haskell/haskell-language-server/pull/3119)) by @parsonsmatt +- Remove pluginId from getNormalizedFilePath error message +([#3118](https://github.com/haskell/haskell-language-server/pull/3118)) by @drsooch +- HLS benchmarks +([#3117](https://github.com/haskell/haskell-language-server/pull/3117)) by @pepeiborra +- Fix --testing +([#3113](https://github.com/haskell/haskell-language-server/pull/3113)) by @pepeiborra +- Deduplicate HLS plugins +([#3112](https://github.com/haskell/haskell-language-server/pull/3112)) by @pepeiborra +- Do not send Heap Stats to the LSP log +([#3111](https://github.com/haskell/haskell-language-server/pull/3111)) by @pepeiborra +- Send begin progress message synchronously +([#3110](https://github.com/haskell/haskell-language-server/pull/3110)) by @pepeiborra +- Remove unused config in hls-class-plugin +([#3107](https://github.com/haskell/haskell-language-server/pull/3107)) by @July541 +- Support fourmolu-0.8.1.0 +([#3103](https://github.com/haskell/haskell-language-server/pull/3103)) by @brandonchinn178 +- Probe-tools: Print stack ghc version +([#3093](https://github.com/haskell/haskell-language-server/pull/3093)) by @andys8 +- Fix #3047 +([#3092](https://github.com/haskell/haskell-language-server/pull/3092)) by @July541 +- Remove exactprint dependencies from ghcide by introducing hls-refactor-plugin. +([#3091](https://github.com/haskell/haskell-language-server/pull/3091)) by @wz1000 +- Stan: Avoid terminal colors in messages +([#3090](https://github.com/haskell/haskell-language-server/pull/3090)) by @andys8 +- Support ghc-9.2.4 +([#3085](https://github.com/haskell/haskell-language-server/pull/3085)) by @July541 +- Bump Nix flake GHC 9.2.3 to 9.2.4 +([#3081](https://github.com/haskell/haskell-language-server/pull/3081)) by @cydparser +- fix lsp-types benchmark +([#3079](https://github.com/haskell/haskell-language-server/pull/3079)) by @pepeiborra +- Add support for Fourmolu 0.8 +([#3078](https://github.com/haskell/haskell-language-server/pull/3078)) by @brandonchinn178 +- upgrade lsp to 1.5 +([#3072](https://github.com/haskell/haskell-language-server/pull/3072)) by @kokobd +- Bump actions/cache from 2 to 3 +([#3071](https://github.com/haskell/haskell-language-server/pull/3071)) by @dependabot[bot] +- Bump actions/setup-python from 3 to 4 +([#3070](https://github.com/haskell/haskell-language-server/pull/3070)) by @dependabot[bot] +- Run the benchmark suite on GHC 9.2.3 +([#3069](https://github.com/haskell/haskell-language-server/pull/3069)) by @pepeiborra +- Simplify instructions about 'ghcup compile hls' +([#3068](https://github.com/haskell/haskell-language-server/pull/3068)) by @hasufell +- Improve performance of NormalizedFilePath +([#3067](https://github.com/haskell/haskell-language-server/pull/3067)) by @kokobd +- add a prefix to plugin CPP definitions +([#3065](https://github.com/haskell/haskell-language-server/pull/3065)) by @kokobd +- Add Github precommit workflow +([#3060](https://github.com/haskell/haskell-language-server/pull/3060)) by @lunaticare +- Run pre-commit hooks +([#3059](https://github.com/haskell/haskell-language-server/pull/3059)) by @lunaticare +- Fix grammar and spelling errors in configuration.md +([#3056](https://github.com/haskell/haskell-language-server/pull/3056)) by @arsenkhy +- Remove redundant WARNING prefix +([#3055](https://github.com/haskell/haskell-language-server/pull/3055)) by @michaelpj +- fix a typo in src/Ide/Plugin/Class/CodeLens.hs +([#3053](https://github.com/haskell/haskell-language-server/pull/3053)) by @tensorknower69 +- fix record-dot-syntax test +([#3051](https://github.com/haskell/haskell-language-server/pull/3051)) by @coltenwebb +- build(nix): ghc922 -> ghc923 +([#3049](https://github.com/haskell/haskell-language-server/pull/3049)) by @teto +- build(nix): bumped gitignore dependency +([#3048](https://github.com/haskell/haskell-language-server/pull/3048)) by @teto +- Update issue templates +([#3044](https://github.com/haskell/haskell-language-server/pull/3044)) by @michaelpj +- Simplify hlint config +([#3038](https://github.com/haskell/haskell-language-server/pull/3038)) by @michaelpj +- handle trailing comma in import list properly +([#3035](https://github.com/haskell/haskell-language-server/pull/3035)) by @kokobd +- upgrade ghc-check to fix #3002 +([#3034](https://github.com/haskell/haskell-language-server/pull/3034)) by @kokobd +- Fix Stack build with Nix on macOS +([#3031](https://github.com/haskell/haskell-language-server/pull/3031)) by @lunaticare +- haskell-language-server: add lower bound for githash +([#3030](https://github.com/haskell/haskell-language-server/pull/3030)) by @Bodigrim +- hls-eval-plugin: add lower bound for parser-combinators +([#3029](https://github.com/haskell/haskell-language-server/pull/3029)) by @Bodigrim +- hls-fourmolu-plugin: add lower bound for process-extras +([#3028](https://github.com/haskell/haskell-language-server/pull/3028)) by @Bodigrim +- ghcide: lower bounds +([#3025](https://github.com/haskell/haskell-language-server/pull/3025)) by @Bodigrim +- remove all usages of pre-commit-check in nix +([#3024](https://github.com/haskell/haskell-language-server/pull/3024)) by @kokobd +- hls-plugin-api: add lower bounds +([#3022](https://github.com/haskell/haskell-language-server/pull/3022)) by @Bodigrim +- hls-graph: add lower bound for async +([#3021](https://github.com/haskell/haskell-language-server/pull/3021)) by @Bodigrim +- Hlint: CodeAction with isPreferred +([#3018](https://github.com/haskell/haskell-language-server/pull/3018)) by @andys8 +- Record Dot Hover Types +([#3016](https://github.com/haskell/haskell-language-server/pull/3016)) by @coltenwebb +- re-enable haddock +([#3015](https://github.com/haskell/haskell-language-server/pull/3015)) by @kokobd +- add Helix to configuration.md +([#3014](https://github.com/haskell/haskell-language-server/pull/3014)) by @0rphee +- Renaming of indirect references (RecordFieldPuns) +([#3013](https://github.com/haskell/haskell-language-server/pull/3013)) by @OliverMadine +- Revert back to Warning not Error in Logging `ResponseErrors` +([#3009](https://github.com/haskell/haskell-language-server/pull/3009)) by @drsooch +- Disable flaky test on Windows +([#3008](https://github.com/haskell/haskell-language-server/pull/3008)) by @michaelpj +- Improve troubleshooting and installation docs a bit +([#3004](https://github.com/haskell/haskell-language-server/pull/3004)) by @michaelpj +- refactor selection range plugin +([#3003](https://github.com/haskell/haskell-language-server/pull/3003)) by @kokobd +- Hlint more partial functions, and Debug.Trace +([#3000](https://github.com/haskell/haskell-language-server/pull/3000)) by @michaelpj +- Don't use typecheck rule for non FOIs in refine imports plugin +([#2995](https://github.com/haskell/haskell-language-server/pull/2995)) by @wz1000 +- GHC 9.4 compatibility + Multiple Home Units +([#2994](https://github.com/haskell/haskell-language-server/pull/2994)) by @wz1000 +- unify pre-commit hook & update Gitpod config +([#2991](https://github.com/haskell/haskell-language-server/pull/2991)) by @kokobd +- Log response errors returned from Plugins +([#2988](https://github.com/haskell/haskell-language-server/pull/2988)) by @drsooch +- Add associated type families to local completions +([#2987](https://github.com/haskell/haskell-language-server/pull/2987)) by @gasparattila +- Remove some partial functions from Shake.hs +([#2986](https://github.com/haskell/haskell-language-server/pull/2986)) by @michaelpj +- Clean up ghc-9.0 partial support contents +([#2983](https://github.com/haskell/haskell-language-server/pull/2983)) by @July541 +- fix new import position +([#2981](https://github.com/haskell/haskell-language-server/pull/2981)) by @kokobd +- Implement PluginMethod for hard-wired in handlers +([#2977](https://github.com/haskell/haskell-language-server/pull/2977)) by @fendor +- Set up partial functions ratchet +([#2974](https://github.com/haskell/haskell-language-server/pull/2974)) by @michaelpj +- Turn HLS-wrapper into an LSP Server +([#2960](https://github.com/haskell/haskell-language-server/pull/2960)) by @smatting +- More Fourmolu improvements +([#2959](https://github.com/haskell/haskell-language-server/pull/2959)) by @georgefst +- hls-class-plugin: Only create placeholders for unimplemented methods +([#2956](https://github.com/haskell/haskell-language-server/pull/2956)) by @akshaymankar +- Fix Fourmolu 0.7 support +([#2950](https://github.com/haskell/haskell-language-server/pull/2950)) by @georgefst +- Teach HLS about different file extensions +([#2945](https://github.com/haskell/haskell-language-server/pull/2945)) by @fendor +- Support `fourmolu ^>= 0.7` +([#2944](https://github.com/haskell/haskell-language-server/pull/2944)) by @parsonsmatt +- hls-explicit-fixity-plugin +([#2941](https://github.com/haskell/haskell-language-server/pull/2941)) by @July541 +- chore(nix): bump nixpkgs to prevent glibc issues +([#2937](https://github.com/haskell/haskell-language-server/pull/2937)) by @teto +- Support ghc-9.2.3 +([#2936](https://github.com/haskell/haskell-language-server/pull/2936)) by @July541 +- Typo fix, dependecies -> dependencies +([#2934](https://github.com/haskell/haskell-language-server/pull/2934)) by @vikrem +- Update Archlinux installation section +([#2933](https://github.com/haskell/haskell-language-server/pull/2933)) by @marcin-rzeznicki +- docs/installation: Remove unused clone with submodule command +([#2930](https://github.com/haskell/haskell-language-server/pull/2930)) by @sloorush +- Omit more parens for wildcard type signature +([#2929](https://github.com/haskell/haskell-language-server/pull/2929)) by @sergv +- Add `throwPluginError` to Plugin Utilities +([#2924](https://github.com/haskell/haskell-language-server/pull/2924)) by @drsooch +- hls-class-plugin enhancement +([#2920](https://github.com/haskell/haskell-language-server/pull/2920)) by @July541 +- Bump documentation requirements +([#2918](https://github.com/haskell/haskell-language-server/pull/2918)) by @xsebek +- Document eval plugin limitations +([#2917](https://github.com/haskell/haskell-language-server/pull/2917)) by @xsebek +- Replace TextDocumentIdentifier with Uri in getNormalizedFilePath +([#2912](https://github.com/haskell/haskell-language-server/pull/2912)) by @July541 +- Fix hover format +([#2911](https://github.com/haskell/haskell-language-server/pull/2911)) by @July541 +- Fix multiline eval plugin padding +([#2910](https://github.com/haskell/haskell-language-server/pull/2910)) by @xsebek +- Stan integration #258 +([#2908](https://github.com/haskell/haskell-language-server/pull/2908)) by @uhbif19 +- A plugin for GADT syntax converter +([#2899](https://github.com/haskell/haskell-language-server/pull/2899)) by @July541 +- Fix DisplayTHWarning error +([#2895](https://github.com/haskell/haskell-language-server/pull/2895)) by @pepeiborra +- Enable hls-eval-plugin test on ghc-9.2.2 +([#2893](https://github.com/haskell/haskell-language-server/pull/2893)) by @July541 +- nix update +([#2892](https://github.com/haskell/haskell-language-server/pull/2892)) by @michaelpj +- Build hls-alternate-number-format-plugin with stack.yaml +([#2891](https://github.com/haskell/haskell-language-server/pull/2891)) by @July541 +- Modify ghcide requirements of hls-change-type-signature-plugin +([#2889](https://github.com/haskell/haskell-language-server/pull/2889)) by @July541 +- Fix hls-call-hierarchy-plugin tests +([#2888](https://github.com/haskell/haskell-language-server/pull/2888)) by @July541 +- Add .txt files as extra-source-files for hls-change-type-signature-plugin +([#2887](https://github.com/haskell/haskell-language-server/pull/2887)) by @cdepillabout +- Prefer Data.HashSet.member to Data.Foldable.elem +([#2886](https://github.com/haskell/haskell-language-server/pull/2886)) by @sergv +- no longer disable -dynamic in CI +([#2885](https://github.com/haskell/haskell-language-server/pull/2885)) by @pepeiborra +- hls-pragmas-plugin requires ghcide >= 1.7 +([#2884](https://github.com/haskell/haskell-language-server/pull/2884)) by @Bodigrim +- Make iface-error-test-1 less flaky +([#2882](https://github.com/haskell/haskell-language-server/pull/2882)) by @pepeiborra +- hls-haddock-comments does not support ghc-exactprint >= 1.0 +([#2878](https://github.com/haskell/haskell-language-server/pull/2878)) by @Bodigrim +- Restore compat. with prettyprinter 1.6 +([#2877](https://github.com/haskell/haskell-language-server/pull/2877)) by @pepeiborra +- ghcide requires ghc-exactprint >= 1.4 +([#2876](https://github.com/haskell/haskell-language-server/pull/2876)) by @Bodigrim +- ghcide needs prettyprinter-1.7 to build +([#2875](https://github.com/haskell/haskell-language-server/pull/2875)) by @juhp +- Review project stack descriptors according to #2533 +([#2874](https://github.com/haskell/haskell-language-server/pull/2874)) by @pepeiborra +- hls-call-hierarchy-plugin Patch release +([#2873](https://github.com/haskell/haskell-language-server/pull/2873)) by @pepeiborra +- Expand input to pragma if available +([#2871](https://github.com/haskell/haskell-language-server/pull/2871)) by @July541 +- Fix hanging redundant import on Unicode function +([#2870](https://github.com/haskell/haskell-language-server/pull/2870)) by @drsooch +- Compatibility with older aeson releases +([#2868](https://github.com/haskell/haskell-language-server/pull/2868)) by @pepeiborra +- simplify hlint plugin Cabal descriptor +([#2867](https://github.com/haskell/haskell-language-server/pull/2867)) by @pepeiborra +- Consolidate all cabal.project files +([#2866](https://github.com/haskell/haskell-language-server/pull/2866)) by @pepeiborra +- release script fixes +([#2861](https://github.com/haskell/haskell-language-server/pull/2861)) by @wz1000 +- Support hls-hlint-plugin and hls-stylish-plugin for ghc9.0 and ghc9.2 +([#2854](https://github.com/haskell/haskell-language-server/pull/2854)) by @July541 +- Bump haskell/actions from 1 to 2 +([#2852](https://github.com/haskell/haskell-language-server/pull/2852)) by @dependabot[bot] +- Add scripts for releases and final 1.7 tweaks +([#2850](https://github.com/haskell/haskell-language-server/pull/2850)) by @wz1000 +- Fix Completion document format +([#2848](https://github.com/haskell/haskell-language-server/pull/2848)) by @July541 +- Improve name export code action +([#2847](https://github.com/haskell/haskell-language-server/pull/2847)) by @sergv +- Update plugin support table +([#2840](https://github.com/haskell/haskell-language-server/pull/2840)) by @michaelpj +- Unify showSDocUnsafe +([#2830](https://github.com/haskell/haskell-language-server/pull/2830)) by @July541 +- ghcide: remove redundant env NIX_GHC_LIBDIR +([#2819](https://github.com/haskell/haskell-language-server/pull/2819)) by @sloorush +- Serialize Core +([#2813](https://github.com/haskell/haskell-language-server/pull/2813)) by @wz1000 +- Expose runtime metrics via EKG +([#2267](https://github.com/haskell/haskell-language-server/pull/2267)) by @pepeiborra + ## 1.7.0.0 - Distribute dynamically linked binaries for HLS to avoid statically linking against GLIBC diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -30,6 +30,7 @@ - [Features](https://haskell-language-server.readthedocs.io/en/latest/features.html) - [Installation](https://haskell-language-server.readthedocs.io/en/latest/installation.html) +- [Supported GHC Versions](https://haskell-language-server.readthedocs.io/en/latest/supported-versions.html) - [Configuration](https://haskell-language-server.readthedocs.io/en/latest/configuration.html) - [Troubleshooting](https://haskell-language-server.readthedocs.io/en/latest/troubleshooting.html) - [Contributing](https://haskell-language-server.readthedocs.io/en/latest/contributing/index.html) diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,282 @@ + +{- Bench history + + A Shake script to analyze the performance of HLS over the git history of the project + + Driven by a config file `bench/config.yaml` containing the list of Git references to analyze. + + Builds each one of them and executes a set of experiments using the ghcide-bench suite. + + The results of the benchmarks and the analysis are recorded in the file + system with the following structure: + + bench-results + ├── + │  ├── ghc.path - path to ghc used to build the binary + │  └── haskell-language-server - binary for this version + ├─ + │ ├── results.csv - aggregated results for all the versions + │ └── + | └── + │   ├── .gcStats.log - RTS -s output + │   ├── .csv - stats for the experiment + │   ├── .svg - Graph of bytes over elapsed time + │   ├── .diff.svg - idem, including the previous version + │   ├── .log - ghcide-bench output + │   └── results.csv - results of all the experiments for the example + ├── results.csv - aggregated results of all the experiments and versions + └── .svg - graph of bytes over elapsed time, for all the included versions + + For diff graphs, the "previous version" is the preceding entry in the list of versions + in the config file. A possible improvement is to obtain this info via `git rev-list`. + + To execute the script: + + > cabal/stack bench + + To build a specific analysis, enumerate the desired file artifacts + + > stack bench --ba "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg" + > cabal bench --benchmark-options "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg" + + -} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wno-orphans #-} +{-# LANGUAGE PackageImports #-} + +import Control.Lens (preview, (^.)) +import Control.Monad.Extra +import Data.Aeson (Value (..), encode) +import Data.Aeson.Lens +import Data.Default +import Data.Foldable (find) +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Text (pack, unpack) +import Data.Yaml (FromJSON (..), ToJSON (toJSON), + decodeFileThrow) +import Development.Benchmark.Rules hiding (parallelism) +import Development.Shake (Action, + Change (ChangeModtimeAndDigestInput), + CmdOption (Cwd, StdinBS), + RuleResult, Rules, + ShakeOptions (shakeChange, shakeThreads), + actionBracket, addOracle, + askOracle, command, command_, + getDirectoryFiles, liftIO, need, + newCache, shakeArgsWith, + shakeOptions, versioned, want) +import Development.Shake.Classes +import Experiments.Types (Example (exampleName), + exampleToOptions) +import GHC.Exts (toList) +import GHC.Generics (Generic) +import HlsPlugins (idePlugins) +import qualified Ide.Plugin.Config as Plugin +import Ide.Types +import Numeric.Natural (Natural) +import System.Console.GetOpt +import System.Directory +import System.FilePath +import System.IO.Error (tryIOError) + +configPath :: FilePath +configPath = "bench/config.yaml" + +configOpt :: OptDescr (Either String FilePath) +configOpt = Option [] ["config"] (ReqArg Right configPath) "config file" + +binaryName :: String +binaryName = "haskell-language-server" + +-- | Read the config without dependency +readConfigIO :: FilePath -> IO (Config BuildSystem) +readConfigIO = decodeFileThrow + +instance IsExample Example where getExampleName = exampleName +type instance RuleResult GetExample = Maybe Example +type instance RuleResult GetExamples = [Example] + +shakeOpts :: ShakeOptions +shakeOpts = + shakeOptions{shakeChange = ChangeModtimeAndDigestInput, shakeThreads = 0} + +main :: IO () +main = shakeArgsWith shakeOpts [configOpt] $ \configs wants -> pure $ Just $ do + let config = fromMaybe configPath $ listToMaybe configs + _configStatic <- createBuildSystem config + case wants of + [] -> want ["all"] + _ -> want wants + +hlsBuildRules :: MkBuildRules BuildSystem +hlsBuildRules = MkBuildRules findGhcForBuildSystem binaryName projectDepends buildHls + where + recordDepends path = + need . map (path ) =<< getDirectoryFiles path ["//*.hs"] + projectDepends = do + recordDepends "src" + recordDepends "exe" + recordDepends "plugins" + recordDepends "ghcide/session-loader" + recordDepends "ghcide/src" + recordDepends "hls-graph/src" + recordDepends "hls-plugin-api/src" + need =<< getDirectoryFiles "." ["*.cabal"] + +-------------------------------------------------------------------------------- +data Config buildSystem = Config + { experiments :: [Unescaped String], + configurations :: [ConfigurationDescriptor], + examples :: [Example], + samples :: Natural, + versions :: [GitCommit], + -- | Output folder ('foo' works, 'foo/bar' does not) + outputFolder :: String, + buildTool :: buildSystem, + profileInterval :: Maybe Double, + parallelism :: Natural + } + deriving (Generic, Show) + deriving anyclass (FromJSON) + +createBuildSystem :: FilePath -> Rules (Config BuildSystem) +createBuildSystem config = do + readConfig <- newCache $ \fp -> need [fp] >> liftIO (readConfigIO fp) + + _ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config + _ <- addOracle $ \GetVersions {} -> versions <$> readConfig config + _ <- versioned 1 $ addOracle $ \GetExamples{} -> examples <$> readConfig config + _ <- versioned 1 $ addOracle $ \(GetExample name) -> find (\e -> getExampleName e == name) . examples <$> readConfig config + _ <- addOracle $ \GetBuildSystem {} -> buildTool <$> readConfig config + _ <- addOracle $ \GetSamples{} -> samples <$> readConfig config + _ <- addOracle $ \GetConfigurations{} -> do + Config{configurations} <- readConfig config + return [ Configuration confName (encode $ disableAllPluginsBut (`elem` confPlugins)) + | ConfigurationDescriptor{..} <- configurations + ] + + configStatic <- liftIO $ readConfigIO config + let build = outputFolder configStatic + + buildRules build hlsBuildRules + benchRules build (MkBenchRules (askOracle $ GetSamples ()) benchHls warmupHls "haskell-language-server" (parallelism configStatic)) + csvRules build + svgRules build + heapProfileRules build + phonyRules "" binaryName NoProfiling build (examples configStatic) + + whenJust (profileInterval configStatic) $ \i -> do + phonyRules "profiled-" binaryName (CheapHeapProfiling i) build (examples configStatic) + + return configStatic + +disableAllPluginsBut :: (PluginId -> Bool) -> Plugin.Config +disableAllPluginsBut pred = def {Plugin.plugins = pluginsMap} where + pluginsMap = Map.fromList + [ (p, def { Plugin.plcGlobalOn = globalOn}) + | PluginDescriptor{pluginId = plugin@(PluginId p)} <- plugins + , let globalOn = + -- ghcide-core is required, nothing works without it + plugin == PluginId (pack "ghcide-core") + -- document symbols is required by the benchmark suite + || plugin == PluginId (pack "ghcide-hover-and-symbols") + || pred plugin + ] + IdePlugins plugins = idePlugins mempty + +newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show) +type instance RuleResult GetSamples = Natural + +-------------------------------------------------------------------------------- + +buildHls :: BuildSystem -> ProjectRoot -> OutputFolder -> Action () +buildHls Cabal root out = actionBracket + (do + projectLocalExists <- liftIO $ doesFileExist projectLocal + when projectLocalExists $ liftIO $ do + void $ tryIOError $ removeFile (projectLocal <.> "restore-after-benchmark") + renameFile projectLocal (projectLocal <.> "restore-after-benchmark") + liftIO $ writeFile projectLocal $ unlines + ["package haskell-language-server" + ," ghc-options: -eventlog -rtsopts" + ,"package ghcide" + ," flags: +ekg" + ] + return projectLocalExists) + (\projectLocalExists -> do + removeFile projectLocal + when projectLocalExists $ + renameFile (projectLocal <.> "restore-after-benchmark") projectLocal + ) $ \_ -> command_ [Cwd root] "cabal" + ["install" + ,"haskell-language-server:exe:haskell-language-server" + ,"--installdir=" ++ out + ,"--install-method=copy" + ,"--overwrite-policy=always" + ] + where + projectLocal = root "cabal.project.local" + +buildHls Stack root out = + command_ [Cwd root] "stack" + ["--local-bin-path=" <> out + ,"build" + ,"haskell-language-server:haskell-language-server" + ,"--copy-bins" + ,"--ghc-options=-rtsopts" + ,"--ghc-options=-eventlog" + ] + +benchHls + :: Natural -> BuildSystem -> [CmdOption] -> BenchProject Example -> Action () +benchHls samples buildSystem args BenchProject{..} = do + command_ ([StdinBS configuration] ++ args) "ghcide-bench" $ + [ "--timeout=300", + "--no-clean", + "-v", + "--samples=" <> show samples, + "--csv=" <> outcsv, + "--ghcide=" <> exePath, + "--select", + unescaped (unescapeExperiment experiment), + "--lsp-config" + ] ++ + exampleToOptions example exeExtraArgs ++ + [ "--stack" | Stack == buildSystem + ] + +warmupHls :: BuildSystem -> FilePath -> [CmdOption] -> Example -> Action () +warmupHls buildSystem exePath args example = do + command args "ghcide-bench" $ + [ "--no-clean", + "-v", + "--samples=1", + "--ghcide=" <> exePath, + "--select=hover" + ] ++ + exampleToOptions example [] ++ + [ "--stack" | Stack == buildSystem + ] + +-------------------------------------------------------------------------------- +data ConfigurationDescriptor = ConfigurationDescriptor + { confName :: String + , confPlugins :: [PluginId] + } + deriving Show + +instance FromJSON ConfigurationDescriptor where + parseJSON (String s) = pure $ ConfigurationDescriptor (unpack s) [PluginId s] + parseJSON o@Object{} = do + let keymap = o ^. _Object + matchKey = preview _String . toJSON + case toList keymap of + -- excuse the aeson 2.0 compatibility hack + [(matchKey -> Just name, Array values)] -> do + pluginIds <- traverse parseJSON values + pure $ ConfigurationDescriptor (unpack name) (map PluginId $ toList pluginIds) + other -> fail $ "Expected object with name and array of plugin ids: " <> show other + parseJSON _ = fail "Expected plugin id or object with name and array of plugin ids" diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,29 +1,42 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Main(main) where +import Control.Arrow ((&&&)) import Control.Monad.IO.Class (liftIO) import Data.Function ((&)) -import Data.Text (Text) -import qualified Development.IDE.Types.Logger as Logger -import Development.IDE.Types.Logger (Priority (Debug, Info, Error), +import Data.Text (Text) +import qualified Development.IDE.Main as GhcideMain +import Development.IDE.Types.Logger (Doc, + Priority (Debug, Error, Info), WithPriority (WithPriority, priority), cfilter, cmapWithPrio, + defaultLayoutOptions, + layoutPretty, makeDefaultStderrRecorder, - withDefaultRecorder, renderStrict, layoutPretty, defaultLayoutOptions, Doc) + payload, renderStrict, + withDefaultRecorder) +import qualified Development.IDE.Types.Logger as Logger +import qualified HlsPlugins as Plugins import Ide.Arguments (Arguments (..), GhcideArguments (..), getArguments) import Ide.Main (defaultMain) import qualified Ide.Main as IdeMain import Ide.PluginUtils (pluginDescToIdePlugins) -import Ide.Types (PluginDescriptor (pluginNotificationHandlers), defaultPluginDescriptor, mkPluginNotificationHandler) +import Ide.Types (PluginDescriptor (pluginNotificationHandlers), + defaultPluginDescriptor, + mkPluginNotificationHandler) import Language.LSP.Server as LSP import Language.LSP.Types as LSP -import qualified Plugins +#if MIN_VERSION_prettyprinter(1,7,0) import Prettyprinter (Pretty (pretty), vsep) +#else +import Data.Text.Prettyprint.Doc (Pretty (pretty), vsep) +#endif data Log = LogIdeMain IdeMain.Log @@ -39,7 +52,7 @@ -- plugin cli commands use stderr logger for now unless we change the args -- parser to get logging arguments first or do more complicated things pluginCliRecorder <- cmapWithPrio pretty <$> makeDefaultStderrRecorder Nothing Info - args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder) False) + args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder)) (lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder (lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder @@ -51,26 +64,30 @@ liftIO $ (cb1 <> cb2) env } - let (minPriority, logFilePath, includeExamplePlugins) = + let (argsTesting, minPriority, logFilePath) = case args of - Ghcide GhcideArguments{ argsTesting, argsDebugOn, argsLogFile, argsExamplePlugin } -> + Ghcide GhcideArguments{ argsTesting, argsDebugOn, argsLogFile} -> let minPriority = if argsDebugOn || argsTesting then Debug else Info - in (minPriority, argsLogFile, argsExamplePlugin) - _ -> (Info, Nothing, False) + in (argsTesting, minPriority, argsLogFile) + _ -> (False, Info, Nothing) withDefaultRecorder logFilePath Nothing minPriority $ \textWithPriorityRecorder -> do let - recorder = cmapWithPrio pretty $ mconcat + recorder = cmapWithPrio (pretty &&& id) $ mconcat [textWithPriorityRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority) + & cmapWithPrio fst , lspMessageRecorder & cfilter (\WithPriority{ priority } -> priority >= Error) - & cmapWithPrio renderDoc + & cmapWithPrio (renderDoc . fst) , lspLogRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority) - & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions) + & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions . fst) + -- do not log heap stats to the LSP log as they interfere with the + -- ability of lsp-test to detect a stuck server in tests and benchmarks + & if argsTesting then cfilter (not . heapStats . snd . payload) else id ] - plugins = (Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins) + plugins = (Plugins.idePlugins (cmapWithPrio LogPlugins recorder)) defaultMain (cmapWithPrio LogIdeMain recorder) @@ -85,3 +102,7 @@ issueTrackerUrl :: Doc a issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues" + +heapStats :: Log -> Bool +heapStats (LogIdeMain (IdeMain.LogIDEMain (GhcideMain.LogHeapStats _))) = True +heapStats _ = False diff --git a/exe/Plugins.hs b/exe/Plugins.hs deleted file mode 100644 --- a/exe/Plugins.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -module Plugins where - -import Development.IDE.Types.Logger (Pretty (pretty), Recorder, - WithPriority, cmapWithPrio) -import Ide.PluginUtils (pluginDescToIdePlugins) -import Ide.Types (IdePlugins) - --- fixed plugins -import Development.IDE (IdeState) -import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde -import qualified Ide.Plugin.Example as Example -import qualified Ide.Plugin.Example2 as Example2 - --- haskell-language-server optional plugins -#if qualifyImportedNames -import qualified Ide.Plugin.QualifyImportedNames as QualifyImportedNames -#endif - -#if callHierarchy -import qualified Ide.Plugin.CallHierarchy as CallHierarchy -#endif - -#if class -import qualified Ide.Plugin.Class as Class -#endif - -#if haddockComments -import qualified Ide.Plugin.HaddockComments as HaddockComments -#endif - -#if eval -import qualified Ide.Plugin.Eval as Eval -#endif - -#if importLens -import qualified Ide.Plugin.ExplicitImports as ExplicitImports -#endif - -#if refineImports -import qualified Ide.Plugin.RefineImports as RefineImports -#endif - -#if rename -import qualified Ide.Plugin.Rename as Rename -#endif - -#if retrie -import qualified Ide.Plugin.Retrie as Retrie -#endif - -#if tactic -import qualified Ide.Plugin.Tactic as Tactic -#endif - -#if hlint -import qualified Ide.Plugin.Hlint as Hlint -#endif - -#if moduleName -import qualified Ide.Plugin.ModuleName as ModuleName -#endif - -#if pragmas -import qualified Ide.Plugin.Pragmas as Pragmas -#endif - -#if splice -import qualified Ide.Plugin.Splice as Splice -#endif - -#if alternateNumberFormat -import qualified Ide.Plugin.AlternateNumberFormat as AlternateNumberFormat -#endif - -#if selectionRange -import Ide.Plugin.SelectionRange as SelectionRange -#endif - -#if changeTypeSignature -import Ide.Plugin.ChangeTypeSignature as ChangeTypeSignature -#endif --- formatters - -#if floskell -import qualified Ide.Plugin.Floskell as Floskell -#endif - -#if fourmolu -import qualified Ide.Plugin.Fourmolu as Fourmolu -#endif - -#if ormolu -import qualified Ide.Plugin.Ormolu as Ormolu -#endif - -#if stylishHaskell -import qualified Ide.Plugin.StylishHaskell as StylishHaskell -#endif - -#if brittany -import qualified Ide.Plugin.Brittany as Brittany -#endif - -data Log = forall a. (Pretty a) => Log a - -instance Pretty Log where - pretty (Log a) = pretty a - --- --------------------------------------------------------------------- - --- | The plugins configured for use in this instance of the language --- server. --- These can be freely added or removed to tailor the available --- features of the server. - -idePlugins :: Recorder (WithPriority Log) -> Bool -> IdePlugins IdeState -idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins - where - pluginRecorder :: forall log. (Pretty log) => Recorder (WithPriority log) - pluginRecorder = cmapWithPrio Log recorder - allPlugins = if includeExamples - then basePlugins ++ examplePlugins - else basePlugins - basePlugins = -#if pragmas - Pragmas.descriptor "pragmas" : -#endif -#if floskell - Floskell.descriptor "floskell" : -#endif -#if fourmolu - Fourmolu.descriptor "fourmolu" : -#endif -#if tactic - Tactic.descriptor pluginRecorder "tactics" : -#endif -#if ormolu - Ormolu.descriptor "ormolu" : -#endif -#if stylishHaskell - StylishHaskell.descriptor "stylish-haskell" : -#endif -#if rename - Rename.descriptor "rename" : -#endif -#if retrie - Retrie.descriptor "retrie" : -#endif -#if brittany - Brittany.descriptor "brittany" : -#endif -#if callHierarchy - CallHierarchy.descriptor "callHierarchy": -#endif -#if class - Class.descriptor "class" : -#endif -#if haddockComments - HaddockComments.descriptor "haddockComments" : -#endif -#if eval - Eval.descriptor pluginRecorder "eval" : -#endif -#if importLens - ExplicitImports.descriptor pluginRecorder "importLens" : -#endif -#if qualifyImportedNames - QualifyImportedNames.descriptor "qualifyImportedNames" : -#endif -#if refineImports - RefineImports.descriptor pluginRecorder "refineImports" : -#endif -#if moduleName - ModuleName.descriptor "moduleName" : -#endif -#if hlint - Hlint.descriptor pluginRecorder "hlint" : -#endif -#if splice - Splice.descriptor "splice" : -#endif -#if alternateNumberFormat - AlternateNumberFormat.descriptor pluginRecorder "alternateNumberFormat" : -#endif -#if selectionRange - SelectionRange.descriptor "selectionRange" : -#endif -#if changeTypeSignature - ChangeTypeSignature.descriptor "changeTypeSignature" : -#endif - -- The ghcide descriptors should come last so that the notification handlers - -- (which restart the Shake build) run after everything else - GhcIde.descriptors pluginRecorder - examplePlugins = - [Example.descriptor pluginRecorder "eg" - ,Example2.descriptor pluginRecorder "eg2" - ] diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -1,18 +1,25 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | This module is based on the hie-wrapper.sh script in -- https://github.com/alanz/vscode-hie-server module Main where import Control.Monad.Extra -import Data.Char (isSpace) +import Data.Char (isSpace) import Data.Default +import Data.Either.Extra (eitherToMaybe) import Data.Foldable import Data.List import Data.Void -import qualified Development.IDE.Session as Session -import qualified HIE.Bios.Environment as HieBios +import qualified Development.IDE.Session as Session +import qualified HIE.Bios.Environment as HieBios import HIE.Bios.Types import Ide.Arguments import Ide.Version @@ -20,14 +27,42 @@ import System.Environment import System.Exit import System.FilePath -import System.IO import System.Info +import System.IO #ifndef mingw32_HOST_OS -import System.Posix.Process (executeFile) -import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict as Map +import System.Posix.Process (executeFile) #else import System.Process #endif +import Control.Concurrent (tryPutMVar) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Trans.Except (ExceptT, runExceptT, + throwE) +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Development.IDE.LSP.LanguageServer (runLanguageServer) +import qualified Development.IDE.Main as Main +import Development.IDE.Types.Logger (Logger (Logger), + Pretty (pretty), + Priority (Info), + Recorder (logger_), + WithPriority (WithPriority), + cmapWithPrio, + makeDefaultStderrRecorder) +import GHC.Stack.Types (emptyCallStack) +import Ide.Plugin.Config (Config) +import Language.LSP.Server (LspM) +import qualified Language.LSP.Server as LSP +import Language.LSP.Types (MessageActionItem (MessageActionItem), + MessageType (MtError), + Method (Initialize), + RequestMessage, + ResponseError, + SMethod (SExit, SWindowShowMessageRequest), + ShowMessageRequestParams (ShowMessageRequestParams)) -- --------------------------------------------------------------------- @@ -44,6 +79,10 @@ putStrLn hlsVer putStrLn "Tool versions found on the $PATH" putStrLn $ showProgramVersionOfInterest programsOfInterest + putStrLn "Tool versions in your project" + cradle <- findProjectCradle' False + ghcVersion <- runExceptT $ getRuntimeGhcVersion' cradle + putStrLn $ showProgramVersion "ghc" $ mkVersion =<< eitherToMaybe ghcVersion VersionMode PrintVersion -> putStrLn hlsVer @@ -57,9 +96,15 @@ cradle <- findProjectCradle' False (CradleSuccess libdir) <- HieBios.getRuntimeGhcLibDir cradle putStr libdir - _ -> launchHaskellLanguageServer args + _ -> launchHaskellLanguageServer args >>= \case + Right () -> pure () + Left err -> do + T.hPutStrLn stderr (prettyError err NoShorten) + case args of + Ghcide _ -> launchErrorLSP (prettyError err Shorten) + _ -> pure () -launchHaskellLanguageServer :: Arguments -> IO () +launchHaskellLanguageServer :: Arguments -> IO (Either WrapperSetupError ()) launchHaskellLanguageServer parsedArgs = do case parsedArgs of Ghcide GhcideArguments{..} -> whenJust argsCwd setCurrentDirectory @@ -75,7 +120,10 @@ case parsedArgs of Ghcide GhcideArguments{..} -> - when argsProjectGhcVersion $ getRuntimeGhcVersion' cradle >>= putStrLn >> exitSuccess + when argsProjectGhcVersion $ do + runExceptT (getRuntimeGhcVersion' cradle) >>= \case + Right ghcVersion -> putStrLn ghcVersion >> exitSuccess + Left err -> T.putStrLn (prettyError err NoShorten) >> exitFailure _ -> pure () progName <- getProgName @@ -94,64 +142,74 @@ hPutStrLn stderr "" -- Get the ghc version -- this might fail! hPutStrLn stderr "Consulting the cradle to get project GHC version..." - ghcVersion <- getRuntimeGhcVersion' cradle - hPutStrLn stderr $ "Project GHC version: " ++ ghcVersion - let - hlsBin = "haskell-language-server-" ++ ghcVersion - candidates' = [hlsBin, "haskell-language-server"] - candidates = map (++ exeExtension) candidates' + runExceptT $ do + ghcVersion <- getRuntimeGhcVersion' cradle + liftIO $ hPutStrLn stderr $ "Project GHC version: " ++ ghcVersion - hPutStrLn stderr $ "haskell-language-server exe candidates: " ++ show candidates + let + hlsBin = "haskell-language-server-" ++ ghcVersion + candidates' = [hlsBin, "haskell-language-server"] + candidates = map (++ exeExtension) candidates' - mexes <- traverse findExecutable candidates + liftIO $ hPutStrLn stderr $ "haskell-language-server exe candidates: " ++ show candidates - case asum mexes of - Nothing -> die $ "Cannot find any haskell-language-server exe, looked for: " ++ intercalate ", " candidates - Just e -> do - hPutStrLn stderr $ "Launching haskell-language-server exe at:" ++ e + mexes <- liftIO $ traverse findExecutable candidates + + case asum mexes of + Nothing -> throwE (NoLanguageServer ghcVersion candidates) + Just e -> do + liftIO $ hPutStrLn stderr $ "Launching haskell-language-server exe at:" ++ e + #ifdef mingw32_HOST_OS - callProcess e args + liftIO $ callProcess e args #else - let Cradle { cradleOptsProg = CradleAction { runGhcCmd } } = cradle - -- we need to be compatible with NoImplicitPrelude - ghcBinary <- (fmap trim <$> runGhcCmd ["-v0", "-package-env=-", "-ignore-dot-ghci", "-e", "Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)"]) - >>= cradleResult "Failed to get project GHC executable path" - libdir <- HieBios.getRuntimeGhcLibDir cradle - >>= cradleResult "Failed to get project GHC libdir path" - env <- Map.fromList <$> getEnvironment - let newEnv = Map.insert "GHC_BIN" ghcBinary $ Map.insert "GHC_LIBDIR" libdir env - executeFile e True args (Just (Map.toList newEnv)) + + let Cradle { cradleOptsProg = CradleAction { runGhcCmd } } = cradle + + let cradleName = actionName (cradleOptsProg cradle) + -- we need to be compatible with NoImplicitPrelude + ghcBinary <- liftIO (fmap trim <$> runGhcCmd ["-v0", "-package-env=-", "-ignore-dot-ghci", "-e", "Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)"]) + >>= cradleResult cradleName + + libdir <- liftIO (HieBios.getRuntimeGhcLibDir cradle) + >>= cradleResult cradleName + + env <- Map.fromList <$> liftIO getEnvironment + let newEnv = Map.insert "GHC_BIN" ghcBinary $ Map.insert "GHC_LIBDIR" libdir env + liftIO $ executeFile e True args (Just (Map.toList newEnv)) #endif -cradleResult :: String -> CradleLoadResult a -> IO a -cradleResult _ (CradleSuccess a) = pure a -cradleResult str (CradleFail e) = die $ str ++ ": " ++ show e -cradleResult str CradleNone = die $ str ++ ": no cradle" +cradleResult :: ActionName Void -> CradleLoadResult a -> ExceptT WrapperSetupError IO a +cradleResult _ (CradleSuccess ver) = pure ver +cradleResult cradleName (CradleFail error) = throwE $ FailedToObtainGhcVersion cradleName error +cradleResult cradleName CradleNone = throwE $ NoneCradleGhcVersion cradleName + -- | Version of 'getRuntimeGhcVersion' that dies if we can't get it, and also -- checks to see if the tool is missing if it is one of -getRuntimeGhcVersion' :: Show a => Cradle a -> IO String +getRuntimeGhcVersion' :: Cradle Void -> ExceptT WrapperSetupError IO String getRuntimeGhcVersion' cradle = do + let cradleName = actionName (cradleOptsProg cradle) -- See if the tool is installed - case actionName (cradleOptsProg cradle) of + case cradleName of Stack -> checkToolExists "stack" Cabal -> checkToolExists "cabal" Default -> checkToolExists "ghc" Direct -> checkToolExists "ghc" _ -> pure () - HieBios.getRuntimeGhcVersion cradle >>= cradleResult "Failed to get project GHC version" + ghcVersionRes <- liftIO $ HieBios.getRuntimeGhcVersion cradle + cradleResult cradleName ghcVersionRes + where checkToolExists exe = do - exists <- findExecutable exe + exists <- liftIO $ findExecutable exe case exists of Just _ -> pure () - Nothing -> - die $ "Cradle requires " ++ exe ++ " but couldn't find it" ++ "\n" - ++ show cradle + Nothing -> throwE $ ToolRequirementMissing exe (actionName (cradleOptsProg cradle)) findProjectCradle :: IO (Cradle Void) findProjectCradle = findProjectCradle' True @@ -175,3 +233,85 @@ trim s = case lines s of [] -> s ls -> dropWhileEnd isSpace $ last ls + +data WrapperSetupError + = FailedToObtainGhcVersion (ActionName Void) CradleError + | NoneCradleGhcVersion (ActionName Void) + | NoLanguageServer String [FilePath] + | ToolRequirementMissing String (ActionName Void) + deriving (Show) + +data Shorten = Shorten | NoShorten + +-- | Pretty error message displayable to the future. +-- Extra argument 'Shorten' can be used to shorten error message. +-- Reduces usefulness, but allows us to show the error message via LSP +-- as LSP doesn't allow any newlines and makes it really hard to read +-- the message otherwise. +prettyError :: WrapperSetupError -> Shorten -> T.Text +prettyError (FailedToObtainGhcVersion name crdlError) shorten = + "Failed to find the GHC version of this " <> T.pack (show name) <> " project." <> + case shorten of + Shorten -> + "\n" <> T.pack (fromMaybe "" . listToMaybe $ cradleErrorStderr crdlError) + NoShorten -> + "\n" <> T.pack (intercalate "\n" (cradleErrorStderr crdlError)) +prettyError (NoneCradleGhcVersion name) _ = + "Failed to get the GHC version of this " <> T.pack (show name) <> + " project because a none cradle is configured" +prettyError (NoLanguageServer ghcVersion candidates) _ = + "Failed to find a HLS version for GHC " <> T.pack ghcVersion <> + "\nExecutable names we failed to find: " <> T.pack (intercalate "," candidates) +prettyError (ToolRequirementMissing toolExe name) _ = + "Failed to find executable \"" <> T.pack toolExe <> "\" in $PATH for this " <> T.pack (show name) <> " project." + +newtype ErrorLSPM c a = ErrorLSPM { unErrorLSPM :: (LspM c) a } + deriving (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, LSP.MonadLsp c) + +-- | Launches a LSP that displays an error and presents the user with a request +-- to shut down the LSP. +launchErrorLSP :: T.Text -> IO () +launchErrorLSP errorMsg = do + recorder <- makeDefaultStderrRecorder Nothing Info + + let logger = Logger $ \p m -> logger_ recorder (WithPriority p emptyCallStack (pretty m)) + + let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) logger + + inH <- Main.argsHandleIn defaultArguments + + outH <- Main.argsHandleOut defaultArguments + + let onConfigurationChange cfg _ = Right cfg + + let setup clientMsgVar = do + -- Forcefully exit + let exit = void $ tryPutMVar clientMsgVar () + + let doInitialize :: LSP.LanguageContextEnv Config -> RequestMessage Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv Config, ())) + doInitialize env _ = do + + let restartTitle = "Try to restart" + void $ LSP.runLspT env $ LSP.sendRequest SWindowShowMessageRequest (ShowMessageRequestParams MtError errorMsg (Just [MessageActionItem restartTitle])) $ \case + Right (Just (MessageActionItem title)) + | title == restartTitle -> liftIO exit + _ -> pure () + + pure (Right (env, ())) + + let asyncHandlers = mconcat + [ exitHandler exit ] + + let interpretHandler (env, _st) = LSP.Iso (LSP.runLspT env . unErrorLSPM) liftIO + pure (doInitialize, asyncHandlers, interpretHandler) + + runLanguageServer (cmapWithPrio pretty recorder) + (Main.argsLspOptions defaultArguments) + inH + outH + (Main.argsDefaultHlsConfig defaultArguments) + onConfigurationChange + setup + +exitHandler :: IO () -> LSP.Handlers (ErrorLSPM c) +exitHandler exit = LSP.notificationHandler SExit $ const $ liftIO exit 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: 2.4 +cabal-version: 3.0 category: Development name: haskell-language-server -version: 1.7.0.0 +version: 1.8.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 == 8.6.5 || == 8.8.4 || == 8.10.6 || == 8.10.7 || == 9.0.2 || == 9.2.2 +tested-with: GHC == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.3 || == 9.2.4 extra-source-files: README.md ChangeLog.md @@ -50,45 +50,6 @@ if flag(pedantic) ghc-options: -Werror -library - import: common-deps - -- configuration - , warnings - , pedantic - exposed-modules: - Ide.Arguments - Ide.Main - Ide.Version - - other-modules: Paths_haskell_language_server - autogen-modules: Paths_haskell_language_server - hs-source-dirs: src - build-depends: - , async - , base16-bytestring - , bytestring - , containers - , cryptohash-sha1 - , data-default - , ghc - , ghcide ^>=1.7 - , githash - , lsp - , hie-bios - , hiedb - , hls-plugin-api ^>=1.4 - , optparse-applicative - , optparse-simple - , process - , hls-graph - , safe-exceptions - , sqlite-simple - , unordered-containers - , aeson-pretty - - default-language: Haskell2010 - default-extensions: DataKinds, TypeOperators - -- Plugin flags are designed for 'cabal install haskell-language-server': -- - Bulk flags should be default:False -- - Individual flags should be default:True @@ -151,6 +112,11 @@ default: True manual: True +flag stan + description: Enable stan plugin + default: True + manual: True + flag moduleName description: Enable moduleName plugin default: True @@ -176,8 +142,8 @@ default: True manual: True -flag selectionRange - description: Enable selectionRange plugin +flag codeRange + description: Enable Code Range plugin default: True manual: True @@ -186,6 +152,16 @@ default: True manual: True +flag gadt + description: Enable gadt plugin + default: True + manual: True + +flag explicitFixity + description: Enable explicitFixity plugin + default: True + manual: True + -- formatters flag floskell @@ -213,161 +189,223 @@ default: True manual: True +flag refactor + description: Enable refactor plugin + default: True + manual: True + flag dynamic description: Build with the dyn rts default: True manual: True -common example-plugins - hs-source-dirs: plugins/default/src - other-modules: Ide.Plugin.Example, - Ide.Plugin.Example2 - common class - if flag(class) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds)) - build-depends: hls-class-plugin ^>= 1.0 - cpp-options: -Dclass + if flag(class) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds)) + build-depends: hls-class-plugin ^>= 1.1 + cpp-options: -Dhls_class common callHierarchy if flag(callHierarchy) - build-depends: hls-call-hierarchy-plugin ^>= 1.0 - cpp-options: -DcallHierarchy + build-depends: hls-call-hierarchy-plugin ^>= 1.1 + cpp-options: -Dhls_callHierarchy common haddockComments - if flag(haddockComments) - build-depends: hls-haddock-comments-plugin ^>= 1.0 - cpp-options: -DhaddockComments + if flag(haddockComments) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds)) + build-depends: hls-haddock-comments-plugin ^>= 1.1 + cpp-options: -Dhls_haddockComments common eval - if flag(eval) - build-depends: hls-eval-plugin ^>= 1.2 - cpp-options: -Deval + if flag(eval) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds)) + build-depends: hls-eval-plugin ^>= 1.3 + cpp-options: -Dhls_eval common importLens if flag(importLens) build-depends: hls-explicit-imports-plugin ^>= 1.1 - cpp-options: -DimportLens + cpp-options: -Dhls_importLens common refineImports if flag(refineImports) build-depends: hls-refine-imports-plugin ^>=1.0 - cpp-options: -DrefineImports + cpp-options: -Dhls_refineImports common rename - if flag(rename) + if flag(rename) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds)) build-depends: hls-rename-plugin ^>= 1.0 - cpp-options: -Drename + cpp-options: -Dhls_rename common retrie - if flag(retrie) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds)) + if flag(retrie) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds)) build-depends: hls-retrie-plugin ^>= 1.0 - cpp-options: -Dretrie + cpp-options: -Dhls_retrie common tactic - if flag(tactic) && (impl(ghc < 9.0.1) || flag(ignore-plugins-ghc-bounds)) - build-depends: hls-tactics-plugin >=1.2.0.0 && <1.7 - cpp-options: -Dtactic + if flag(tactic) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds)) + build-depends: hls-tactics-plugin ^>= 1.7 + cpp-options: -Dhls_tactic common hlint - if flag(hlint) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds)) - build-depends: hls-hlint-plugin ^>= 1.0 - cpp-options: -Dhlint + if flag(hlint) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds)) + build-depends: hls-hlint-plugin ^>= 1.1 + cpp-options: -Dhls_hlint +common stan + if flag(stan) && (impl(ghc >= 8.8) && impl(ghc < 9.0)) + build-depends: hls-stan-plugin ^>= 1.0 + cpp-options: -Dhls_stan + common moduleName if flag(moduleName) - build-depends: hls-module-name-plugin ^>= 1.0 - cpp-options: -DmoduleName + build-depends: hls-module-name-plugin ^>= 1.1 + cpp-options: -Dhls_moduleName common pragmas if flag(pragmas) build-depends: hls-pragmas-plugin ^>= 1.0 - cpp-options: -Dpragmas + cpp-options: -Dhls_pragmas common splice if flag(splice) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds)) build-depends: hls-splice-plugin ^>=1.0.0.1 - cpp-options: -Dsplice + cpp-options: -Dhls_splice common alternateNumberFormat - if flag(alternateNumberFormat) - build-depends: hls-alternate-number-format-plugin ^>= 1.1 - cpp-options: -DalternateNumberFormat + if flag(alternateNumberFormat) + build-depends: hls-alternate-number-format-plugin ^>= 1.2 + cpp-options: -Dhls_alternateNumberFormat common qualifyImportedNames if flag(qualifyImportedNames) build-depends: hls-qualify-imported-names-plugin ^>=1.0 - cpp-options: -DqualifyImportedNames + cpp-options: -Dhls_qualifyImportedNames -common selectionRange - if flag(selectionRange) - build-depends: hls-selection-range-plugin ^>= 1.0 - cpp-options: -DselectionRange +common codeRange + if flag(codeRange) + build-depends: hls-code-range-plugin ^>= 1.0 + cpp-options: -Dhls_codeRange common changeTypeSignature if flag(changeTypeSignature) build-depends: hls-change-type-signature-plugin ^>= 1.0 - cpp-options: -DchangeTypeSignature + cpp-options: -Dhls_changeTypeSignature +common gadt + if flag(gadt) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds)) + build-depends: hls-gadt-plugin ^>= 1.0 + cpp-options: -Dhls_gadt + +common explicitFixity + if flag(explicitFixity) + build-depends: hls-explicit-fixity-plugin ^>= 1.0 + cpp-options: -DexplicitFixity + -- formatters common floskell - if flag(floskell) + if flag(floskell) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds)) build-depends: hls-floskell-plugin ^>= 1.0 - cpp-options: -Dfloskell + cpp-options: -Dhls_floskell common fourmolu - if flag(fourmolu) - build-depends: hls-fourmolu-plugin ^>= 1.0 - cpp-options: -Dfourmolu + if flag(fourmolu) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds)) + build-depends: hls-fourmolu-plugin ^>= 1.1 + cpp-options: -Dhls_fourmolu common ormolu - if flag(ormolu) + if flag(ormolu) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds)) build-depends: hls-ormolu-plugin ^>= 1.0 - cpp-options: -Dormolu + cpp-options: -Dhls_ormolu common stylishHaskell - if flag(stylishHaskell) && (impl(ghc < 9.0.1) || flag(ignore-plugins-ghc-bounds)) + if flag(stylishHaskell) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds)) build-depends: hls-stylish-haskell-plugin ^>= 1.0 - cpp-options: -DstylishHaskell + cpp-options: -Dhls_stylishHaskell common brittany if flag(brittany) && (impl(ghc < 9.0.2) || flag(ignore-plugins-ghc-bounds)) build-depends: hls-brittany-plugin ^>= 1.0 - cpp-options: -Dbrittany + cpp-options: -Dhls_brittany -executable haskell-language-server - import: common-deps +common refactor + if flag(refactor) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds)) + build-depends: hls-refactor-plugin ^>= 1.0 + cpp-options: -Dhls_refactor + +library + import: common-deps -- configuration - , warnings - , pedantic - -- plugins - , example-plugins - , callHierarchy - , changeTypeSignature - , class - , haddockComments - , eval - , importLens - , refineImports - , rename - , retrie - , tactic - , hlint - , moduleName - , pragmas - , splice - , alternateNumberFormat - , qualifyImportedNames - , selectionRange - , floskell - , fourmolu - , ormolu - , stylishHaskell - , brittany + , warnings + , pedantic + -- plugins + , callHierarchy + , changeTypeSignature + , class + , haddockComments + , eval + , importLens + , refineImports + , rename + , retrie + , tactic + , hlint + , stan + , moduleName + , pragmas + , splice + , alternateNumberFormat + , qualifyImportedNames + , codeRange + , gadt + , explicitFixity + , floskell + , fourmolu + , ormolu + , stylishHaskell + , brittany + , refactor + exposed-modules: + Ide.Arguments + Ide.Main + Ide.Version + HlsPlugins + + other-modules: Paths_haskell_language_server + autogen-modules: Paths_haskell_language_server + hs-source-dirs: src + build-depends: + , async + , base16-bytestring + , bytestring + , containers + , cryptohash-sha1 + , data-default + , ghc + , ghcide ^>=1.8 + , githash >=0.1.6.1 + , lsp + , hie-bios + , hiedb + , hls-plugin-api ^>=1.5 + , optparse-applicative + , optparse-simple + , process + , hls-graph + , safe-exceptions + , sqlite-simple + , unordered-containers + , aeson-pretty + + default-language: Haskell2010 + default-extensions: DataKinds, TypeOperators + +executable haskell-language-server + import: common-deps + -- configuration + , warnings + , pedantic main-is: Main.hs hs-source-dirs: exe - other-modules: Plugins ghc-options: -threaded @@ -448,10 +486,17 @@ , ghcide , gitrev , haskell-language-server + , hslogger , hie-bios + , hls-plugin-api + , lsp + , lsp-types + , mtl , optparse-applicative , optparse-simple , process + , transformers + , unliftio-core if !os(windows) build-depends: unix @@ -464,6 +509,7 @@ import: common-deps , warnings , pedantic + , refactor type: exitcode-stdio-1.0 default-language: Haskell2010 build-tool-depends: @@ -477,7 +523,7 @@ , lens , lens-aeson , ghcide - , hls-test-utils ^>=1.3 + , hls-test-utils ^>=1.4 , lsp-types , aeson , hls-plugin-api @@ -513,14 +559,14 @@ -- Duplicating inclusion plugin conditions until tests are moved to their own packages if flag(eval) - cpp-options: -Deval + cpp-options: -Dhls_eval -- formatters if flag(floskell) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds)) - cpp-options: -Dfloskell + cpp-options: -Dhls_floskell if flag(fourmolu) - cpp-options: -Dfourmolu + cpp-options: -Dhls_fourmolu if flag(ormolu) - cpp-options: -Dormolu + cpp-options: -Dhls_ormolu test-suite wrapper-test import: common-deps @@ -538,3 +584,47 @@ hs-source-dirs: test/wrapper main-is: Main.hs + +benchmark benchmark + type: exitcode-stdio-1.0 + default-language: Haskell2010 + ghc-options: -Wall -Wno-name-shadowing -threaded + main-is: Main.hs + hs-source-dirs: bench + build-tool-depends: + ghcide-bench:ghcide-bench, + hp2pretty:hp2pretty, + implicit-hie:gen-hie + default-extensions: + BangPatterns + DeriveFunctor + DeriveGeneric + FlexibleContexts + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns + + build-depends: + aeson, + base == 4.*, + containers, + data-default, + directory, + extra, + filepath, + ghcide-bench, + haskell-language-server, + hls-plugin-api, + lens, + lens-aeson, + optparse-applicative, + shake, + shake-bench == 0.1.*, + text, + yaml diff --git a/plugins/default/src/Ide/Plugin/Example.hs b/plugins/default/src/Ide/Plugin/Example.hs deleted file mode 100644 --- a/plugins/default/src/Ide/Plugin/Example.hs +++ /dev/null @@ -1,253 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module Ide.Plugin.Example - ( - descriptor - , Log(..) - ) where - -import Control.Concurrent.STM -import Control.DeepSeq (NFData) -import Control.Monad.IO.Class -import Control.Monad.Trans.Maybe -import Data.Aeson -import Data.Functor -import qualified Data.HashMap.Strict as Map -import Data.Hashable -import qualified Data.Text as T -import Data.Typeable -import Development.IDE as D -import Development.IDE.Core.Shake (getDiagnostics, - getHiddenDiagnostics) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.GHC.Compat -import GHC.Generics -import Ide.PluginUtils -import Ide.Types -import Language.LSP.Server -import Language.LSP.Types -import Options.Applicative (ParserInfo, info) -import Text.Regex.TDFA.Text () - --- --------------------------------------------------------------------- - -newtype Log = LogShake Shake.Log deriving Show - -instance Pretty Log where - pretty = \case - LogShake log -> pretty log - -descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginRules = exampleRules recorder - , pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] - , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction - <> mkPluginHandler STextDocumentCodeLens codeLens - <> mkPluginHandler STextDocumentHover hover - <> mkPluginHandler STextDocumentDocumentSymbol symbols - <> mkPluginHandler STextDocumentCompletion completion - , pluginCli = Just exampleCli - } - -exampleCli :: ParserInfo (IdeCommand IdeState) -exampleCli = info p mempty - where p = pure $ IdeCommand $ \_ideState -> putStrLn "hello HLS" - --- --------------------------------------------------------------------- - -hover :: PluginMethodHandler IdeState TextDocumentHover -hover ide _ HoverParams{..} = liftIO $ request "Hover" blah (Right Nothing) foundHover ide TextDocumentPositionParams{..} - -blah :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text])) -blah _ (Position line col) - = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover 1\n"]) - --- --------------------------------------------------------------------- --- Generating Diagnostics via rules --- --------------------------------------------------------------------- - -data Example = Example - deriving (Eq, Show, Typeable, Generic) -instance Hashable Example -instance NFData Example - -type instance RuleResult Example = () - -exampleRules :: Recorder (WithPriority Log) -> Rules () -exampleRules recorder = do - define (cmapWithPrio LogShake recorder) $ \Example file -> do - _pm <- getParsedModule file - let diag = mkDiag file "example" DsError (Range (Position 0 0) (Position 1 0)) "example diagnostic, hello world" - return ([diag], Just ()) - - action $ do - files <- getFilesOfInterestUntracked - void $ uses Example $ Map.keys files - -mkDiag :: NormalizedFilePath - -> DiagnosticSource - -> DiagnosticSeverity - -> Range - -> T.Text - -> FileDiagnostic -mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) - Diagnostic - { _range = loc - , _severity = Just sev - , _source = Just diagSource - , _message = msg - , _code = Nothing - , _tags = Nothing - , _relatedInformation = Nothing - } - --- --------------------------------------------------------------------- --- code actions --- --------------------------------------------------------------------- - --- | Generate code actions. -codeAction :: PluginMethodHandler IdeState TextDocumentCodeAction -codeAction state _pid (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs}) = liftIO $ do - let mbnfp = uriToNormalizedFilePath $ toNormalizedUri uri - case mbnfp of - Just nfp -> do - Just (ParsedModule{},_) <- runIdeAction "example" (shakeExtras state) $ useWithStaleFast GetParsedModule nfp - let - title = "Add TODO Item 1" - tedit = [TextEdit (Range (Position 2 0) (Position 2 0)) - "-- TODO1 added by Example Plugin directly\n"] - edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing - pure $ Right $ List - [ InR $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) Nothing Nothing (Just edit) Nothing Nothing] - Nothing -> error $ "Unable to get a normalized file path from the uri: " ++ show uri - --- --------------------------------------------------------------------- - -codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens -codeLens ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = liftIO $ do - logInfo (ideLogger ideState) "Example.codeLens entered (ideLogger)" -- AZ - case uriToFilePath' uri of - Just (toNormalizedFilePath -> filePath) -> do - _ <- runIdeAction "Example.codeLens" (shakeExtras ideState) $ runMaybeT $ useE TypeCheck filePath - _diag <- atomically $ getDiagnostics ideState - _hDiag <- atomically $ getHiddenDiagnostics ideState - let - title = "Add TODO Item via Code Lens" - -- tedit = [TextEdit (Range (Position 3 0) (Position 3 0)) - -- "-- TODO added by Example Plugin via code lens action\n"] - -- edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing - range = Range (Position 3 0) (Position 4 0) - let cmdParams = AddTodoParams uri "do abc" - cmd = mkLspCommand plId "codelens.todo" title (Just [toJSON cmdParams]) - pure $ Right $ List [ CodeLens range (Just cmd) Nothing ] - Nothing -> pure $ Right $ List [] - --- --------------------------------------------------------------------- --- | Parameters for the addTodo PluginCommand. -data AddTodoParams = AddTodoParams - { file :: Uri -- ^ Uri of the file to add the pragma to - , todoText :: T.Text - } - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -addTodoCmd :: CommandFunction IdeState AddTodoParams -addTodoCmd _ide (AddTodoParams uri todoText) = do - let - pos = Position 3 0 - textEdits = List - [TextEdit (Range pos pos) - ("-- TODO:" <> todoText <> "\n") - ] - res = WorkspaceEdit - (Just $ Map.singleton uri textEdits) - Nothing - Nothing - _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing res) (\_ -> pure ()) - return $ Right Null - --- --------------------------------------------------------------------- - -foundHover :: (Maybe Range, [T.Text]) -> Either ResponseError (Maybe Hover) -foundHover (mbRange, contents) = - Right $ Just $ Hover (HoverContents $ MarkupContent MkMarkdown - $ T.intercalate sectionSeparator contents) mbRange - - --- | Respond to and log a hover or go-to-definition request -request - :: T.Text - -> (NormalizedFilePath -> Position -> Action (Maybe a)) - -> Either ResponseError b - -> (a -> Either ResponseError b) - -> IdeState - -> TextDocumentPositionParams - -> IO (Either ResponseError b) -request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = do - mbResult <- case uriToFilePath' uri of - Just path -> logAndRunRequest label getResults ide pos path - Nothing -> pure Nothing - pure $ maybe notFound found mbResult - -logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) - -> IdeState -> Position -> String -> IO b -logAndRunRequest label getResults ide pos path = do - let filePath = toNormalizedFilePath path - logInfo (ideLogger ide) $ - label <> " request at position " <> T.pack (showPosition pos) <> - " in file: " <> T.pack path - runAction "Example" ide $ getResults filePath pos - --- --------------------------------------------------------------------- - -symbols :: PluginMethodHandler IdeState TextDocumentDocumentSymbol -symbols _ide _pid (DocumentSymbolParams _ _ _doc) - = pure $ Right $ InL $ List [r] - where - r = DocumentSymbol name detail kind Nothing deprecation range selR chList - name = "Example_symbol_name" - detail = Nothing - kind = SkVariable - deprecation = Nothing - range = Range (Position 2 0) (Position 2 5) - selR = range - chList = Nothing - --- --------------------------------------------------------------------- - -completion :: PluginMethodHandler IdeState TextDocumentCompletion -completion _ide _pid (CompletionParams _doc _pos _ _ _mctxt) - = pure $ Right $ InL $ List [r] - where - r = CompletionItem label kind tags detail documentation deprecated preselect - sortText filterText insertText insertTextFormat insertTextMode - textEdit additionalTextEdits commitCharacters - command xd - label = "Example completion" - kind = Nothing - tags = Nothing - detail = Nothing - documentation = Nothing - deprecated = Nothing - preselect = Nothing - sortText = Nothing - filterText = Nothing - insertText = Nothing - insertTextMode = Nothing - insertTextFormat = Nothing - textEdit = Nothing - additionalTextEdits = Nothing - commitCharacters = Nothing - command = Nothing - xd = Nothing - --- --------------------------------------------------------------------- diff --git a/plugins/default/src/Ide/Plugin/Example2.hs b/plugins/default/src/Ide/Plugin/Example2.hs deleted file mode 100644 --- a/plugins/default/src/Ide/Plugin/Example2.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module Ide.Plugin.Example2 - ( - descriptor - , Log(..) - ) where - -import Control.Concurrent.STM -import Control.DeepSeq (NFData) -import Control.Monad.IO.Class -import Control.Monad.Trans.Maybe -import Data.Aeson -import Data.Functor -import qualified Data.HashMap.Strict as Map -import Data.Hashable -import qualified Data.Text as T -import Data.Typeable -import Development.IDE as D -import Development.IDE.Core.Shake hiding (Log) -import qualified Development.IDE.Core.Shake as Shake -import GHC.Generics -import Ide.PluginUtils -import Ide.Types -import Language.LSP.Server -import Language.LSP.Types -import Text.Regex.TDFA.Text () - --- --------------------------------------------------------------------- - -newtype Log = LogShake Shake.Log deriving Show - -instance Pretty Log where - pretty = \case - LogShake log -> pretty log - -descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginRules = exampleRules recorder - , pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] - , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction - <> mkPluginHandler STextDocumentCodeLens codeLens - <> mkPluginHandler STextDocumentHover hover - <> mkPluginHandler STextDocumentDocumentSymbol symbols - <> mkPluginHandler STextDocumentCompletion completion - } - --- --------------------------------------------------------------------- - -hover :: PluginMethodHandler IdeState TextDocumentHover -hover ide _ HoverParams{..} = liftIO $ request "Hover" blah (Right Nothing) foundHover ide TextDocumentPositionParams{..} - -blah :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text])) -blah _ (Position line col) - = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover 2\n"]) - --- --------------------------------------------------------------------- --- Generating Diagnostics via rules --- --------------------------------------------------------------------- - -data Example2 = Example2 - deriving (Eq, Show, Typeable, Generic) -instance Hashable Example2 -instance NFData Example2 - -type instance RuleResult Example2 = () - -exampleRules :: Recorder (WithPriority Log) -> Rules () -exampleRules recorder = do - define (cmapWithPrio LogShake recorder) $ \Example2 file -> do - _pm <- getParsedModule file - let diag = mkDiag file "example2" DsError (Range (Position 0 0) (Position 1 0)) "example2 diagnostic, hello world" - return ([diag], Just ()) - - action $ do - files <- getFilesOfInterestUntracked - void $ uses Example2 $ Map.keys files - -mkDiag :: NormalizedFilePath - -> DiagnosticSource - -> DiagnosticSeverity - -> Range - -> T.Text - -> FileDiagnostic -mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) - Diagnostic - { _range = loc - , _severity = Just sev - , _source = Just diagSource - , _message = msg - , _code = Nothing - , _tags = Nothing - , _relatedInformation = Nothing - } - --- --------------------------------------------------------------------- --- code actions --- --------------------------------------------------------------------- - --- | Generate code actions. -codeAction :: PluginMethodHandler IdeState TextDocumentCodeAction -codeAction _state _pid (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs}) = do - let - title = "Add TODO2 Item" - tedit = [TextEdit (Range (Position 3 0) (Position 3 0)) - "-- TODO2 added by Example2 Plugin directly\n"] - edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing - pure $ Right $ List - [ InR $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) Nothing Nothing (Just edit) Nothing Nothing] - --- --------------------------------------------------------------------- - -codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens -codeLens ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = liftIO $ do - logInfo (ideLogger ideState) "Example2.codeLens entered (ideLogger)" -- AZ - case uriToFilePath' uri of - Just (toNormalizedFilePath -> filePath) -> do - _ <- runIdeAction (fromNormalizedFilePath filePath) (shakeExtras ideState) $ runMaybeT $ useE TypeCheck filePath - _diag <- atomically $ getDiagnostics ideState - _hDiag <- atomically $ getHiddenDiagnostics ideState - let - title = "Add TODO2 Item via Code Lens" - range = Range (Position 3 0) (Position 4 0) - let cmdParams = AddTodoParams uri "do abc" - cmd = mkLspCommand plId "codelens.todo" title (Just [toJSON cmdParams]) - pure $ Right $ List [ CodeLens range (Just cmd) Nothing ] - Nothing -> pure $ Right $ List [] - --- --------------------------------------------------------------------- --- | Parameters for the addTodo PluginCommand. -data AddTodoParams = AddTodoParams - { file :: Uri -- ^ Uri of the file to add the pragma to - , todoText :: T.Text - } - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -addTodoCmd :: CommandFunction IdeState AddTodoParams -addTodoCmd _ide (AddTodoParams uri todoText) = do - let - pos = Position 5 0 - textEdits = List - [TextEdit (Range pos pos) - ("-- TODO2:" <> todoText <> "\n") - ] - res = WorkspaceEdit - (Just $ Map.singleton uri textEdits) - Nothing - Nothing - _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing res) (\_ -> pure ()) - return $ Right Null - --- --------------------------------------------------------------------- - -foundHover :: (Maybe Range, [T.Text]) -> Either ResponseError (Maybe Hover) -foundHover (mbRange, contents) = - Right $ Just $ Hover (HoverContents $ MarkupContent MkMarkdown - $ T.intercalate sectionSeparator contents) mbRange - - --- | Respond to and log a hover or go-to-definition request -request - :: T.Text - -> (NormalizedFilePath -> Position -> Action (Maybe a)) - -> Either ResponseError b - -> (a -> Either ResponseError b) - -> IdeState - -> TextDocumentPositionParams - -> IO (Either ResponseError b) -request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = do - mbResult <- case uriToFilePath' uri of - Just path -> logAndRunRequest label getResults ide pos path - Nothing -> pure Nothing - pure $ maybe notFound found mbResult - -logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) - -> IdeState -> Position -> String -> IO b -logAndRunRequest label getResults ide pos path = do - let filePath = toNormalizedFilePath path - logInfo (ideLogger ide) $ - label <> " request at position " <> T.pack (showPosition pos) <> - " in file: " <> T.pack path - runAction "Example2" ide $ getResults filePath pos - --- --------------------------------------------------------------------- - -symbols :: PluginMethodHandler IdeState TextDocumentDocumentSymbol -symbols _ide _ (DocumentSymbolParams _ _ _doc) - = pure $ Right $ InL $ List [r] - where - r = DocumentSymbol name detail kind Nothing deprecation range selR chList - name = "Example2_symbol_name" - detail = Nothing - kind = SkVariable - deprecation = Nothing - range = Range (Position 4 1) (Position 4 7) - selR = range - chList = Nothing - --- --------------------------------------------------------------------- - -completion :: PluginMethodHandler IdeState TextDocumentCompletion -completion _ide _pid (CompletionParams _doc _pos _ _ _mctxt) - = pure $ Right $ InL $ List [r] - where - r = CompletionItem label kind tags detail documentation deprecated preselect - sortText filterText insertText insertTextFormat insertTextMode - textEdit additionalTextEdits commitCharacters - command xd - label = "Example2 completion" - kind = Nothing - tags = Nothing - detail = Nothing - documentation = Nothing - deprecated = Nothing - preselect = Nothing - sortText = Nothing - filterText = Nothing - insertText = Nothing - insertTextMode = Nothing - insertTextFormat = Nothing - textEdit = Nothing - additionalTextEdits = Nothing - commitCharacters = Nothing - command = Nothing - xd = Nothing - --- --------------------------------------------------------------------- diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs new file mode 100644 --- /dev/null +++ b/src/HlsPlugins.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +module HlsPlugins where + +import Development.IDE.Types.Logger (Pretty (pretty), Recorder, + WithPriority, cmapWithPrio) +import Ide.PluginUtils (pluginDescToIdePlugins) +import Ide.Types (IdePlugins) + +-- fixed plugins +import Development.IDE (IdeState) +import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde + +-- haskell-language-server optional plugins +#if hls_qualifyImportedNames +import qualified Ide.Plugin.QualifyImportedNames as QualifyImportedNames +#endif + +#if hls_callHierarchy +import qualified Ide.Plugin.CallHierarchy as CallHierarchy +#endif + +#if hls_class +import qualified Ide.Plugin.Class as Class +#endif + +#if hls_haddockComments +import qualified Ide.Plugin.HaddockComments as HaddockComments +#endif + +#if hls_eval +import qualified Ide.Plugin.Eval as Eval +#endif + +#if hls_importLens +import qualified Ide.Plugin.ExplicitImports as ExplicitImports +#endif + +#if hls_refineImports +import qualified Ide.Plugin.RefineImports as RefineImports +#endif + +#if hls_rename +import qualified Ide.Plugin.Rename as Rename +#endif + +#if hls_retrie +import qualified Ide.Plugin.Retrie as Retrie +#endif + +#if hls_tactic +import qualified Ide.Plugin.Tactic as Tactic +#endif + +#if hls_hlint +import qualified Ide.Plugin.Hlint as Hlint +#endif + +#if hls_stan +import qualified Ide.Plugin.Stan as Stan +#endif + +#if hls_moduleName +import qualified Ide.Plugin.ModuleName as ModuleName +#endif + +#if hls_pragmas +import qualified Ide.Plugin.Pragmas as Pragmas +#endif + +#if hls_splice +import qualified Ide.Plugin.Splice as Splice +#endif + +#if hls_alternateNumberFormat +import qualified Ide.Plugin.AlternateNumberFormat as AlternateNumberFormat +#endif + +#if hls_codeRange +import qualified Ide.Plugin.CodeRange as CodeRange +#endif + +#if hls_changeTypeSignature +import Ide.Plugin.ChangeTypeSignature as ChangeTypeSignature +#endif + +#if hls_gadt +import Ide.Plugin.GADT as GADT +#endif + +#if explicitFixity +import Ide.Plugin.ExplicitFixity as ExplicitFixity +#endif + +-- formatters + +#if hls_floskell +import qualified Ide.Plugin.Floskell as Floskell +#endif + +#if hls_fourmolu +import qualified Ide.Plugin.Fourmolu as Fourmolu +#endif + +#if hls_ormolu +import qualified Ide.Plugin.Ormolu as Ormolu +#endif + +#if hls_stylishHaskell +import qualified Ide.Plugin.StylishHaskell as StylishHaskell +#endif + +#if hls_brittany +import qualified Ide.Plugin.Brittany as Brittany +#endif + +#if hls_refactor +import qualified Development.IDE.Plugin.CodeAction as Refactor +#endif + +data Log = forall a. (Pretty a) => Log a + +instance Pretty Log where + pretty (Log a) = pretty a + +-- --------------------------------------------------------------------- + +-- | The plugins configured for use in this instance of the language +-- server. +-- These can be freely added or removed to tailor the available +-- features of the server. + +idePlugins :: Recorder (WithPriority Log) -> IdePlugins IdeState +idePlugins recorder = pluginDescToIdePlugins allPlugins + where + pluginRecorder :: forall log. (Pretty log) => Recorder (WithPriority log) + pluginRecorder = cmapWithPrio Log recorder + allPlugins = +#if hls_pragmas + Pragmas.descriptor "pragmas" : +#endif +#if hls_floskell + Floskell.descriptor "floskell" : +#endif +#if hls_fourmolu + Fourmolu.descriptor pluginRecorder "fourmolu" : +#endif +#if hls_tactic + Tactic.descriptor pluginRecorder "tactics" : +#endif +#if hls_ormolu + Ormolu.descriptor "ormolu" : +#endif +#if hls_stylishHaskell + StylishHaskell.descriptor "stylish-haskell" : +#endif +#if hls_rename + Rename.descriptor pluginRecorder "rename" : +#endif +#if hls_retrie + Retrie.descriptor "retrie" : +#endif +#if hls_brittany + Brittany.descriptor "brittany" : +#endif +#if hls_callHierarchy + CallHierarchy.descriptor : +#endif +#if hls_class + Class.descriptor pluginRecorder "class" : +#endif +#if hls_haddockComments + HaddockComments.descriptor pluginRecorder "haddockComments" : +#endif +#if hls_eval + Eval.descriptor pluginRecorder "eval" : +#endif +#if hls_importLens + ExplicitImports.descriptor pluginRecorder "importLens" : +#endif +#if hls_qualifyImportedNames + QualifyImportedNames.descriptor "qualifyImportedNames" : +#endif +#if hls_refineImports + RefineImports.descriptor pluginRecorder "refineImports" : +#endif +#if hls_moduleName + ModuleName.descriptor pluginRecorder "moduleName" : +#endif +#if hls_hlint + Hlint.descriptor pluginRecorder "hlint" : +#endif +#if hls_stan + Stan.descriptor pluginRecorder "stan" : +#endif +#if hls_splice + Splice.descriptor "splice" : +#endif +#if hls_alternateNumberFormat + AlternateNumberFormat.descriptor pluginRecorder : +#endif +#if hls_codeRange + CodeRange.descriptor pluginRecorder "codeRange" : +#endif +#if hls_changeTypeSignature + ChangeTypeSignature.descriptor : +#endif +#if hls_gadt + GADT.descriptor "gadt" : +#endif +#if hls_refactor + Refactor.iePluginDescriptor pluginRecorder "ghcide-code-actions-imports-exports" : + Refactor.typeSigsPluginDescriptor pluginRecorder "ghcide-code-actions-type-signatures" : + Refactor.bindingsPluginDescriptor pluginRecorder "ghcide-code-actions-bindings" : + Refactor.fillHolePluginDescriptor pluginRecorder "ghcide-code-actions-fill-holes" : + Refactor.extendImportPluginDescriptor pluginRecorder "ghcide-extend-import-action" : +#endif + GhcIde.descriptors pluginRecorder +#if explicitFixity + ++ [ExplicitFixity.descriptor pluginRecorder] +#endif + diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -27,12 +27,12 @@ import qualified Development.IDE.Types.Options as Ghcide import GHC.Stack (emptyCallStack) import qualified HIE.Bios.Environment as HieBios -import HIE.Bios.Types +import HIE.Bios.Types hiding (Log) import Ide.Arguments import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, pluginsToVSCodeExtensionSchema) import Ide.Types (IdePlugins, PluginId (PluginId), - ipMap) + ipMap, pluginId) import Ide.Version import System.Directory import qualified System.Directory.Extra as IO @@ -80,7 +80,7 @@ ListPluginsMode -> do let pluginNames = sort - $ map ((\(PluginId t) -> T.unpack t) . fst) + $ map ((\(PluginId t) -> T.unpack t) . pluginId) $ ipMap idePlugins mapM_ putStrLn pluginNames @@ -118,20 +118,19 @@ log Info $ LogDirectory dir when (isLSP argsCommand) $ do - log Info $ LogLspStart ghcideArgs (map fst $ ipMap idePlugins) + log Info $ LogLspStart ghcideArgs (map pluginId $ ipMap idePlugins) -- exists so old-style logging works. intended to be phased out let logger = Logger $ \p m -> logger_ recorder (WithPriority p emptyCallStack $ LogOther m) + args = (if argsTesting then IDEMain.testing else IDEMain.defaultArguments) + (cmapWithPrio LogIDEMain recorder) logger - IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) (IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) logger) + IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) args { IDEMain.argCommand = argsCommand - , IDEMain.argsHlsPlugins = idePlugins + , IDEMain.argsHlsPlugins = IDEMain.argsHlsPlugins args <> idePlugins , IDEMain.argsLogger = pure logger <> pure telemetryLogger , IDEMain.argsThreads = if argsThreads == 0 then Nothing else Just $ fromIntegral argsThreads - , IDEMain.argsIdeOptions = \_config sessionLoader -> - let defOptions = Ghcide.defaultIdeOptions sessionLoader - in defOptions - { Ghcide.optShakeProfiling = argsShakeProfiling - , Ghcide.optTesting = Ghcide.IdeTesting argsTesting - } + , IDEMain.argsIdeOptions = \config sessionLoader -> + let defOptions = IDEMain.argsIdeOptions args config sessionLoader + in defOptions { Ghcide.optShakeProfiling = argsShakeProfiling } } diff --git a/src/Ide/Version.hs b/src/Ide/Version.hs --- a/src/Ide/Version.hs +++ b/src/Ide/Version.hs @@ -46,13 +46,17 @@ showProgramVersionOfInterest :: ProgramsOfInterest -> String showProgramVersionOfInterest ProgramsOfInterest {..} = unlines - [ "cabal:\t\t" ++ showVersionWithDefault cabalVersion - , "stack:\t\t" ++ showVersionWithDefault stackVersion - , "ghc:\t\t" ++ showVersionWithDefault ghcVersion + [ showProgramVersion "cabal" cabalVersion + , showProgramVersion "stack" stackVersion + , showProgramVersion "ghc" ghcVersion ] + +showProgramVersion :: String -> Maybe Version -> String +showProgramVersion name version = + pad 16 (name ++ ":") ++ showVersionWithDefault version where - showVersionWithDefault :: Maybe Version -> String showVersionWithDefault = maybe "Not found" showVersion + pad n s = s ++ replicate (n - length s) ' ' findProgramVersions :: IO ProgramsOfInterest findProgramVersions = ProgramsOfInterest @@ -69,8 +73,11 @@ Nothing -> pure Nothing Just path -> readProcessWithExitCode path ["--numeric-version"] "" >>= \case - (ExitSuccess, sout, _) -> pure $ consumeParser myVersionParser sout + (ExitSuccess, sout, _) -> pure $ mkVersion sout _ -> pure Nothing + +mkVersion :: String -> Maybe Version +mkVersion = consumeParser myVersionParser where myVersionParser = do skipSpaces @@ -79,4 +86,5 @@ pure version consumeParser :: ReadP a -> String -> Maybe a - consumeParser p input = listToMaybe $ map fst . filter (null . snd) $ readP_to_S p input + consumeParser p input = + listToMaybe $ map fst . filter (null . snd) $ readP_to_S p input diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs --- a/test/functional/Completion.hs +++ b/test/functional/Completion.hs @@ -138,15 +138,25 @@ , testCase "import second function completion" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "FunctionCompletions.hs" "haskell" - let te = TextEdit (Range (Position 0 41) (Position 0 42)) ", l" + let te = TextEdit (Range (Position 0 39) (Position 0 39)) ", l" _ <- applyEdit doc te - compls <- getCompletions doc (Position 0 41) + compls <- getCompletions doc (Position 0 42) item <- getCompletionByLabel "liftA" compls liftIO $ do item ^. label @?= "liftA" item ^. kind @?= Just CiFunction item ^. detail @?= Just "Control.Applicative" + + , testCase "completes locally defined associated type family" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "AssociatedTypeFamily.hs" "haskell" + + compls <- getCompletions doc (Position 5 20) + item <- getCompletionByLabel "Fam" compls + liftIO $ do + item ^. label @?= "Fam" + item ^. kind @?= Just CiStruct + , contextTests , snippetTests ] diff --git a/test/functional/Diagnostic.hs b/test/functional/Diagnostic.hs --- a/test/functional/Diagnostic.hs +++ b/test/functional/Diagnostic.hs @@ -10,23 +10,8 @@ -- --------------------------------------------------------------------- tests :: TestTree -tests = testGroup "diagnostics providers" [ - basicTests - , warningTests - ] +tests = testGroup "diagnostics providers" [ warningTests ] -basicTests :: TestTree -basicTests = testGroup "Diagnostics work" [ - testCase "example plugin produces diagnostics" $ - runSession hlsCommandExamplePlugin fullCaps "test/testdata/diagnostics" $ do - doc <- openDoc "Foo.hs" "haskell" - diags <- waitForDiagnosticsFromSource doc "example2" - reduceDiag <- liftIO $ inspectDiagnostic diags ["example2 diagnostic, hello world"] - liftIO $ do - length diags @?= 1 - reduceDiag ^. LSP.range @?= Range (Position 0 0) (Position 1 0) - reduceDiag ^. LSP.severity @?= Just DsError - ] warningTests :: TestTree warningTests = testGroup "Warnings are warnings" [ diff --git a/test/functional/Format.hs b/test/functional/Format.hs --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -8,6 +8,7 @@ import qualified Data.ByteString.Lazy as BS import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T +import qualified Data.Text as T import Language.LSP.Test import Language.LSP.Types import qualified Language.LSP.Types.Lens as LSP @@ -47,7 +48,13 @@ testCase "respects none" $ runSessionWithConfig (formatConfig "none") hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" resp <- request STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) - liftIO $ resp ^. LSP.result @?= Left (ResponseError InvalidRequest "No plugin enabled for STextDocumentFormatting, available: []" Nothing) + liftIO $ case resp ^. LSP.result of + result@(Left (ResponseError reason message Nothing)) -> case reason of + MethodNotFound -> pure () -- No formatter + InvalidRequest | "No plugin enabled for STextDocumentFormatting" `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" $ runSession hlsCommand fullCaps "test/testdata/format" $ do formattedOrmolu <- liftIO $ T.readFile "test/testdata/format/Format.ormolu.formatted.hs" diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -24,6 +24,7 @@ tests :: TestTree tests = testGroup "code actions" [ +#if hls_refactor importTests , packageTests , redundantImportTests @@ -31,6 +32,7 @@ , signatureTests , typedHoleTests , unusedTermTests +#endif ] renameTests :: TestTree diff --git a/test/functional/HieBios.hs b/test/functional/HieBios.hs --- a/test/functional/HieBios.hs +++ b/test/functional/HieBios.hs @@ -24,7 +24,7 @@ @? "found hover text for main" _ -> error $ "Unexpected hover contents: " ++ show hoverContents - , testCase "reports errors in hie.yaml" $ do + , expectFailBecause "hie-bios 0.11 has poor error messages" $ testCase "reports errors in hie.yaml" $ do writeFile (hieBiosErrorPath "hie.yaml") "" runSession hlsCommand fullCaps hieBiosErrorPath $ do _ <- openDoc "Foo.hs" "haskell" diff --git a/test/testdata/completion/AssociatedTypeFamily.hs b/test/testdata/completion/AssociatedTypeFamily.hs new file mode 100644 --- /dev/null +++ b/test/testdata/completion/AssociatedTypeFamily.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} +module AssociatedTypeFamily () where + +class C a where + type Fam a + +x :: C a => a -> Fam a +x = undefined diff --git a/test/testdata/hieBiosError/hie.yaml b/test/testdata/hieBiosError/hie.yaml new file mode 100644 --- /dev/null +++ b/test/testdata/hieBiosError/hie.yaml diff --git a/test/testdata/wErrorTest/src/WError.hs b/test/testdata/wErrorTest/src/WError.hs --- a/test/testdata/wErrorTest/src/WError.hs +++ b/test/testdata/wErrorTest/src/WError.hs @@ -1,2 +1,3 @@ module WError where +{-# ANN module "HLint: ignore" #-} main = undefined