haskell/haskell-language-server
1
1
Fork 0
mirror of https://github.com/haskell/haskell-language-server.git synced 2024-07-14 10:40:35 +03:00
Code Issues Projects Releases Wiki Activity

HLS benchmarks (#3117)

Browse Source 
* 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
This commit is contained in:
Pepe Iborra 2022-08-25 15:08:57 +01:00 committed by GitHub
parent 55d9024144
commit d0e3e0fe3f
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
32 changed files with 1296 additions and 1220 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
.github/workflows/bench.yml vendored
View File

@ -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:

3
.gitignore vendored
View File

@ -34,9 +34,10 @@ test/testdata/**/hie.yaml
/.direnv/
/.envrc
# ghcide-bench
# bench
*.identifierPosition
/bench/example
/bench-results
# nix
result

282
bench/Main.hs Normal file
View File

@ -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
├── <git-reference>
│  ├── ghc.path - path to ghc used to build the binary
│  └── haskell-language-server - binary for this version
├─ <example>
│ ├── results.csv - aggregated results for all the versions
│ └── <git-reference>
| └── <HLS plugin>
│   ├── <experiment>.gcStats.log - RTS -s output
│   ├── <experiment>.csv - stats for the experiment
│   ├── <experiment>.svg - Graph of bytes over elapsed time
│   ├── <experiment>.diff.svg - idem, including the previous version
│   ├── <experiment>.log - ghcide-bench output
│   └── results.csv - results of all the experiments for the example
├── results.csv - aggregated results of all the experiments and versions
└── <experiment>.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"

22
ghcide/bench/README.md → bench/README.md
View File

@ -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:

175
bench/config.yaml Normal file
View File

@ -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:
# - <tag>
# - <branch>
# - <commit hash>
# Or in extended form, where all the fields are optional:
# - <name>:
# git: <tag/branch/commithash>
# include: true # whether to include in comparison graphs
# parent: <tag/branch/commithash> # 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

9
cabal.project
View File

@ -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
----------

6
docs/contributing/contributing.md
View File

@ -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

14
exe/Main.hs
View File

@ -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)

201
ghcide-bench/LICENSE Normal file
View File

@ -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.

61
ghcide-bench/README.md Normal file
View File

@ -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

0
ghcide/bench/exe/Main.hs → ghcide-bench/exe/Main.hs
View File

137
ghcide-bench/ghcide-bench.cabal Normal file
View File

@ -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

48
ghcide-bench/src/Development/IDE/Test/Diagnostic.hs Normal file
View File

@ -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

166
ghcide/bench/lib/Experiments.hs → ghcide-bench/src/Experiments.hs
View File

@ -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

19
ghcide/bench/lib/Experiments/Types.hs → ghcide-bench/src/Experiments/Types.hs
View File

@ -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]

48
ghcide-bench/test/Main.hs Normal file
View File

@ -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

5
ghcide/.gitignore vendored
View File

@ -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

4
ghcide/bench-results/.artifactignore
View File

@ -1,4 +0,0 @@
ghcide
ghcide-bench
ghcide-preprocessor
*.benchmark-gcStats

116
ghcide/bench/config.yaml
View File

@ -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:
# - <tag>
# - <branch>
# - <commit hash>
# Or in extended form, where all the fields are optional:
# - <name>:
# git: <tag/branch/commithash>
# include: true # whether to include in comparison graphs
# parent: <tag/branch/commithash> # 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

192
ghcide/bench/hist/Main.hs
View File

@ -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
├── <git-reference>
│  ├── ghc.path - path to ghc used to build the binary
│  ├── ghcide - binary for this version
├─ <example>
│ ├── results.csv - aggregated results for all the versions
│ └── <git-reference>
│   ├── <experiment>.gcStats.log - RTS -s output
│   ├── <experiment>.csv - stats for the experiment
│   ├── <experiment>.svg - Graph of bytes over elapsed time
│   ├── <experiment>.diff.svg - idem, including the previous version
│   ├── <experiment>.log - ghcide-bench output
│   └── results.csv - results of all the experiments for the example
├── results.csv - aggregated results of all the experiments and versions
└── <experiment>.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
]

110
ghcide/ghcide.cabal
View File

@ -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

21
ghcide/test/exe/Main.hs
View File

@ -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

20
ghcide/test/src/Development/IDE/Test.hs
View File

@ -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)

68
haskell-language-server.cabal
View File

@ -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

2
hls-plugin-api/src/Ide/Types.hs
View File

@ -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

253
plugins/default/src/Ide/Plugin/Example.hs
View File

@ -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
-- ---------------------------------------------------------------------

237
plugins/default/src/Ide/Plugin/Example2.hs
View File

@ -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
-- ---------------------------------------------------------------------

75
plugins/default/src/Ide/Plugin/ExampleCabal.hs
View File

@ -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

1
shake-bench/shake-bench.cabal
View File

@ -17,6 +17,7 @@ library
build-depends:
aeson,
base == 4.*,
bytestring,
Chart,
Chart-diagrams,
diagrams-contrib,

159
shake-bench/src/Development/Benchmark/Rules.hs
View File

@ -26,20 +26,22 @@
├── binaries
│ └── <git-reference>
│  ├── ghc.path - path to ghc used to build the executable
│  └── <executable> - binary for this version
│  ├── <executable> - binary for this version
│  └── commitid - Git commit id for this reference
├─ <example>
│ ├── results.csv - aggregated results for all the versions
│ └── <git-reference>
│   ├── <experiment>.gcStats.log - RTS -s output
│   ├── <experiment>.csv - stats for the experiment
│   ├── <experiment>.svg - Graph of bytes over elapsed time
│   ├── <experiment>.diff.svg - idem, including the previous version
│   ├── <experiment>.heap.svg - Heap profile
│   ├── <experiment>.log - bench stdout
│   └── results.csv - results of all the experiments for the example
├── results.csv - aggregated results of all the experiments and versions
└── <experiment>.svg - graph of bytes over elapsed time, for all the included versions
│ ├── results.csv - aggregated results for all the versions and configurations
│ ├── <experiment>.svg - graph of bytes over elapsed time, for all the versions and configurations
| └── <git-reference>
│ └── <configuration>
│   ├── <experiment>.gcStats.log - RTS -s output
│   ├── <experiment>.csv - stats for the experiment
│   ├── <experiment>.svg - Graph of bytes over elapsed time
│   ├── <experiment>.diff.svg - idem, including the previous version
│   ├── <experiment>.heap.svg - Heap profile
│   ├── <experiment>.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
└── <experiment>.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
]

19
exe/Plugins.hs → src/HlsPlugins.hs
View File

@ -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"
]

17
test/functional/Diagnostic.hs
View File

@ -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" [