From d0e3e0fe3f1d14dd51a40d43d3272269b445cede Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Thu, 25 Aug 2022 15:08:57 +0100 Subject: [PATCH] HLS benchmarks (#3117) * extract ghcide:experiments-types * extract haskell-language-server:plugins and let go of examples The main goal here is to move the Plugins module into an internal library so that it can be reused from the benchmark suite. In order to make that easier, and since they hardly serve a purpose in a repository with 25 plugins, I delete the Example and Example2 plugin descriptors and their dependencies. * HLS benchmark suite Port the ghcide benchmark suite to HLS and benchmark plugin "configurations" independently. This includes the following changes to the ghcide benchmark suite and HLS: - Support for "configurations" which are defined as sets of plugin ids. The benchmark will be run with only these plugins enabled and all others disabled - Support for configurable concurrency. This relies on RTS -ol and -po flags to place the RTS traces in the target location rather than in the cwd This change requires two commits, the next one places ghcide/bench/hist/Main.hs into its final location to help 'git' recognize the change as a file move * ghcide/bench/hist/Main.hs -> bench/Main.hs * CI - fix artifact names for uniqueness * disable shorten HLS step * Do not store eventlogs to avoid out of disk space * render durations up to milliseconds * shorten titles Goal is to display the formatted CSV (via column) one row per line * exclude formatting plugin configurations * Extract ghcide-bench to a standalone package * ghcide-bench: fix stderr capturing * Fix mem stats We parse maxResidency and allocatedBytes from the RTS -S output, but runSessionWithHandles kills the server without waiting for it to exit and these stats don't get logged. The solution is to use runSessionWithHandles', but unfortunately it is internal and not exposed. I have raised a PR to expose it and in the meantime we need a source repo package. * feedbacks * delete Example plugins --- .github/workflows/bench.yml | 26 +- .gitignore | 3 +- bench/Main.hs | 282 ++++++++++++++++++ {ghcide/bench => bench}/README.md | 22 +- bench/config.yaml | 175 +++++++++++ cabal.project | 9 + docs/contributing/contributing.md | 6 +- exe/Main.hs | 14 +- ghcide-bench/LICENSE | 201 +++++++++++++ ghcide-bench/README.md | 61 ++++ {ghcide/bench => ghcide-bench}/exe/Main.hs | 0 ghcide-bench/ghcide-bench.cabal | 137 +++++++++ .../src/Development/IDE/Test/Diagnostic.hs | 48 +++ .../lib => ghcide-bench/src}/Experiments.hs | 166 +++++++---- .../src}/Experiments/Types.hs | 19 +- ghcide-bench/test/Main.hs | 48 +++ ghcide/.gitignore | 5 - ghcide/bench-results/.artifactignore | 4 - ghcide/bench/config.yaml | 116 ------- ghcide/bench/hist/Main.hs | 192 ------------ ghcide/ghcide.cabal | 110 +------ ghcide/test/exe/Main.hs | 21 -- ghcide/test/src/Development/IDE/Test.hs | 20 -- haskell-language-server.cabal | 68 ++++- hls-plugin-api/src/Ide/Types.hs | 2 +- plugins/default/src/Ide/Plugin/Example.hs | 253 ---------------- plugins/default/src/Ide/Plugin/Example2.hs | 237 --------------- .../default/src/Ide/Plugin/ExampleCabal.hs | 75 ----- shake-bench/shake-bench.cabal | 1 + .../src/Development/Benchmark/Rules.hs | 159 ++++++---- exe/Plugins.hs => src/HlsPlugins.hs | 19 +- test/functional/Diagnostic.hs | 17 +- 32 files changed, 1296 insertions(+), 1220 deletions(-) create mode 100644 bench/Main.hs rename {ghcide/bench => bench}/README.md (65%) create mode 100644 bench/config.yaml create mode 100644 ghcide-bench/LICENSE create mode 100644 ghcide-bench/README.md rename {ghcide/bench => ghcide-bench}/exe/Main.hs (100%) create mode 100644 ghcide-bench/ghcide-bench.cabal create mode 100644 ghcide-bench/src/Development/IDE/Test/Diagnostic.hs rename {ghcide/bench/lib => ghcide-bench/src}/Experiments.hs (85%) rename {ghcide/bench/lib => ghcide-bench/src}/Experiments/Types.hs (82%) create mode 100644 ghcide-bench/test/Main.hs delete mode 100644 ghcide/bench-results/.artifactignore delete mode 100644 ghcide/bench/config.yaml delete mode 100644 ghcide/bench/hist/Main.hs delete mode 100644 plugins/default/src/Ide/Plugin/Example.hs delete mode 100644 plugins/default/src/Ide/Plugin/Example2.hs delete mode 100644 plugins/default/src/Ide/Plugin/ExampleCabal.hs rename exe/Plugins.hs => src/HlsPlugins.hs (88%) diff --git a/.github/workflows/bench.yml b/.github/workflows/bench.yml index 2945ac2812..a9d7bdfae4 100644 --- a/.github/workflows/bench.yml +++ b/.github/workflows/bench.yml @@ -61,16 +61,17 @@ jobs: with: ghc: ${{ matrix.ghc }} os: ${{ runner.os }} + shorten-hls: "false" # max-backjumps is increased as a temporary solution # for dependency resolution failure - run: cabal configure --enable-benchmarks --max-backjumps 12000 - name: Build - run: cabal build ghcide:benchHist + run: cabal build haskell-language-server:benchmark - name: Bench init - run: cabal bench ghcide:benchHist -j --benchmark-options="all-binaries" + run: cabal bench -j --benchmark-options="all-binaries" # tar is required to preserve file permissions # compression speeds up upload/download nicely @@ -85,14 +86,14 @@ jobs: - name: Upload workspace uses: actions/upload-artifact@v3 with: - name: workspace + name: workspace-${{ matrix.ghc }}-${{ matrix.os }} retention-days: 1 path: workspace.tar.gz - name: Upload .cabal uses: actions/upload-artifact@v3 with: - name: cabal-home + name: cabal-home-${{ matrix.ghc }}-${{ matrix.os }} retention-days: 1 path: ~/.cabal/cabal.tar.gz @@ -118,13 +119,13 @@ jobs: - name: Download cabal home uses: actions/download-artifact@v3 with: - name: cabal-home + name: cabal-home-${{ matrix.ghc }}-${{ matrix.os }} path: . - name: Download workspace uses: actions/download-artifact@v3 with: - name: workspace + name: workspace-${{ matrix.ghc }}-${{ matrix.os }} path: . - name: untar @@ -134,28 +135,29 @@ jobs: tar xzf cabal.tar.gz --directory ~/.cabal - name: Bench - run: cabal bench ghcide:benchHist -j --benchmark-options="${{ matrix.example }}" + run: cabal bench -j --benchmark-options="${{ matrix.example }}" - name: Display results run: | - column -s, -t < ghcide/bench-results/unprofiled/${{ matrix.example }}/results.csv | tee ghcide/bench-results/unprofiled/${{ matrix.example }}/results.txt + column -s, -t < bench-results/unprofiled/${{ matrix.example }}/results.csv | tee bench-results/unprofiled/${{ matrix.example }}/results.txt - name: tar benchmarking artifacts - run: find ghcide/bench-results -name "*.csv" -or -name "*.svg" -or -name "*.html" | xargs tar -czf benchmark-artifacts.tar.gz + run: find bench-results -name "*.csv" -or -name "*.svg" -or -name "*.html" | xargs tar -czf benchmark-artifacts.tar.gz - name: Archive benchmarking artifacts uses: actions/upload-artifact@v3 with: - name: bench-results-${{ runner.os }}-${{ matrix.ghc }} + name: bench-results-${{ matrix.example }}-${{ runner.os }}-${{ matrix.ghc }} path: benchmark-artifacts.tar.gz - name: tar benchmarking logs - run: find ghcide/bench-results -name "*.log" -or -name "*.eventlog" -or -name "*.hp" | xargs tar -czf benchmark-logs.tar.gz + # We dont' store the eventlogs because the CI workers risk running out of disk space + run: find bench-results -name "*.log" -or -name "*.hp" | xargs tar -czf benchmark-logs.tar.gz - name: Archive benchmark logs uses: actions/upload-artifact@v3 with: - name: bench-logs-${{ runner.os }}-${{ matrix.ghc }} + name: bench-logs-${{ matrix.example }}-${{ runner.os }}-${{ matrix.ghc }} path: benchmark-logs.tar.gz bench_post_job: diff --git a/.gitignore b/.gitignore index ed983e69c8..1cf8b239ad 100644 --- a/.gitignore +++ b/.gitignore @@ -34,9 +34,10 @@ test/testdata/**/hie.yaml /.direnv/ /.envrc -# ghcide-bench +# bench *.identifierPosition /bench/example +/bench-results # nix result diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 index 0000000000..97d01f9537 --- /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/ghcide/bench/README.md b/bench/README.md similarity index 65% rename from ghcide/bench/README.md rename to bench/README.md index 783ab70985..557fcc1420 100644 --- a/ghcide/bench/README.md +++ b/bench/README.md @@ -1,22 +1,17 @@ # Benchmarks -This folder contains two Haskell programs that work together to simplify the -performance analysis of ghcide: - -- `exe/Main.hs` - a standalone benchmark runner. Run with `stack run ghcide-bench` -- `hist/Main.hs` - a Shake script for running the benchmark suite over a set of commits. - - Run with `stack bench ghcide` or `cabal bench ghcide`, - - Requires a `ghcide-bench` binary in the PATH (usually provided by stack/cabal), - - Calls `cabal` (or `stack`, configurable) internally to build the project, - - Driven by the `bench/config.yaml` configuration file. - By default it compares HEAD with "master" +This folder contains a Shake script to simplify the performance analysis of HLS. +It drives the `ghcide-bench` benchmark suite over a set of commits and experiments. +To run it, use `cabal bench`. +To configure it, edit `bench/config.yaml`. +By default it compares HEAD with "origin/master" # Examples and experiments The benchmark suites runs a set of experiments (hover, completion, edit, etc.) over all the defined examples (currently Cabal and lsp-types). Examples are defined -in `ghcide/bench/config.yaml` whereas experiments are coded in `ghcide/bench/lib/Experiments.hs`. +in `bench/config.yaml` whereas experiments are coded in `ghcide-bench/src/Experiments.hs`. # Phony targets @@ -34,11 +29,14 @@ The Shake script supports a number of phony targets that allow running a subset * profiled-Cabal-3.0.0.0 : runs the Cabal example, with heap profiling +* all-binaries +: build all the HLS binaries for each of the versions under analysis + * etc `--help` lists all the phony targets. Invoke it with: - cabal bench ghcide --benchmark-options="--help" + cabal bench --benchmark-options="--help" ``` Targets: diff --git a/bench/config.yaml b/bench/config.yaml new file mode 100644 index 0000000000..19e014a485 --- /dev/null +++ b/bench/config.yaml @@ -0,0 +1,175 @@ +# The number of samples to run per experiment. +# At least 100 is recommended in order to observe space leaks +samples: 50 + +buildTool: cabal + +# Output folder for the experiments +outputFolder: bench-results + +# Heap profile interval in seconds (+RTS -i) +# Comment out to disable heap profiling +profileInterval: 1 + +# Number of concurrent benchmark and warmup runs +parallelism: 1 + +# Example project used to run the experiments +# Can either be a Hackage package (name,version) +# or a local project (path) with a valid `hie.yaml` file +examples: + # Medium-sized project without TH + - name: cabal + package: Cabal + version: 3.6.3.0 + modules: + - src/Distribution/Simple.hs + - src/Distribution/Types/Module.hs + extra-args: [] # extra HLS command line args + # Small-sized project with TH + - name: lsp-types + package: lsp-types + version: 1.5.0.0 + modules: + - src/Language/LSP/Types/WatchedFiles.hs + - src/Language/LSP/Types/CallHierarchy.hs + # Small but heavily multi-component example + # Disabled as it is far to slow. hie-bios >0.7.2 should help + # - name: HLS + # path: bench/example/HLS + # modules: + # - hls-plugin-api/src/Ide/Plugin/Config.hs + # - ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs + # - ghcide/bench/hist/Main.hs + # - ghcide/bench/lib/Experiments/Types.hs + # - ghcide/test/exe/Main.hs + # - exe/Plugins.hs + +# The set of experiments to execute +experiments: + - "edit" + - "hover" + - "hover after edit" + # - "hover after cradle edit" + - "getDefinition" + - "getDefinition after edit" + - "completions" + - "completions after edit" + - "code actions" + - "code actions after edit" + - "code actions after cradle edit" + - "documentSymbols after edit" + - "hole fit suggestions" + +# An ordered list of versions to analyze +versions: +# A version can be defined briefly: +# - +# - +# - + +# Or in extended form, where all the fields are optional: +# - : +# git: +# include: true # whether to include in comparison graphs +# parent: # version to compare with in .diff graphs + + +# - 1.8.0.0 +# - upstream: origin/master +# - HEAD~1 +- HEAD + +# A list of plugin configurations to analyze +configurations: +# A configuration contains one or more plugins: +# - ConfigurationName: +# - plugin1 +# - plugin2 +# +# There is short-hand notation for defining singleton configurations. +# Simply give the plugin name top level: +# - plugin1 +# +# Some plugins are implicitly included since they are required by the benchmark driver: +# The implicitly included plugins are: +# - ghcide-core +# - ghcide-hover-and-symbols +- None: [] +- Core: + - callHierarchy + - codeRange + - eval + - ghcide-code-actions-bindings + - ghcide-code-actions-fill-holes + - ghcide-code-actions-imports-exports + - ghcide-code-actions-type-signatures + - ghcide-completions + - ghcide-type-lenses + - pragmas +- Ghcide: + - ghcide-code-actions-bindings + - ghcide-code-actions-fill-holes + - ghcide-code-actions-imports-exports + - ghcide-code-actions-type-signatures + - ghcide-completions + - ghcide-type-lenses +- All: + - alternateNumberFormat + - callHierarchy + - changeTypeSignature + - class + - codeRange + - eval + - explicitFixity + - floskell + - fourmolu + - gadt + - ghcide-code-actions-bindings + - ghcide-code-actions-fill-holes + - ghcide-code-actions-imports-exports + - ghcide-code-actions-type-signatures + - ghcide-completions + - ghcide-type-lenses + - hlint + - importLens + - moduleName + - ormolu + - pragmas + - qualifyImportedNames + - refineImports + - rename + - stylish-haskell +- alternateNumberFormat +# - brittany +- callHierarchy +- changeTypeSignature +- class +- codeRange +- eval +- explicitFixity +# - floskell +# - fourmolu +- gadt +- ghcide-code-actions-bindings +- ghcide-code-actions-fill-holes +- ghcide-code-actions-imports-exports +- ghcide-code-actions-type-signatures +- ghcide-completions +# - ghcide-core # implicitly included in all configurations +# - ghcide-hover-and-symbols # implicitly included in all configurations +- ghcide-type-lenses +- haddockComments +- hlint +- importLens +- moduleName +# - ormolu +- pragmas +- qualifyImportedNames +- refineImports +- rename +- retrie +- splice +- stan +# - stylish-haskell +- tactics diff --git a/cabal.project b/cabal.project index 8bfcb20265..047c2efcc2 100644 --- a/cabal.project +++ b/cabal.project @@ -4,6 +4,7 @@ packages: ./shake-bench ./hls-graph ./ghcide + ./ghcide-bench ./hls-plugin-api ./hls-test-utils ./plugins/hls-tactics-plugin @@ -64,6 +65,14 @@ source-repository-package tag: 7a0af7a8fd38045fd15fb13445bdcc7085325460 -- https://github.com/tibbe/ekg-json/pull/12 +-- Needed for ghcide-bench until a new release of lsp-test is out +source-repository-package + type:git + location: https://github.com/haskell/lsp + subdir: lsp-test + tag: c95eb06c70c35f1e13c37ed11a7d9e5b36bfa2e8 + -- https://github.com/haskell/lsp/pull/450 + allow-newer: -- ghc-9.2 ---------- diff --git a/docs/contributing/contributing.md b/docs/contributing/contributing.md index a3fd5660b3..4d7aae78a5 100644 --- a/docs/contributing/contributing.md +++ b/docs/contributing/contributing.md @@ -208,11 +208,11 @@ If you are touching performance sensitive code, take the time to run a different benchmark between HEAD and master using the benchHist script. This assumes that "master" points to the upstream master. -Run the benchmarks with `cabal bench ghcide`. +Run the benchmarks with `cabal bench`. -It should take around 25 minutes and the results will be stored in the `ghcide/bench-results` folder. To interpret the results, see the comments in the `ghcide/bench/hist/Main.hs` module. +It should take around 25 minutes and the results will be stored in the `bench-results` folder. To interpret the results, see the comments in the `bench/Main.hs` module. -More details in [bench/README](../../ghcide/bench/README.md) +More details in [bench/README](../../bench/README.md) ### Tracing diff --git a/exe/Main.hs b/exe/Main.hs index 083f76a1b4..ca8c885f43 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -20,6 +20,7 @@ import Development.IDE.Types.Logger (Doc, payload, renderStrict, withDefaultRecorder) import qualified Development.IDE.Types.Logger as Logger +import qualified HlsPlugins as Plugins import Ide.Arguments (Arguments (..), GhcideArguments (..), getArguments) @@ -31,7 +32,6 @@ import Ide.Types (PluginDescriptor (pluginNotificat 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 @@ -52,7 +52,7 @@ main = do -- 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 @@ -64,12 +64,12 @@ main = do liftIO $ (cb1 <> cb2) env } - let (argsTesting, 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 (argsTesting, minPriority, argsLogFile, argsExamplePlugin) - _ -> (False, Info, Nothing, False) + in (argsTesting, minPriority, argsLogFile) + _ -> (False, Info, Nothing) withDefaultRecorder logFilePath Nothing minPriority $ \textWithPriorityRecorder -> do let @@ -87,7 +87,7 @@ main = do -- 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) diff --git a/ghcide-bench/LICENSE b/ghcide-bench/LICENSE new file mode 100644 index 0000000000..261eeb9e9f --- /dev/null +++ b/ghcide-bench/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/ghcide-bench/README.md b/ghcide-bench/README.md new file mode 100644 index 0000000000..f815635157 --- /dev/null +++ b/ghcide-bench/README.md @@ -0,0 +1,61 @@ +A benchmark suite for measuring various performance-related metrics on ghcide and HLS. + +## Usage + +Run with `cabal ghcide bench`, point it to a `haskell-language-server` or `ghcide` binary, specify: +- the experiment to run, from the ones defined in `src/Experiments.hs`, +- the example codebase (either a local folder or a Hackage package), +- one or more module paths to run the experiment on, +- the number of samples, +- any extra command line options to pass to the binary, + +``` +Usage: ghcide-bench [(-v|--verbose) | (-q|--quiet)] [--shake-profiling PATH] + [--ot-profiling DIR] [--csv PATH] [--stack] + [--ghcide-options ARG] [-s|--select ARG] [--samples NAT] + [--ghcide PATH] [--timeout ARG] + [[--example-package-name ARG] + [--example-package-version ARG] + [(--example-module PATH)] | + --example-path ARG (--example-module PATH)] [--lsp-config] + [--no-clean] + +Available options: + --ot-profiling DIR Enable OpenTelemetry and write eventlog for each + benchmark in DIR + --stack Use stack (by default cabal is used) + --ghcide-options ARG additional options for ghcide + -s,--select ARG select which benchmarks to run + --samples NAT override sampling count + --ghcide PATH path to ghcide + --timeout ARG timeout for waiting for a ghcide response + --lsp-config Read an LSP config payload from standard input + -h,--help Show this help text +``` + +## Experiments + +Experiments are LSP sessions defined using the `lsp-test` DSL that run on one or +more modules. + +Currently the following experiments are defined: +- *edit*: makes an edit and waits for re-typechecking +- *hover*: asks for hover on an identifier +- *getDefinition*: asks for the definitions of an identifier +- *documentsymbols* +- *completions*: asks for completions on an identifier position +- *code actions*: makes an edit that breaks typechecking and asks for code actions +- *hole fit suggestions*: measures the performance of hole fits +- *X after edit*: combines the *edit* and X experiments +- *X after cradle edit*: combines the X experiments with an edit to the `hie.yaml` file + +One can define additional experiments easily, for e.g. formatting, code lenses, renames, etc. +Experiments are defined in the `src/Experiments.hs` module. + +### Positions +`ghcide-bench` will analyze the modules prior to running the experiments, +and try to identify the following designated source locations in the module: + +- *stringLiteralP*: a location that can be mutated without generating a diagnostic, +- *identifierP*: a location with an identifier that is not locally defined in the module. +- *docP*: a location containing a comment diff --git a/ghcide/bench/exe/Main.hs b/ghcide-bench/exe/Main.hs similarity index 100% rename from ghcide/bench/exe/Main.hs rename to ghcide-bench/exe/Main.hs diff --git a/ghcide-bench/ghcide-bench.cabal b/ghcide-bench/ghcide-bench.cabal new file mode 100644 index 0000000000..89a9fc1080 --- /dev/null +++ b/ghcide-bench/ghcide-bench.cabal @@ -0,0 +1,137 @@ +cabal-version: 3.0 +build-type: Simple +category: Development +name: ghcide-bench +version: 0.1 +license: Apache-2.0 +license-file: LICENSE +author: The Haskell IDE team +maintainer: pepeiborra@gmail.com +copyright: The Haskell IDE team +synopsis: An LSP client for running performance experiments on HLS +description: An LSP client for running performance experiments on HLS +homepage: https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme +bug-reports: https://github.com/haskell/haskell-language-server/issues +tested-with: GHC == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.3 || == 9.2.4 + +executable ghcide-bench + default-language: Haskell2010 + build-depends: + aeson, + base, + bytestring, + containers, + data-default, + directory, + extra, + filepath, + hls-plugin-api, + lens, + ghcide-bench, + lsp-test, + lsp-types, + optparse-applicative, + process, + safe-exceptions, + hls-graph, + shake, + tasty-hunit >= 0.10, + text + hs-source-dirs: exe + ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts + main-is: Main.hs + default-extensions: + BangPatterns + DeriveFunctor + DeriveGeneric + FlexibleContexts + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall -Wno-name-shadowing + exposed-modules: + Experiments.Types + Experiments + other-modules: + Development.IDE.Test.Diagnostic + build-depends: + aeson, + async, + base == 4.*, + binary, + bytestring, + deepseq, + directory, + extra, + filepath, + ghcide, + hashable, + lens, + lsp-test, + lsp-types, + optparse-applicative, + parser-combinators, + process, + safe-exceptions, + shake, + text, + default-extensions: + BangPatterns + DeriveFunctor + DeriveGeneric + FlexibleContexts + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns + +test-suite test + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-tool-depends: + ghcide:ghcide, + implicit-hie:gen-hie + main-is: Main.hs + hs-source-dirs: test + ghc-options: -Wunused-packages + ghc-options: -threaded -Wall + build-depends: + base, + extra, + ghcide-bench, + lsp-test ^>= 0.14, + tasty, + tasty-hunit >= 0.10, + tasty-rerun, + default-extensions: + BangPatterns + DeriveFunctor + DeriveGeneric + FlexibleContexts + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns + diff --git a/ghcide-bench/src/Development/IDE/Test/Diagnostic.hs b/ghcide-bench/src/Development/IDE/Test/Diagnostic.hs new file mode 100644 index 0000000000..a1ea88ec28 --- /dev/null +++ b/ghcide-bench/src/Development/IDE/Test/Diagnostic.hs @@ -0,0 +1,48 @@ +-- Duplicate of ghcide/test/Development/IDE/Test/Diagnostic.hs +module Development.IDE.Test.Diagnostic where + +import Control.Lens ((^.)) +import qualified Data.Text as T +import GHC.Stack (HasCallStack) +import Language.LSP.Types +import Language.LSP.Types.Lens as Lsp + +-- | (0-based line number, 0-based column number) +type Cursor = (UInt, UInt) + +cursorPosition :: Cursor -> Position +cursorPosition (line, col) = Position line col + +type ErrorMsg = String + +requireDiagnostic + :: (Foldable f, Show (f Diagnostic), HasCallStack) + => f Diagnostic + -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) + -> Maybe ErrorMsg +requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) + | any match actuals = Nothing + | otherwise = Just $ + "Could not find " <> show expected <> + " in " <> show actuals + where + match :: Diagnostic -> Bool + match d = + Just severity == _severity d + && cursorPosition cursor == d ^. range . start + && standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf` + standardizeQuotes (T.toLower $ d ^. message) + && hasTag expectedTag (d ^. tags) + + hasTag :: Maybe DiagnosticTag -> Maybe (List DiagnosticTag) -> Bool + hasTag Nothing _ = True + hasTag (Just _) Nothing = False + hasTag (Just actualTag) (Just (List tags)) = actualTag `elem` tags + +standardizeQuotes :: T.Text -> T.Text +standardizeQuotes msg = let + repl '‘' = '\'' + repl '’' = '\'' + repl '`' = '\'' + repl c = c + in T.map repl msg diff --git a/ghcide/bench/lib/Experiments.hs b/ghcide-bench/src/Experiments.hs similarity index 85% rename from ghcide/bench/lib/Experiments.hs rename to ghcide-bench/src/Experiments.hs index 081df51984..1d8d6f6c5b 100644 --- a/ghcide/bench/lib/Experiments.hs +++ b/ghcide-bench/src/Experiments.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} @@ -23,24 +24,24 @@ module Experiments , exampleToOptions ) where import Control.Applicative.Combinators (skipManyTill) +import Control.Concurrent.Async (withAsync) import Control.Exception.Safe (IOException, handleAny, try) -import Control.Monad.Extra (allM, forM, forM_, unless, - void, whenJust, (&&^)) +import Control.Monad.Extra (allM, forM, forM_, forever, + unless, void, when, whenJust, + (&&^)) import Control.Monad.Fail (MonadFail) import Control.Monad.IO.Class -import Data.Aeson (Value (Null), toJSON) +import Data.Aeson (Value (Null), + eitherDecodeStrict', toJSON) +import qualified Data.Aeson as A +import qualified Data.ByteString as BS import Data.Either (fromRight) import Data.List import Data.Maybe +import Data.Text (Text) import qualified Data.Text as T import Data.Version import Development.IDE.Plugin.Test -import Development.IDE.Test (getBuildEdgesCount, - getBuildKeysBuilt, - getBuildKeysChanged, - getBuildKeysVisited, - getRebuildsCount, - getStoredKeys) import Development.IDE.Test.Diagnostic import Development.Shake (CmdOption (Cwd, FileStdout), cmd_) @@ -56,9 +57,11 @@ import Options.Applicative import System.Directory import System.Environment.Blank (getEnv) import System.FilePath ((<.>), ()) +import System.IO import System.Process import System.Time.Extra import Text.ParserCombinators.ReadP (readP_to_S) +import Text.Printf charEdit :: Position -> TextDocumentContentChangeEvent charEdit p = @@ -69,8 +72,11 @@ charEdit p = } data DocumentPositions = DocumentPositions { + -- | A position that can be used to generate non null goto-def and completion responses identifierP :: Maybe Position, + -- | A position that can be modified without generating a new diagnostic stringLiteralP :: !Position, + -- | The document containing the above positions doc :: !TextDocumentIdentifier } @@ -82,7 +88,7 @@ allWithIdentifierPos f docs = case applicableDocs of where applicableDocs = filter (isJust . identifierP) docs -experiments :: [Bench] +experiments :: HasConfig => [Bench] experiments = [ --------------------------------------------------------------------------------------- bench "hover" $ allWithIdentifierPos $ \DocumentPositions{..} -> @@ -94,6 +100,7 @@ experiments = -- wait for a fresh build start waitForProgressStart -- wait for the build to be finished + output "edit: waitForProgressDone" waitForProgressDone return True, --------------------------------------------------------------------------------------- @@ -267,6 +274,7 @@ configP = <$> (Left <$> pathP) <*> some moduleOption <*> pure []) + <*> switch (long "lsp-config" <> help "Read an LSP config payload from standard input") where moduleOption = strOption (long "example-module" <> metavar "PATH") @@ -324,9 +332,30 @@ runBenchmarksFun dir allBenchmarks = do whenJust (otMemoryProfiling ?config) $ \eventlogDir -> createDirectoryIfMissing True eventlogDir - results <- forM benchmarks $ \b@Bench{name} -> do - let run = runSessionWithConfig conf (cmd name dir) lspTestCaps dir - (b,) <$> runBench run b + lspConfig <- if Experiments.Types.lspConfig ?config + then either error Just . eitherDecodeStrict' <$> BS.getContents + else return Nothing + + let conf = defaultConfig + { logStdErr = verbose ?config, + logMessages = verbose ?config, + logColor = False, + Language.LSP.Test.lspConfig = lspConfig, + messageTimeout = timeoutLsp ?config + } + results <- forM benchmarks $ \b@Bench{name} -> do + let p = (proc (ghcide ?config) (allArgs name dir)) + { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } + run sess = withCreateProcess p $ \(Just inH) (Just outH) (Just errH) pH -> do + -- Need to continuously consume to stderr else it gets blocked + -- Can't pass NoStream either to std_err + hSetBuffering errH NoBuffering + hSetBinaryMode errH True + let errSinkThread = + forever $ hGetLine errH >>= when (verbose ?config). putStrLn + withAsync errSinkThread $ \_ -> do + runSessionWithHandles' (Just pH) inH outH conf lspTestCaps dir sess + (b,) <$> runBench run b -- output raw data as CSV let headers = @@ -335,31 +364,31 @@ runBenchmarksFun dir allBenchmarks = do , "samples" , "startup" , "setup" - , "userTime" - , "delayedTime" - , "firstBuildTime" - , "averageTimePerResponse" - , "totalTime" - , "buildRulesBuilt" - , "buildRulesChanged" - , "buildRulesVisited" - , "buildRulesTotal" - , "buildEdges" + , "userT" + , "delayedT" + , "1stBuildT" + , "avgPerRespT" + , "totalT" + , "rulesBuilt" + , "rulesChanged" + , "rulesVisited" + , "rulesTotal" + , "ruleEdges" , "ghcRebuilds" ] rows = [ [ name, show success, show samples, - show startup, - show runSetup', - show userWaits, - show delayedWork, - show $ firstResponse+firstResponseDelayed, + showMs startup, + showMs runSetup', + showMs userWaits, + showMs delayedWork, + showMs $ firstResponse+firstResponseDelayed, -- Exclude first response as it has a lot of setup time included -- Assume that number of requests = number of modules * number of samples - show ((userWaits - firstResponse)/((fromIntegral samples - 1)*modules)), - show runExperiment, + showMs ((userWaits - firstResponse)/((fromIntegral samples - 1)*modules)), + showMs runExperiment, show rulesBuilt, show rulesChanged, show rulesVisited, @@ -402,36 +431,32 @@ runBenchmarksFun dir allBenchmarks = do outputRow $ (map . map) (const '-') paddedHeaders forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row where - ghcideCmd dir = - [ ghcide ?config, - "--lsp", + ghcideArgs dir = + [ "--lsp", "--test", "--cwd", - dir, - "+RTS" + dir ] - cmd name dir = - unwords $ - ghcideCmd dir - ++ case otMemoryProfiling ?config of - Just dir -> ["-l", "-ol" ++ (dir map (\c -> if c == ' ' then '-' else c) name <.> "eventlog")] - Nothing -> [] - ++ [ "-RTS" ] + allArgs name dir = + ghcideArgs dir + ++ concat + [ [ "+RTS" + , "-l" + , "-ol" ++ (dir map (\c -> if c == ' ' then '-' else c) name <.> "eventlog") + , "-RTS" + ] + | Just dir <- [otMemoryProfiling ?config] + ] ++ ghcideOptions ?config ++ concat [ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config] ] - ++ ["--verbose" | verbose ?config] ++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]] lspTestCaps = fullCaps {_window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } - conf = - defaultConfig - { logStdErr = verbose ?config, - logMessages = verbose ?config, - logColor = False, - messageTimeout = timeoutLsp ?config - } + +showMs :: Seconds -> String +showMs = printf "%.2f" data BenchRun = BenchRun { startup :: !Seconds, @@ -483,7 +508,7 @@ waitForBuildQueue = do _ -> return 0 runBench :: - (?config :: Config) => + HasConfig => (Session BenchRun -> IO BenchRun) -> Bench -> IO BenchRun @@ -688,3 +713,42 @@ searchSymbol doc@TextDocumentIdentifier{_uri} fileContents pos = do checkCompletions pos = not . null <$> getCompletions doc pos + +getBuildKeysBuilt :: Session (Either ResponseError [T.Text]) +getBuildKeysBuilt = tryCallTestPlugin GetBuildKeysBuilt + +getBuildKeysVisited :: Session (Either ResponseError [T.Text]) +getBuildKeysVisited = tryCallTestPlugin GetBuildKeysVisited + +getBuildKeysChanged :: Session (Either ResponseError [T.Text]) +getBuildKeysChanged = tryCallTestPlugin GetBuildKeysChanged + +getBuildEdgesCount :: Session (Either ResponseError Int) +getBuildEdgesCount = tryCallTestPlugin GetBuildEdgesCount + +getRebuildsCount :: Session (Either ResponseError Int) +getRebuildsCount = tryCallTestPlugin GetRebuildsCount + +-- Copy&paste from ghcide/test/Development.IDE.Test +getStoredKeys :: Session [Text] +getStoredKeys = callTestPlugin GetStoredKeys + +-- Copy&paste from ghcide/test/Development.IDE.Test +tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b) +tryCallTestPlugin cmd = do + let cm = SCustomMethod "test" + waitId <- sendRequest cm (A.toJSON cmd) + ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId + return $ case _result of + Left e -> Left e + Right json -> case A.fromJSON json of + A.Success a -> Right a + A.Error e -> error e + +-- Copy&paste from ghcide/test/Development.IDE.Test +callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b +callTestPlugin cmd = do + res <- tryCallTestPlugin cmd + case res of + Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err + Right a -> pure a diff --git a/ghcide/bench/lib/Experiments/Types.hs b/ghcide-bench/src/Experiments/Types.hs similarity index 82% rename from ghcide/bench/lib/Experiments/Types.hs rename to ghcide-bench/src/Experiments/Types.hs index 633052efd6..303abaf8cd 100644 --- a/ghcide/bench/lib/Experiments/Types.hs +++ b/ghcide-bench/src/Experiments/Types.hs @@ -3,10 +3,12 @@ {-# LANGUAGE OverloadedStrings #-} module Experiments.Types (module Experiments.Types ) where +import Control.DeepSeq import Data.Aeson -import Data.Maybe (fromMaybe) +import Data.Binary (Binary) +import Data.Hashable (Hashable) +import Data.Maybe (fromMaybe) import Data.Version -import Development.Shake.Classes import GHC.Generics import Numeric.Natural @@ -27,7 +29,8 @@ data Config = Config repetitions :: Maybe Natural, ghcide :: FilePath, timeoutLsp :: Int, - example :: Example + example :: Example, + lspConfig :: Bool } deriving (Eq, Show) @@ -64,11 +67,13 @@ exampleToOptions :: Example -> [String] -> [String] exampleToOptions Example{exampleDetails = Right ExamplePackage{..}, ..} extraArgs = ["--example-package-name", packageName ,"--example-package-version", showVersion packageVersion - ,"--ghcide-options", unwords $ exampleExtraArgs ++ extraArgs ] ++ - ["--example-module=" <> m | m <- exampleModules] + ["--example-module=" <> m | m <- exampleModules + ] ++ + ["--ghcide-options=" <> o | o <- exampleExtraArgs ++ extraArgs] exampleToOptions Example{exampleDetails = Left examplePath, ..} extraArgs = ["--example-path", examplePath - ,"--ghcide-options", unwords $ exampleExtraArgs ++ extraArgs ] ++ - ["--example-module=" <> m | m <- exampleModules] + ["--example-module=" <> m | m <- exampleModules + ] ++ + ["--ghcide-options=" <> o | o <- exampleExtraArgs ++ extraArgs] diff --git a/ghcide-bench/test/Main.hs b/ghcide-bench/test/Main.hs new file mode 100644 index 0000000000..beb5066ddb --- /dev/null +++ b/ghcide-bench/test/Main.hs @@ -0,0 +1,48 @@ +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE PolyKinds #-} +{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} + +module Main (main) where + +import Data.List.Extra +import qualified Experiments as Bench +import Language.LSP.Test +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Ingredients.Rerun (defaultMainWithRerun) + +main :: IO () +main = defaultMainWithRerun benchmarkTests + +benchmarkTests :: TestTree +benchmarkTests = + let ?config = Bench.defConfig + { Bench.verbosity = Bench.Quiet + , Bench.repetitions = Just 3 + , Bench.buildTool = Bench.Cabal + } in + withResource Bench.setup Bench.cleanUp $ \getResource -> testGroup "benchmark experiments" + [ testCase (Bench.name e) $ do + Bench.SetupResult{Bench.benchDir} <- getResource + res <- Bench.runBench (runInDir benchDir) e + assertBool "did not successfully complete 5 repetitions" $ Bench.success res + | e <- Bench.experiments + , Bench.name e /= "edit" -- the edit experiment does not ever fail + , Bench.name e /= "hole fit suggestions" -- is too slow! + -- the cradle experiments are way too slow + , not ("cradle" `isInfixOf` Bench.name e) + ] + +runInDir :: FilePath -> Session a -> IO a +runInDir dir = runSessionWithConfig defaultConfig cmd fullCaps dir + where + -- TODO use HLS instead of ghcide + cmd = "ghcide --lsp --test --verbose -j2 --cwd " <> dir diff --git a/ghcide/.gitignore b/ghcide/.gitignore index 3544e898b0..8370c00874 100644 --- a/ghcide/.gitignore +++ b/ghcide/.gitignore @@ -7,11 +7,6 @@ cabal.project.local /.tasty-rerun-log .vscode /.hlint-* -bench/example/* -# don't ignore the example file, we need it! -!bench/example/HLS -bench-results/ -bench-temp/ .shake/ ghcide ghcide-bench diff --git a/ghcide/bench-results/.artifactignore b/ghcide/bench-results/.artifactignore deleted file mode 100644 index 326f663a2b..0000000000 --- a/ghcide/bench-results/.artifactignore +++ /dev/null @@ -1,4 +0,0 @@ -ghcide -ghcide-bench -ghcide-preprocessor -*.benchmark-gcStats diff --git a/ghcide/bench/config.yaml b/ghcide/bench/config.yaml deleted file mode 100644 index a744f56e17..0000000000 --- a/ghcide/bench/config.yaml +++ /dev/null @@ -1,116 +0,0 @@ -# The number of samples to run per experiment. -# At least 100 is recommended in order to observe space leaks -samples: 50 - -buildTool: cabal - -# Output folder for the experiments -outputFolder: bench-results - -# Example project used to run the experiments -# Can either be a Hackage package (name,version) -# or a local project (path) with a valid `hie.yaml` file -examples: - # Medium-sized project without TH - - name: cabal - package: Cabal - version: 3.6.3.0 - modules: - - src/Distribution/Simple.hs - - src/Distribution/Types/Module.hs - extra-args: [] # extra ghcide command line args - - name: cabal-1module - package: Cabal - version: 3.6.3.0 - modules: - - src/Distribution/Simple.hs - - name: cabal-conservative - package: Cabal - version: 3.6.3.0 - modules: - - src/Distribution/Simple.hs - - src/Distribution/Types/Module.hs - extra-args: # extra ghcide command line args - - --conservative-change-tracking - # Small-sized project with TH - - name: lsp-types - package: lsp-types - version: 1.5.0.0 - modules: - - src/Language/LSP/Types/WatchedFiles.hs - - src/Language/LSP/Types/CallHierarchy.hs - - name: lsp-types-conservative - package: lsp-types - version: 1.5.0.0 - modules: - - src/Language/LSP/Types/WatchedFiles.hs - - src/Language/LSP/Types/CallHierarchy.hs - extra-args: - - --conservative-change-tracking - # Small-sized project with TH - # Small but heavily multi-component example - # Disabled as it is far to slow. hie-bios >0.7.2 should help - # - name: HLS - # path: bench/example/HLS - # modules: - # - hls-plugin-api/src/Ide/Plugin/Config.hs - # - ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs - # - ghcide/bench/hist/Main.hs - # - ghcide/bench/lib/Experiments/Types.hs - # - ghcide/test/exe/Main.hs - # - exe/Plugins.hs - -# The set of experiments to execute -experiments: - - "edit" - - "hover" - - "hover after edit" - # - "hover after cradle edit" - - "getDefinition" - - "getDefinition after edit" - - "completions" - - "completions after edit" - - "code actions" - - "code actions after edit" - - "code actions after cradle edit" - - "documentSymbols after edit" - - "hole fit suggestions" - -# An ordered list of versions to analyze -versions: -# A version can be defined briefly: -# - -# - -# - - -# Or in extended form, where all the fields are optional: -# - : -# git: -# include: true # whether to include in comparison graphs -# parent: # version to compare with in .diff graphs - - -# - ghcide-v0.0.5 -# - ghcide-v0.0.6 -# - ghcide-v0.1.0 -# - ghcide-v0.2.0 -# - ghcide-v0.3.0 -# - ghcide-v0.4.0 -# - ghcide-v0.5.0 -# - ghcide-v0.6.0 -# - ghcide-v0.7.0 -# - ghcide-v0.7.1 -# - ghcide-v0.7.2 -# - ghcide-v0.7.3 -# - ghcide-v0.7.4 -# - ghcide-v0.7.5 -# - 1.0.0 -# - ghcide-v1.1.0 -# - ghcide-v1.2.0 -# - ghcide-v1.3.0 -- upstream: origin/master -- HEAD - -# Heap profile interval in seconds (+RTS -i) -# Comment out to disable heap profiling -profileInterval: 1 diff --git a/ghcide/bench/hist/Main.hs b/ghcide/bench/hist/Main.hs deleted file mode 100644 index f09e247268..0000000000 --- a/ghcide/bench/hist/Main.hs +++ /dev/null @@ -1,192 +0,0 @@ -{- Bench history - - A Shake script to analyze the performance of ghcide 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 - │  ├── ghcide - 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 #-} - -import Control.Monad.Extra -import Data.Foldable (find) -import Data.Maybe -import Data.Yaml (FromJSON (..), decodeFileThrow) -import Development.Benchmark.Rules -import Development.Shake -import Development.Shake.Classes -import Experiments.Types (Example (exampleName), - exampleToOptions) -import GHC.Generics (Generic) -import Numeric.Natural (Natural) -import System.Console.GetOpt -import System.FilePath - -configPath :: FilePath -configPath = "bench/config.yaml" - -configOpt :: OptDescr (Either String FilePath) -configOpt = Option [] ["config"] (ReqArg Right configPath) "config file" - --- | 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 - -ghcideBuildRules :: MkBuildRules BuildSystem -ghcideBuildRules = MkBuildRules findGhcForBuildSystem "ghcide" projectDepends buildGhcide - where - projectDepends = do - need . map ("../hls-graph/src" ) =<< getDirectoryFiles "../hls-graph/src" ["//*.hs"] - need . map ("../hls-plugin-api/src" ) =<< getDirectoryFiles "../hls-plugin-api/src" ["//*.hs"] - need . map ("src" ) =<< getDirectoryFiles "src" ["//*.hs"] - need . map ("session-loader" ) =<< getDirectoryFiles "session-loader" ["//*.hs"] - need =<< getDirectoryFiles "." ["*.cabal"] - --------------------------------------------------------------------------------- - -data Config buildSystem = Config - { experiments :: [Unescaped String], - examples :: [Example], - samples :: Natural, - versions :: [GitCommit], - -- | Output folder ('foo' works, 'foo/bar' does not) - outputFolder :: String, - buildTool :: buildSystem, - profileInterval :: Maybe Double - } - 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 - - configStatic <- liftIO $ readConfigIO config - let build = outputFolder configStatic - - buildRules build ghcideBuildRules - benchRules build (MkBenchRules (askOracle $ GetSamples ()) benchGhcide warmupGhcide "ghcide") - csvRules build - svgRules build - heapProfileRules build - phonyRules "" "ghcide" NoProfiling build (examples configStatic) - - whenJust (profileInterval configStatic) $ \i -> do - phonyRules "profiled-" "ghcide" (CheapHeapProfiling i) build (examples configStatic) - - return configStatic - -newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show) -type instance RuleResult GetSamples = Natural - --------------------------------------------------------------------------------- - -buildGhcide :: BuildSystem -> [CmdOption] -> FilePath -> Action () -buildGhcide Cabal args out = do - command_ args "cabal" - ["install" - ,"exe:ghcide" - ,"--installdir=" ++ out - ,"--install-method=copy" - ,"--overwrite-policy=always" - ,"--ghc-options=-rtsopts" - ,"--ghc-options=-eventlog" - ] - -buildGhcide Stack args out = - command_ args "stack" - ["--local-bin-path=" <> out - ,"build" - ,"ghcide:ghcide" - ,"--copy-bins" - ,"--ghc-options=-rtsopts" - ,"--ghc-options=-eventlog" - ] - -benchGhcide - :: Natural -> BuildSystem -> [CmdOption] -> BenchProject Example -> Action () -benchGhcide samples buildSystem args BenchProject{..} = do - command_ args "ghcide-bench" $ - [ "--timeout=300", - "--no-clean", - "-v", - "--samples=" <> show samples, - "--csv=" <> outcsv, - "--ghcide=" <> exePath, - "--select", - unescaped (unescapeExperiment experiment) - ] ++ - exampleToOptions example exeExtraArgs ++ - [ "--stack" | Stack == buildSystem - ] - -warmupGhcide :: BuildSystem -> FilePath -> [CmdOption] -> Example -> Action () -warmupGhcide buildSystem exePath args example = do - command args "ghcide-bench" $ - [ "--no-clean", - "-v", - "--samples=1", - "--ghcide=" <> exePath, - "--select=hover" - ] ++ - exampleToOptions example [] ++ - [ "--stack" | Stack == buildSystem - ] diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 8db4b73e50..e3af7960ce 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -1,4 +1,4 @@ -cabal-version: 2.4 +cabal-version: 3.0 build-type: Simple category: Development name: ghcide @@ -267,45 +267,6 @@ executable ghcide-test-preprocessor if !flag(test-exe) buildable: False -benchmark benchHist - type: exitcode-stdio-1.0 - default-language: Haskell2010 - ghc-options: -Wall -Wno-name-shadowing -threaded - main-is: Main.hs - hs-source-dirs: bench/hist bench/lib - other-modules: Experiments.Types - build-tool-depends: - ghcide: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.*, - shake-bench == 0.1.*, - directory, - extra, - filepath, - lens, - optparse-applicative, - shake, - text, - yaml - flag executable description: Build the ghcide executable default: True @@ -389,8 +350,6 @@ test-suite ghcide-tests aeson, async, base, - binary, - bytestring, containers, data-default, directory, @@ -407,7 +366,6 @@ test-suite ghcide-tests -------------------------------------------------------------- ghcide, ghc-typelits-knownnat, - haddock-library, lsp, lsp-types, hls-plugin-api, @@ -416,20 +374,13 @@ test-suite ghcide-tests lsp-test ^>= 0.14, monoid-subclasses, network-uri, - optparse-applicative, - parallel, - process, QuickCheck, - quickcheck-instances, random, regex-tdfa ^>= 1.3.1, - safe, - safe-exceptions, shake, sqlite-simple, stm, stm-containers, - hls-graph, tasty, tasty-expected-failure, tasty-hunit >= 0.10, @@ -438,7 +389,6 @@ test-suite ghcide-tests text, text-rope, unordered-containers, - vector, if (impl(ghc >= 8.6) && impl(ghc < 9.2)) build-depends: record-dot-preprocessor, @@ -450,8 +400,6 @@ test-suite ghcide-tests Development.IDE.Test Development.IDE.Test.Diagnostic Development.IDE.Test.Runfiles - Experiments - Experiments.Types FuzzySearch Progress HieDbRetry @@ -470,59 +418,3 @@ test-suite ghcide-tests TupleSections TypeApplications ViewPatterns - -flag bench-exe - description: Build the ghcide-bench executable - default: True - -executable ghcide-bench - default-language: Haskell2010 - build-tool-depends: - ghcide:ghcide - build-depends: - aeson, - base, - bytestring, - containers, - data-default, - directory, - extra, - filepath, - ghcide, - hls-plugin-api, - lens, - lsp-test, - lsp-types, - optparse-applicative, - process, - safe-exceptions, - hls-graph, - shake, - tasty-hunit >= 0.10, - text - hs-source-dirs: bench/lib bench/exe test/src - ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts - main-is: Main.hs - other-modules: - Development.IDE.Test - Development.IDE.Test.Diagnostic - Experiments - Experiments.Types - default-extensions: - BangPatterns - DeriveFunctor - DeriveGeneric - FlexibleContexts - GeneralizedNewtypeDeriving - LambdaCase - NamedFieldPuns - OverloadedStrings - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - ViewPatterns - - if !flag(bench-exe) - buildable: False diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 73caa02437..787e6941c4 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -65,7 +65,6 @@ import Development.IDE.Test.Runfiles import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location import Development.Shake (getDirectoryFilesIO) -import qualified Experiments as Bench import Ide.Plugin.Config import Language.LSP.Test import Language.LSP.Types hiding @@ -221,7 +220,6 @@ main = do , cradleTests , dependentFileTest , nonLspCommandLine - , benchmarkTests , ifaceTests , bootTests , rootUriTests @@ -6311,25 +6309,6 @@ nonLspCommandLine = testGroup "ghcide command line" ec @?= ExitSuccess ] -benchmarkTests :: TestTree -benchmarkTests = - let ?config = Bench.defConfig - { Bench.verbosity = Bench.Quiet - , Bench.repetitions = Just 3 - , Bench.buildTool = Bench.Cabal - } in - withResource Bench.setup Bench.cleanUp $ \getResource -> testGroup "benchmark experiments" - [ testCase (Bench.name e) $ do - Bench.SetupResult{Bench.benchDir} <- getResource - res <- Bench.runBench (runInDir benchDir) e - assertBool "did not successfully complete 5 repetitions" $ Bench.success res - | e <- Bench.experiments - , Bench.name e /= "edit" -- the edit experiment does not ever fail - , Bench.name e /= "hole fit suggestions" -- is too slow! - -- the cradle experiments are way too slow - , not ("cradle" `isInfixOf` Bench.name e) - ] - -- | checks if we use InitializeParams.rootUri for loading session rootUriTests :: TestTree rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index b4385043be..216020a89e 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -29,11 +29,6 @@ module Development.IDE.Test , getStoredKeys , waitForCustomMessage , waitForGC - , getBuildKeysBuilt - , getBuildKeysVisited - , getBuildKeysChanged - , getBuildEdgesCount - , getRebuildsCount , configureCheckProject , isReferenceReady , referenceReady) where @@ -214,21 +209,6 @@ waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResul waitForAction key TextDocumentIdentifier{_uri} = callTestPlugin (WaitForIdeRule key _uri) -getBuildKeysBuilt :: Session (Either ResponseError [T.Text]) -getBuildKeysBuilt = tryCallTestPlugin GetBuildKeysBuilt - -getBuildKeysVisited :: Session (Either ResponseError [T.Text]) -getBuildKeysVisited = tryCallTestPlugin GetBuildKeysVisited - -getBuildKeysChanged :: Session (Either ResponseError [T.Text]) -getBuildKeysChanged = tryCallTestPlugin GetBuildKeysChanged - -getBuildEdgesCount :: Session (Either ResponseError Int) -getBuildEdgesCount = tryCallTestPlugin GetBuildEdgesCount - -getRebuildsCount :: Session (Either ResponseError Int) -getRebuildsCount = tryCallTestPlugin GetRebuildsCount - getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index d786e71530..694f057534 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1,4 +1,4 @@ -cabal-version: 2.4 +cabal-version: 3.0 category: Development name: haskell-language-server version: 1.7.0.0 @@ -233,12 +233,6 @@ flag dynamic default: True manual: True -common example-plugins - hs-source-dirs: plugins/default/src - other-modules: Ide.Plugin.Example, - Ide.Plugin.Example2, - Ide.Plugin.ExampleCabal - common class if flag(class) build-depends: hls-class-plugin ^>= 1.0 @@ -366,13 +360,12 @@ common brittany build-depends: hls-brittany-plugin ^>= 1.0 cpp-options: -Dhls_brittany -executable haskell-language-server +library plugins import: common-deps -- configuration , warnings , pedantic -- plugins - , example-plugins , callHierarchy , changeTypeSignature , class @@ -398,10 +391,20 @@ executable haskell-language-server , ormolu , stylishHaskell , brittany + exposed-modules: HlsPlugins + hs-source-dirs: src + + build-depends: ghcide, hls-plugin-api + 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 @@ -438,6 +441,7 @@ executable haskell-language-server , ghcide , hashable , haskell-language-server + , haskell-language-server:plugins , lsp , hie-bios , hiedb @@ -579,3 +583,47 @@ test-suite wrapper-test 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:plugins, + hls-plugin-api, + lens, + lens-aeson, + optparse-applicative, + shake, + shake-bench == 0.1.*, + text, + yaml diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 95c04f24c5..4877b5271b 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -704,7 +704,7 @@ type CommandFunction ideState a newtype PluginId = PluginId T.Text deriving (Show, Read, Eq, Ord) - deriving newtype Hashable + deriving newtype (FromJSON, Hashable) instance IsString PluginId where fromString = PluginId . T.pack diff --git a/plugins/default/src/Ide/Plugin/Example.hs b/plugins/default/src/Ide/Plugin/Example.hs deleted file mode 100644 index 33bf8720fa..0000000000 --- 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 Data.Hashable -import qualified Data.HashMap.Strict as Map -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 index 8ba3a69b68..0000000000 --- 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 Data.Hashable -import qualified Data.HashMap.Strict as Map -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/plugins/default/src/Ide/Plugin/ExampleCabal.hs b/plugins/default/src/Ide/Plugin/ExampleCabal.hs deleted file mode 100644 index 39a64f220a..0000000000 --- a/plugins/default/src/Ide/Plugin/ExampleCabal.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module Ide.Plugin.ExampleCabal where - -import Control.Monad.IO.Class -import Data.Aeson -import qualified Data.HashMap.Strict as Map -import qualified Data.Text as T -import Development.IDE as D hiding (pluginHandlers) -import GHC.Generics -import Ide.PluginUtils -import Ide.Types -import Language.LSP.Server -import Language.LSP.Types - -newtype Log = LogText T.Text deriving Show - -instance Pretty Log where - pretty = \case - LogText log -> pretty log - -descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = (defaultCabalPluginDescriptor plId) - { pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] - , pluginHandlers = mkPluginHandler STextDocumentCodeLens (codeLens recorder) - } - --- --------------------------------------------------------------------- - -codeLens :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState TextDocumentCodeLens -codeLens recorder _ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = liftIO $ do - log Debug $ LogText "ExampleCabal.codeLens entered (ideLogger)" - case uriToFilePath' uri of - Just (toNormalizedFilePath -> _filePath) -> do - let - title = "Add TODO 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 [] - where - log = logWith recorder - --- --------------------------------------------------------------------- --- | 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 diff --git a/shake-bench/shake-bench.cabal b/shake-bench/shake-bench.cabal index cd4474f36e..ec1649ccd5 100644 --- a/shake-bench/shake-bench.cabal +++ b/shake-bench/shake-bench.cabal @@ -17,6 +17,7 @@ library build-depends: aeson, base == 4.*, + bytestring, Chart, Chart-diagrams, diagrams-contrib, diff --git a/shake-bench/src/Development/Benchmark/Rules.hs b/shake-bench/src/Development/Benchmark/Rules.hs index a68507e604..7d5e4dcef9 100644 --- a/shake-bench/src/Development/Benchmark/Rules.hs +++ b/shake-bench/src/Development/Benchmark/Rules.hs @@ -26,20 +26,22 @@ ├── binaries │ └── │  ├── ghc.path - path to ghc used to build the executable - │  └── - binary for this version + │  ├── - binary for this version │  └── commitid - Git commit id for this reference ├─ - │ ├── 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 - │   ├── .heap.svg - Heap profile - │   ├── .log - bench stdout - │   └── 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 + │ ├── results.csv - aggregated results for all the versions and configurations + │ ├── .svg - graph of bytes over elapsed time, for all the versions and configurations + | └── + │ └── + │   ├── .gcStats.log - RTS -s output + │   ├── .csv - stats for the experiment + │   ├── .svg - Graph of bytes over elapsed time + │   ├── .diff.svg - idem, including the previous version + │   ├── .heap.svg - Heap profile + │   ├── .log - bench stdout + │   └── results.csv - results of all the experiments for the example + ├── results.csv - aggregated results of all the examples, experiments, versions and configurations + └── .svg - graph of bytes over elapsed time, for all the examples, experiments, versions and configuratiof 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`. @@ -47,7 +49,7 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Development.Benchmark.Rules ( - buildRules, MkBuildRules(..), + buildRules, MkBuildRules(..), OutputFolder, ProjectRoot, benchRules, MkBenchRules(..), BenchProject(..), ProfilingMode(..), csvRules, svgRules, @@ -60,6 +62,7 @@ module Development.Benchmark.Rules GetVersions(..), GetCommitId(..), GetBuildSystem(..), + GetConfigurations(..), Configuration(..), BuildSystem(..), findGhcForBuildSystem, Escaped(..), Unescaped(..), escapeExperiment, unescapeExperiment, GitCommit @@ -76,6 +79,7 @@ import Data.Aeson (FromJSON (..), (.!=), (.:?), (.=)) import Data.Aeson.Lens (AsJSON (_JSON), _Object, _String) +import Data.ByteString.Lazy (ByteString) import Data.Char (isDigit) import Data.List (find, isInfixOf, stripPrefix, @@ -94,6 +98,7 @@ import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import qualified Graphics.Rendering.Chart.Backend.Diagrams as E import qualified Graphics.Rendering.Chart.Easy as E +import Numeric.Natural import System.Directory (createDirectoryIfMissing, findExecutable, renameFile) @@ -112,6 +117,7 @@ newtype GetCommitId = GetCommitId String deriving newtype (Binary, Eq, Hashable, newtype GetBuildSystem = GetBuildSystem () deriving newtype (Binary, Eq, Hashable, NFData, Show) newtype GetExample = GetExample String deriving newtype (Binary, Eq, Hashable, NFData, Show) newtype GetExamples = GetExamples () deriving newtype (Binary, Eq, Hashable, NFData, Show) +newtype GetConfigurations = GetConfigurations () deriving newtype (Binary, Eq, Hashable, NFData, Show) type instance RuleResult GetExperiments = [Unescaped String] type instance RuleResult GetVersions = [GitCommit] @@ -124,6 +130,10 @@ type RuleResultForExample e = , RuleResult GetExamples ~ [e] , IsExample e) +data Configuration = Configuration {confName :: String, confValue :: ByteString} + deriving (Binary, Eq, Generic, Hashable, NFData, Show, Typeable) +type instance RuleResult GetConfigurations = [Configuration] + -- | Knowledge needed to run an example class (Binary e, Eq e, Hashable e, NFData e, Show e, Typeable e) => IsExample e where getExampleName :: e -> String @@ -134,6 +144,7 @@ allTargetsForExample :: IsExample e => ProfilingMode -> FilePath -> e -> Action allTargetsForExample prof baseFolder ex = do experiments <- askOracle $ GetExperiments () versions <- askOracle $ GetVersions () + configurations <- askOracle $ GetConfigurations () let buildFolder = baseFolder profilingPath prof return $ [buildFolder getExampleName ex "results.csv"] @@ -143,9 +154,12 @@ allTargetsForExample prof baseFolder ex = do ++ [ buildFolder getExampleName ex T.unpack (humanName ver) - escaped (escapeExperiment e) <.> mode + confName + escaped (escapeExperiment e) <.> + mode | e <- experiments, ver <- versions, + Configuration{confName} <- configurations, mode <- ["svg", "diff.svg"] ++ ["heap.svg" | prof /= NoProfiling] ] @@ -179,6 +193,7 @@ phonyRules prefix executableName prof buildFolder examples = do phony (prefix <> "all-binaries") $ need =<< allBinaries buildFolder executableName -------------------------------------------------------------------------------- type OutputFolder = FilePath +type ProjectRoot = FilePath data MkBuildRules buildSystem = MkBuildRules { -- | Return the path to the GHC executable to use for the project found in the cwd @@ -187,9 +202,9 @@ data MkBuildRules buildSystem = MkBuildRules , executableName :: String -- | An action that captures the source dependencies, used for the HEAD build , projectDepends :: Action () - -- | Build the project found in the cwd and save the build artifacts in the output folder + -- | Build the project found in the given path and save the build artifacts in the output folder , buildProject :: buildSystem - -> [CmdOption] + -> ProjectRoot -> OutputFolder -> Action () } @@ -217,7 +232,7 @@ buildRules build MkBuildRules{..} = do projectDepends liftIO $ createDirectoryIfMissing True $ dropFileName out buildSystem <- askOracle $ GetBuildSystem () - buildProject buildSystem [Cwd "."] (takeDirectory out) + buildProject buildSystem "." (takeDirectory out) ghcLoc <- liftIO $ findGhc buildSystem "." writeFile' ghcpath ghcLoc @@ -232,7 +247,7 @@ buildRules build MkBuildRules{..} = do buildSystem <- askOracle $ GetBuildSystem () flip actionFinally (cmd_ ("git worktree remove bench-temp-" <> ver <> " --force" :: String)) $ do ghcLoc <- liftIO $ findGhc buildSystem ver - buildProject buildSystem [Cwd $ "bench-temp-" <> ver] (".." takeDirectory out) + buildProject buildSystem ("bench-temp-" <> ver) (".." takeDirectory out) writeFile' ghcPath ghcLoc -------------------------------------------------------------------------------- @@ -246,14 +261,17 @@ data MkBenchRules buildSystem example = forall setup. MkBenchRules , warmupProject :: buildSystem -> FilePath -> [CmdOption] -> example -> Action () -- | Name of the executable to benchmark. Should match the one used to 'MkBuildRules' , executableName :: String + -- | Number of concurrent benchmarks to run + , parallelism :: Natural } data BenchProject example = BenchProject - { outcsv :: FilePath -- ^ where to save the CSV output - , exePath :: FilePath -- ^ where to find the executable for benchmarking - , exeExtraArgs :: [String] -- ^ extra args for the executable - , example :: example -- ^ example to benchmark - , experiment :: Escaped String -- ^ experiment to run + { outcsv :: FilePath -- ^ where to save the CSV output + , exePath :: FilePath -- ^ where to find the executable for benchmarking + , exeExtraArgs :: [String] -- ^ extra args for the executable + , example :: example -- ^ example to benchmark + , experiment :: Escaped String -- ^ experiment to run + , configuration :: ByteString -- ^ configuration to use } data ProfilingMode = NoProfiling | CheapHeapProfiling Seconds @@ -272,7 +290,7 @@ profilingPath (CheapHeapProfiling i) = "profiled-" <> show i benchRules :: RuleResultForExample example => FilePattern -> MkBenchRules BuildSystem example -> Rules () benchRules build MkBenchRules{..} = do - benchResource <- newResource "ghcide-bench" 1 + benchResource <- newResource "ghcide-bench" (fromIntegral parallelism) -- warmup an example build -/- "binaries/*/*.warmup" %> \out -> do let [_, _, ver, exampleName] = splitDirectories (dropExtension out) @@ -295,33 +313,38 @@ benchRules build MkBenchRules{..} = do example -- run an experiment priority 0 $ - [ build -/- "*/*/*/*.csv", - build -/- "*/*/*/*.gcStats.log", - build -/- "*/*/*/*.output.log", - build -/- "*/*/*/*.eventlog", - build -/- "*/*/*/*.hp" + [ build -/- "*/*/*/*/*.csv", + build -/- "*/*/*/*/*.gcStats.log", + build -/- "*/*/*/*/*.output.log", + build -/- "*/*/*/*/*.eventlog", + build -/- "*/*/*/*/*.hp" ] &%> \[outcsv, outGc, outLog, outEventlog, outHp] -> do - let [_, flavour, exampleName, ver, exp] = splitDirectories outcsv + let [_, flavour, exampleName, ver, conf, exp] = splitDirectories outcsv prof = fromMaybe (error $ "Not a valid profiling mode: " <> flavour) $ profilingP flavour example <- fromMaybe (error $ "Unknown example " <> exampleName) <$> askOracle (GetExample exampleName) buildSystem <- askOracle $ GetBuildSystem () + configurations <- askOracle $ GetConfigurations () setupRes <- setupProject liftIO $ createDirectoryIfMissing True $ dropFileName outcsv let exePath = build "binaries" ver executableName exeExtraArgs = [ "+RTS" , "-l" + , "-ol" <> outEventlog , "-S" <> outGc] ++ concat [[ "-h" , "-i" <> show i + , "-po" <> outHp , "-qg"] | CheapHeapProfiling i <- [prof]] ++ ["-RTS"] ghcPath = build "binaries" ver "ghc.path" warmupPath = build "binaries" ver exampleName <.> "warmup" experiment = Escaped $ dropExtension exp + Just Configuration{..} = find (\Configuration{confName} -> confName == conf) configurations + configuration = confValue need [exePath, ghcPath, warmupPath] ghcPath <- readFile' ghcPath withResource benchResource 1 $ do @@ -333,10 +356,9 @@ benchRules build MkBenchRules{..} = do AddPath [takeDirectory ghcPath, "."] [] ] BenchProject {..} - liftIO $ renameFile "ghcide.eventlog" outEventlog liftIO $ case prof of - CheapHeapProfiling{} -> renameFile "ghcide.hp" outHp - NoProfiling -> writeFile outHp dummyHp + NoProfiling -> writeFile outHp dummyHp + _ -> return () -- extend csv output with allocation data csvContents <- liftIO $ lines <$> readFile outcsv @@ -370,7 +392,7 @@ parseMaxResidencyAndAllocations input = csvRules :: forall example . RuleResultForExample example => FilePattern -> Rules () csvRules build = do -- build results for every experiment*example - build -/- "*/*/*/results.csv" %> \out -> do + build -/- "*/*/*/*/results.csv" %> \out -> do experiments <- askOracle $ GetExperiments () let allResultFiles = [takeDirectory out escaped (escapeExperiment e) <.> "csv" | e <- experiments] @@ -380,6 +402,20 @@ csvRules build = do results = map tail allResults writeFileChanged out $ unlines $ header : concat results + -- aggregate all configurations for an experiment + build -/- "*/*/*/results.csv" %> \out -> do + configurations <- map confName <$> askOracle (GetConfigurations ()) + let allResultFiles = [takeDirectory out c "results.csv" | c <- configurations ] + + allResults <- traverse readFileLines allResultFiles + + let header = head $ head allResults + results = map tail allResults + header' = "configuration, " <> header + results' = zipWith (\v -> map (\l -> v <> ", " <> l)) configurations results + + writeFileChanged out $ unlines $ header' : interleave results' + -- aggregate all experiments for an example build -/- "*/*/results.csv" %> \out -> do versions <- map (T.unpack . humanName) <$> askOracle (GetVersions ()) @@ -416,44 +452,60 @@ svgRules build = do void $ addOracle $ \(GetParent name) -> findPrev name <$> askOracle (GetVersions ()) -- chart GC stats for an experiment on a given revision priority 1 $ - build -/- "*/*/*/*.svg" %> \out -> do - let [_, _, _example, ver, _exp] = splitDirectories out - runLog <- loadRunLog (Escaped $ replaceExtension out "csv") ver + build -/- "*/*/*/*/*.svg" %> \out -> do + let [_, _, _example, ver, conf, _exp] = splitDirectories out + runLog <- loadRunLog (Escaped $ replaceExtension out "csv") ver conf let diagram = Diagram Live [runLog] title title = ver <> " live bytes over time" plotDiagram True diagram out -- chart of GC stats for an experiment on this and the previous revision priority 2 $ - build -/- "*/*/*/*.diff.svg" %> \out -> do - let [b, flav, example, ver, exp_] = splitDirectories out + build -/- "*/*/*/*/*.diff.svg" %> \out -> do + let [b, flav, example, ver, conf, exp_] = splitDirectories out exp = Escaped $ dropExtension2 exp_ prev <- fmap T.unpack $ askOracle $ GetParent $ T.pack ver - runLog <- loadRunLog (Escaped $ replaceExtension (dropExtension out) "csv") ver - runLogPrev <- loadRunLog (Escaped $ joinPath [b,flav, example, prev, replaceExtension (dropExtension exp_) "csv"]) prev + runLog <- loadRunLog (Escaped $ replaceExtension (dropExtension out) "csv") ver conf + runLogPrev <- loadRunLog (Escaped $ joinPath [b,flav, example, prev, conf, replaceExtension (dropExtension exp_) "csv"]) prev conf let diagram = Diagram Live [runLog, runLogPrev] title title = show (unescapeExperiment exp) <> " - live bytes over time compared" plotDiagram True diagram out + -- aggregated chart of GC stats for all the configurations + build -/- "*/*/*/*.svg" %> \out -> do + let exp = Escaped $ dropExtension $ takeFileName out + [b, flav, example, ver] = splitDirectories out + versions <- askOracle $ GetVersions () + configurations <- askOracle $ GetConfigurations () + + runLogs <- forM configurations $ \Configuration{confName} -> do + loadRunLog (Escaped $ takeDirectory out confName replaceExtension (takeFileName out) "csv") ver confName + + let diagram = Diagram Live runLogs title + title = show (unescapeExperiment exp) <> " - live bytes over time" + plotDiagram False diagram out + -- aggregated chart of GC stats for all the revisions build -/- "*/*/*.svg" %> \out -> do let exp = Escaped $ dropExtension $ takeFileName out versions <- askOracle $ GetVersions () + configurations <- askOracle $ GetConfigurations () - runLogs <- forM (filter include versions) $ \v -> do + runLogs <- forM (filter include versions) $ \v -> + forM configurations $ \Configuration{confName} -> do let v' = T.unpack (humanName v) - loadRunLog (Escaped $ takeDirectory out v' replaceExtension (takeFileName out) "csv") v' + loadRunLog (Escaped $ takeDirectory out v' confName replaceExtension (takeFileName out) "csv") v' confName - let diagram = Diagram Live runLogs title + let diagram = Diagram Live (concat runLogs) title title = show (unescapeExperiment exp) <> " - live bytes over time" plotDiagram False diagram out heapProfileRules :: FilePattern -> Rules () heapProfileRules build = do priority 3 $ - build -/- "*/*/*/*.heap.svg" %> \out -> do + build -/- "*/*/*/*/*.heap.svg" %> \out -> do let hpFile = dropExtension2 out <.> "hp" need [hpFile] cmd_ ("hp2pretty" :: String) [hpFile] @@ -563,14 +615,15 @@ instance Read Frame where -- | A file path containing the output of -S for a given run data RunLog = RunLog - { runVersion :: !String, - runFrames :: ![Frame], - runSuccess :: !Bool, - runFirstReponse :: !(Maybe Seconds) + { runVersion :: !String, + runConfiguration :: !String, + runFrames :: ![Frame], + runSuccess :: !Bool, + runFirstReponse :: !(Maybe Seconds) } -loadRunLog :: HasCallStack => Escaped FilePath -> String -> Action RunLog -loadRunLog (Escaped csv_fp) ver = do +loadRunLog :: HasCallStack => Escaped FilePath -> String -> String -> Action RunLog +loadRunLog (Escaped csv_fp) ver conf = do let log_fp = replaceExtension csv_fp "gcStats.log" log <- readFileLines log_fp csv <- readFileLines csv_fp @@ -591,7 +644,7 @@ loadRunLog (Escaped csv_fp) ver = do , Just s <- readMaybe (T.unpack s) -> (s,timeForFirstResponse) _ -> error $ "Cannot parse: " <> csv_fp - return $ RunLog ver frames success firstResponse + return $ RunLog ver conf frames success firstResponse -------------------------------------------------------------------------------- @@ -631,7 +684,7 @@ plotDiagram includeFailed t@Diagram {traceMetric, runLogs} out = do ~(c:_) <- E.liftCState $ S.gets (E.view E.colors) E.plot $ do lplot <- E.line - (runVersion rl ++ if runSuccess rl then "" else " (FAILED)") + (runVersion rl ++ " " ++ runConfiguration rl ++ if runSuccess rl then "" else " (FAILED)") [ [ (totElapsed f, extract f) | f <- runFrames rl ] diff --git a/exe/Plugins.hs b/src/HlsPlugins.hs similarity index 88% rename from exe/Plugins.hs rename to src/HlsPlugins.hs index cba0c73658..2fc1e41235 100644 --- a/exe/Plugins.hs +++ b/src/HlsPlugins.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-} -module Plugins where +module HlsPlugins where import Development.IDE.Types.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) @@ -11,9 +11,6 @@ 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 -import qualified Ide.Plugin.ExampleCabal as ExampleCabal -- haskell-language-server optional plugins #if hls_qualifyImportedNames @@ -130,15 +127,12 @@ instance Pretty Log where -- 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 +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 includeExamples - then basePlugins ++ examplePlugins - else basePlugins - basePlugins = + allPlugins = #if hls_pragmas Pragmas.descriptor "pragmas" : #endif @@ -215,9 +209,4 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins #if explicitFixity ++ [ExplicitFixity.descriptor pluginRecorder] #endif - examplePlugins = - [Example.descriptor pluginRecorder "eg" - ,Example2.descriptor pluginRecorder "eg2" - ,ExampleCabal.descriptor pluginRecorder "ec" - ] diff --git a/test/functional/Diagnostic.hs b/test/functional/Diagnostic.hs index bf2aab31cd..089a3ecbe2 100644 --- a/test/functional/Diagnostic.hs +++ b/test/functional/Diagnostic.hs @@ -10,23 +10,8 @@ import Test.Hls.Command -- --------------------------------------------------------------------- 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" [