mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-11 08:45:35 +03:00
HLS benchmarks (#3117)
* extract ghcide:experiments-types * extract haskell-language-server:plugins and let go of examples The main goal here is to move the Plugins module into an internal library so that it can be reused from the benchmark suite. In order to make that easier, and since they hardly serve a purpose in a repository with 25 plugins, I delete the Example and Example2 plugin descriptors and their dependencies. * HLS benchmark suite Port the ghcide benchmark suite to HLS and benchmark plugin "configurations" independently. This includes the following changes to the ghcide benchmark suite and HLS: - Support for "configurations" which are defined as sets of plugin ids. The benchmark will be run with only these plugins enabled and all others disabled - Support for configurable concurrency. This relies on RTS -ol and -po flags to place the RTS traces in the target location rather than in the cwd This change requires two commits, the next one places ghcide/bench/hist/Main.hs into its final location to help 'git' recognize the change as a file move * ghcide/bench/hist/Main.hs -> bench/Main.hs * CI - fix artifact names for uniqueness * disable shorten HLS step * Do not store eventlogs to avoid out of disk space * render durations up to milliseconds * shorten titles Goal is to display the formatted CSV (via column) one row per line * exclude formatting plugin configurations * Extract ghcide-bench to a standalone package * ghcide-bench: fix stderr capturing * Fix mem stats We parse maxResidency and allocatedBytes from the RTS -S output, but runSessionWithHandles kills the server without waiting for it to exit and these stats don't get logged. The solution is to use runSessionWithHandles', but unfortunately it is internal and not exposed. I have raised a PR to expose it and in the meantime we need a source repo package. * feedbacks * delete Example plugins
This commit is contained in:
parent
55d9024144
commit
d0e3e0fe3f
26
.github/workflows/bench.yml
vendored
26
.github/workflows/bench.yml
vendored
@ -61,16 +61,17 @@ jobs:
|
|||||||
with:
|
with:
|
||||||
ghc: ${{ matrix.ghc }}
|
ghc: ${{ matrix.ghc }}
|
||||||
os: ${{ runner.os }}
|
os: ${{ runner.os }}
|
||||||
|
shorten-hls: "false"
|
||||||
|
|
||||||
# max-backjumps is increased as a temporary solution
|
# max-backjumps is increased as a temporary solution
|
||||||
# for dependency resolution failure
|
# for dependency resolution failure
|
||||||
- run: cabal configure --enable-benchmarks --max-backjumps 12000
|
- run: cabal configure --enable-benchmarks --max-backjumps 12000
|
||||||
|
|
||||||
- name: Build
|
- name: Build
|
||||||
run: cabal build ghcide:benchHist
|
run: cabal build haskell-language-server:benchmark
|
||||||
|
|
||||||
- name: Bench init
|
- 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
|
# tar is required to preserve file permissions
|
||||||
# compression speeds up upload/download nicely
|
# compression speeds up upload/download nicely
|
||||||
@ -85,14 +86,14 @@ jobs:
|
|||||||
- name: Upload workspace
|
- name: Upload workspace
|
||||||
uses: actions/upload-artifact@v3
|
uses: actions/upload-artifact@v3
|
||||||
with:
|
with:
|
||||||
name: workspace
|
name: workspace-${{ matrix.ghc }}-${{ matrix.os }}
|
||||||
retention-days: 1
|
retention-days: 1
|
||||||
path: workspace.tar.gz
|
path: workspace.tar.gz
|
||||||
|
|
||||||
- name: Upload .cabal
|
- name: Upload .cabal
|
||||||
uses: actions/upload-artifact@v3
|
uses: actions/upload-artifact@v3
|
||||||
with:
|
with:
|
||||||
name: cabal-home
|
name: cabal-home-${{ matrix.ghc }}-${{ matrix.os }}
|
||||||
retention-days: 1
|
retention-days: 1
|
||||||
path: ~/.cabal/cabal.tar.gz
|
path: ~/.cabal/cabal.tar.gz
|
||||||
|
|
||||||
@ -118,13 +119,13 @@ jobs:
|
|||||||
- name: Download cabal home
|
- name: Download cabal home
|
||||||
uses: actions/download-artifact@v3
|
uses: actions/download-artifact@v3
|
||||||
with:
|
with:
|
||||||
name: cabal-home
|
name: cabal-home-${{ matrix.ghc }}-${{ matrix.os }}
|
||||||
path: .
|
path: .
|
||||||
|
|
||||||
- name: Download workspace
|
- name: Download workspace
|
||||||
uses: actions/download-artifact@v3
|
uses: actions/download-artifact@v3
|
||||||
with:
|
with:
|
||||||
name: workspace
|
name: workspace-${{ matrix.ghc }}-${{ matrix.os }}
|
||||||
path: .
|
path: .
|
||||||
|
|
||||||
- name: untar
|
- name: untar
|
||||||
@ -134,28 +135,29 @@ jobs:
|
|||||||
tar xzf cabal.tar.gz --directory ~/.cabal
|
tar xzf cabal.tar.gz --directory ~/.cabal
|
||||||
|
|
||||||
- name: Bench
|
- name: Bench
|
||||||
run: cabal bench ghcide:benchHist -j --benchmark-options="${{ matrix.example }}"
|
run: cabal bench -j --benchmark-options="${{ matrix.example }}"
|
||||||
|
|
||||||
- name: Display results
|
- name: Display results
|
||||||
run: |
|
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
|
- 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
|
- name: Archive benchmarking artifacts
|
||||||
uses: actions/upload-artifact@v3
|
uses: actions/upload-artifact@v3
|
||||||
with:
|
with:
|
||||||
name: bench-results-${{ runner.os }}-${{ matrix.ghc }}
|
name: bench-results-${{ matrix.example }}-${{ runner.os }}-${{ matrix.ghc }}
|
||||||
path: benchmark-artifacts.tar.gz
|
path: benchmark-artifacts.tar.gz
|
||||||
|
|
||||||
- name: tar benchmarking logs
|
- 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
|
- name: Archive benchmark logs
|
||||||
uses: actions/upload-artifact@v3
|
uses: actions/upload-artifact@v3
|
||||||
with:
|
with:
|
||||||
name: bench-logs-${{ runner.os }}-${{ matrix.ghc }}
|
name: bench-logs-${{ matrix.example }}-${{ runner.os }}-${{ matrix.ghc }}
|
||||||
path: benchmark-logs.tar.gz
|
path: benchmark-logs.tar.gz
|
||||||
|
|
||||||
bench_post_job:
|
bench_post_job:
|
||||||
|
3
.gitignore
vendored
3
.gitignore
vendored
@ -34,9 +34,10 @@ test/testdata/**/hie.yaml
|
|||||||
/.direnv/
|
/.direnv/
|
||||||
/.envrc
|
/.envrc
|
||||||
|
|
||||||
# ghcide-bench
|
# bench
|
||||||
*.identifierPosition
|
*.identifierPosition
|
||||||
/bench/example
|
/bench/example
|
||||||
|
/bench-results
|
||||||
|
|
||||||
# nix
|
# nix
|
||||||
result
|
result
|
||||||
|
282
bench/Main.hs
Normal file
282
bench/Main.hs
Normal 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"
|
@ -1,22 +1,17 @@
|
|||||||
|
|
||||||
# Benchmarks
|
# Benchmarks
|
||||||
|
|
||||||
This folder contains two Haskell programs that work together to simplify the
|
This folder contains a Shake script to simplify the performance analysis of HLS.
|
||||||
performance analysis of ghcide:
|
It drives the `ghcide-bench` benchmark suite over a set of commits and experiments.
|
||||||
|
To run it, use `cabal bench`.
|
||||||
- `exe/Main.hs` - a standalone benchmark runner. Run with `stack run ghcide-bench`
|
To configure it, edit `bench/config.yaml`.
|
||||||
- `hist/Main.hs` - a Shake script for running the benchmark suite over a set of commits.
|
By default it compares HEAD with "origin/master"
|
||||||
- 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"
|
|
||||||
|
|
||||||
# Examples and experiments
|
# Examples and experiments
|
||||||
|
|
||||||
The benchmark suites runs a set of experiments (hover, completion, edit, etc.)
|
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
|
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
|
# 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
|
* profiled-Cabal-3.0.0.0
|
||||||
: runs the Cabal example, with heap profiling
|
: runs the Cabal example, with heap profiling
|
||||||
|
|
||||||
|
* all-binaries
|
||||||
|
: build all the HLS binaries for each of the versions under analysis
|
||||||
|
|
||||||
* etc
|
* etc
|
||||||
|
|
||||||
`--help` lists all the phony targets. Invoke it with:
|
`--help` lists all the phony targets. Invoke it with:
|
||||||
|
|
||||||
cabal bench ghcide --benchmark-options="--help"
|
cabal bench --benchmark-options="--help"
|
||||||
|
|
||||||
```
|
```
|
||||||
Targets:
|
Targets:
|
175
bench/config.yaml
Normal file
175
bench/config.yaml
Normal 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
|
@ -4,6 +4,7 @@ packages:
|
|||||||
./shake-bench
|
./shake-bench
|
||||||
./hls-graph
|
./hls-graph
|
||||||
./ghcide
|
./ghcide
|
||||||
|
./ghcide-bench
|
||||||
./hls-plugin-api
|
./hls-plugin-api
|
||||||
./hls-test-utils
|
./hls-test-utils
|
||||||
./plugins/hls-tactics-plugin
|
./plugins/hls-tactics-plugin
|
||||||
@ -64,6 +65,14 @@ source-repository-package
|
|||||||
tag: 7a0af7a8fd38045fd15fb13445bdcc7085325460
|
tag: 7a0af7a8fd38045fd15fb13445bdcc7085325460
|
||||||
-- https://github.com/tibbe/ekg-json/pull/12
|
-- 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:
|
allow-newer:
|
||||||
-- ghc-9.2
|
-- ghc-9.2
|
||||||
----------
|
----------
|
||||||
|
@ -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
|
benchmark between HEAD and master using the benchHist script. This assumes that
|
||||||
"master" points to the upstream master.
|
"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
|
### Tracing
|
||||||
|
|
||||||
|
14
exe/Main.hs
14
exe/Main.hs
@ -20,6 +20,7 @@ import Development.IDE.Types.Logger (Doc,
|
|||||||
payload, renderStrict,
|
payload, renderStrict,
|
||||||
withDefaultRecorder)
|
withDefaultRecorder)
|
||||||
import qualified Development.IDE.Types.Logger as Logger
|
import qualified Development.IDE.Types.Logger as Logger
|
||||||
|
import qualified HlsPlugins as Plugins
|
||||||
import Ide.Arguments (Arguments (..),
|
import Ide.Arguments (Arguments (..),
|
||||||
GhcideArguments (..),
|
GhcideArguments (..),
|
||||||
getArguments)
|
getArguments)
|
||||||
@ -31,7 +32,6 @@ import Ide.Types (PluginDescriptor (pluginNotificat
|
|||||||
mkPluginNotificationHandler)
|
mkPluginNotificationHandler)
|
||||||
import Language.LSP.Server as LSP
|
import Language.LSP.Server as LSP
|
||||||
import Language.LSP.Types as LSP
|
import Language.LSP.Types as LSP
|
||||||
import qualified Plugins
|
|
||||||
#if MIN_VERSION_prettyprinter(1,7,0)
|
#if MIN_VERSION_prettyprinter(1,7,0)
|
||||||
import Prettyprinter (Pretty (pretty), vsep)
|
import Prettyprinter (Pretty (pretty), vsep)
|
||||||
#else
|
#else
|
||||||
@ -52,7 +52,7 @@ main = do
|
|||||||
-- plugin cli commands use stderr logger for now unless we change the args
|
-- plugin cli commands use stderr logger for now unless we change the args
|
||||||
-- parser to get logging arguments first or do more complicated things
|
-- parser to get logging arguments first or do more complicated things
|
||||||
pluginCliRecorder <- cmapWithPrio pretty <$> makeDefaultStderrRecorder Nothing Info
|
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
|
(lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder
|
||||||
(lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder
|
(lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder
|
||||||
@ -64,12 +64,12 @@ main = do
|
|||||||
liftIO $ (cb1 <> cb2) env
|
liftIO $ (cb1 <> cb2) env
|
||||||
}
|
}
|
||||||
|
|
||||||
let (argsTesting, minPriority, logFilePath, includeExamplePlugins) =
|
let (argsTesting, minPriority, logFilePath) =
|
||||||
case args of
|
case args of
|
||||||
Ghcide GhcideArguments{ argsTesting, argsDebugOn, argsLogFile, argsExamplePlugin } ->
|
Ghcide GhcideArguments{ argsTesting, argsDebugOn, argsLogFile} ->
|
||||||
let minPriority = if argsDebugOn || argsTesting then Debug else Info
|
let minPriority = if argsDebugOn || argsTesting then Debug else Info
|
||||||
in (argsTesting, minPriority, argsLogFile, argsExamplePlugin)
|
in (argsTesting, minPriority, argsLogFile)
|
||||||
_ -> (False, Info, Nothing, False)
|
_ -> (False, Info, Nothing)
|
||||||
|
|
||||||
withDefaultRecorder logFilePath Nothing minPriority $ \textWithPriorityRecorder -> do
|
withDefaultRecorder logFilePath Nothing minPriority $ \textWithPriorityRecorder -> do
|
||||||
let
|
let
|
||||||
@ -87,7 +87,7 @@ main = do
|
|||||||
-- ability of lsp-test to detect a stuck server in tests and benchmarks
|
-- ability of lsp-test to detect a stuck server in tests and benchmarks
|
||||||
& if argsTesting then cfilter (not . heapStats . snd . payload) else id
|
& if argsTesting then cfilter (not . heapStats . snd . payload) else id
|
||||||
]
|
]
|
||||||
plugins = (Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins)
|
plugins = (Plugins.idePlugins (cmapWithPrio LogPlugins recorder))
|
||||||
|
|
||||||
defaultMain
|
defaultMain
|
||||||
(cmapWithPrio LogIdeMain recorder)
|
(cmapWithPrio LogIdeMain recorder)
|
||||||
|
201
ghcide-bench/LICENSE
Normal file
201
ghcide-bench/LICENSE
Normal 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
61
ghcide-bench/README.md
Normal 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
|
137
ghcide-bench/ghcide-bench.cabal
Normal file
137
ghcide-bench/ghcide-bench.cabal
Normal 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
48
ghcide-bench/src/Development/IDE/Test/Diagnostic.hs
Normal 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
|
@ -3,6 +3,7 @@
|
|||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
{-# LANGUAGE ImplicitParams #-}
|
{-# LANGUAGE ImplicitParams #-}
|
||||||
{-# LANGUAGE ImpredicativeTypes #-}
|
{-# LANGUAGE ImpredicativeTypes #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE PolyKinds #-}
|
{-# LANGUAGE PolyKinds #-}
|
||||||
{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-}
|
{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-}
|
||||||
|
|
||||||
@ -23,24 +24,24 @@ module Experiments
|
|||||||
, exampleToOptions
|
, exampleToOptions
|
||||||
) where
|
) where
|
||||||
import Control.Applicative.Combinators (skipManyTill)
|
import Control.Applicative.Combinators (skipManyTill)
|
||||||
|
import Control.Concurrent.Async (withAsync)
|
||||||
import Control.Exception.Safe (IOException, handleAny, try)
|
import Control.Exception.Safe (IOException, handleAny, try)
|
||||||
import Control.Monad.Extra (allM, forM, forM_, unless,
|
import Control.Monad.Extra (allM, forM, forM_, forever,
|
||||||
void, whenJust, (&&^))
|
unless, void, when, whenJust,
|
||||||
|
(&&^))
|
||||||
import Control.Monad.Fail (MonadFail)
|
import Control.Monad.Fail (MonadFail)
|
||||||
import Control.Monad.IO.Class
|
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.Either (fromRight)
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Data.Version
|
import Data.Version
|
||||||
import Development.IDE.Plugin.Test
|
import Development.IDE.Plugin.Test
|
||||||
import Development.IDE.Test (getBuildEdgesCount,
|
|
||||||
getBuildKeysBuilt,
|
|
||||||
getBuildKeysChanged,
|
|
||||||
getBuildKeysVisited,
|
|
||||||
getRebuildsCount,
|
|
||||||
getStoredKeys)
|
|
||||||
import Development.IDE.Test.Diagnostic
|
import Development.IDE.Test.Diagnostic
|
||||||
import Development.Shake (CmdOption (Cwd, FileStdout),
|
import Development.Shake (CmdOption (Cwd, FileStdout),
|
||||||
cmd_)
|
cmd_)
|
||||||
@ -56,9 +57,11 @@ import Options.Applicative
|
|||||||
import System.Directory
|
import System.Directory
|
||||||
import System.Environment.Blank (getEnv)
|
import System.Environment.Blank (getEnv)
|
||||||
import System.FilePath ((<.>), (</>))
|
import System.FilePath ((<.>), (</>))
|
||||||
|
import System.IO
|
||||||
import System.Process
|
import System.Process
|
||||||
import System.Time.Extra
|
import System.Time.Extra
|
||||||
import Text.ParserCombinators.ReadP (readP_to_S)
|
import Text.ParserCombinators.ReadP (readP_to_S)
|
||||||
|
import Text.Printf
|
||||||
|
|
||||||
charEdit :: Position -> TextDocumentContentChangeEvent
|
charEdit :: Position -> TextDocumentContentChangeEvent
|
||||||
charEdit p =
|
charEdit p =
|
||||||
@ -69,8 +72,11 @@ charEdit p =
|
|||||||
}
|
}
|
||||||
|
|
||||||
data DocumentPositions = DocumentPositions {
|
data DocumentPositions = DocumentPositions {
|
||||||
|
-- | A position that can be used to generate non null goto-def and completion responses
|
||||||
identifierP :: Maybe Position,
|
identifierP :: Maybe Position,
|
||||||
|
-- | A position that can be modified without generating a new diagnostic
|
||||||
stringLiteralP :: !Position,
|
stringLiteralP :: !Position,
|
||||||
|
-- | The document containing the above positions
|
||||||
doc :: !TextDocumentIdentifier
|
doc :: !TextDocumentIdentifier
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -82,7 +88,7 @@ allWithIdentifierPos f docs = case applicableDocs of
|
|||||||
where
|
where
|
||||||
applicableDocs = filter (isJust . identifierP) docs
|
applicableDocs = filter (isJust . identifierP) docs
|
||||||
|
|
||||||
experiments :: [Bench]
|
experiments :: HasConfig => [Bench]
|
||||||
experiments =
|
experiments =
|
||||||
[ ---------------------------------------------------------------------------------------
|
[ ---------------------------------------------------------------------------------------
|
||||||
bench "hover" $ allWithIdentifierPos $ \DocumentPositions{..} ->
|
bench "hover" $ allWithIdentifierPos $ \DocumentPositions{..} ->
|
||||||
@ -94,6 +100,7 @@ experiments =
|
|||||||
-- wait for a fresh build start
|
-- wait for a fresh build start
|
||||||
waitForProgressStart
|
waitForProgressStart
|
||||||
-- wait for the build to be finished
|
-- wait for the build to be finished
|
||||||
|
output "edit: waitForProgressDone"
|
||||||
waitForProgressDone
|
waitForProgressDone
|
||||||
return True,
|
return True,
|
||||||
---------------------------------------------------------------------------------------
|
---------------------------------------------------------------------------------------
|
||||||
@ -267,6 +274,7 @@ configP =
|
|||||||
<$> (Left <$> pathP)
|
<$> (Left <$> pathP)
|
||||||
<*> some moduleOption
|
<*> some moduleOption
|
||||||
<*> pure [])
|
<*> pure [])
|
||||||
|
<*> switch (long "lsp-config" <> help "Read an LSP config payload from standard input")
|
||||||
where
|
where
|
||||||
moduleOption = strOption (long "example-module" <> metavar "PATH")
|
moduleOption = strOption (long "example-module" <> metavar "PATH")
|
||||||
|
|
||||||
@ -324,9 +332,30 @@ runBenchmarksFun dir allBenchmarks = do
|
|||||||
whenJust (otMemoryProfiling ?config) $ \eventlogDir ->
|
whenJust (otMemoryProfiling ?config) $ \eventlogDir ->
|
||||||
createDirectoryIfMissing True eventlogDir
|
createDirectoryIfMissing True eventlogDir
|
||||||
|
|
||||||
results <- forM benchmarks $ \b@Bench{name} -> do
|
lspConfig <- if Experiments.Types.lspConfig ?config
|
||||||
let run = runSessionWithConfig conf (cmd name dir) lspTestCaps dir
|
then either error Just . eitherDecodeStrict' <$> BS.getContents
|
||||||
(b,) <$> runBench run b
|
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
|
-- output raw data as CSV
|
||||||
let headers =
|
let headers =
|
||||||
@ -335,31 +364,31 @@ runBenchmarksFun dir allBenchmarks = do
|
|||||||
, "samples"
|
, "samples"
|
||||||
, "startup"
|
, "startup"
|
||||||
, "setup"
|
, "setup"
|
||||||
, "userTime"
|
, "userT"
|
||||||
, "delayedTime"
|
, "delayedT"
|
||||||
, "firstBuildTime"
|
, "1stBuildT"
|
||||||
, "averageTimePerResponse"
|
, "avgPerRespT"
|
||||||
, "totalTime"
|
, "totalT"
|
||||||
, "buildRulesBuilt"
|
, "rulesBuilt"
|
||||||
, "buildRulesChanged"
|
, "rulesChanged"
|
||||||
, "buildRulesVisited"
|
, "rulesVisited"
|
||||||
, "buildRulesTotal"
|
, "rulesTotal"
|
||||||
, "buildEdges"
|
, "ruleEdges"
|
||||||
, "ghcRebuilds"
|
, "ghcRebuilds"
|
||||||
]
|
]
|
||||||
rows =
|
rows =
|
||||||
[ [ name,
|
[ [ name,
|
||||||
show success,
|
show success,
|
||||||
show samples,
|
show samples,
|
||||||
show startup,
|
showMs startup,
|
||||||
show runSetup',
|
showMs runSetup',
|
||||||
show userWaits,
|
showMs userWaits,
|
||||||
show delayedWork,
|
showMs delayedWork,
|
||||||
show $ firstResponse+firstResponseDelayed,
|
showMs $ firstResponse+firstResponseDelayed,
|
||||||
-- Exclude first response as it has a lot of setup time included
|
-- Exclude first response as it has a lot of setup time included
|
||||||
-- Assume that number of requests = number of modules * number of samples
|
-- Assume that number of requests = number of modules * number of samples
|
||||||
show ((userWaits - firstResponse)/((fromIntegral samples - 1)*modules)),
|
showMs ((userWaits - firstResponse)/((fromIntegral samples - 1)*modules)),
|
||||||
show runExperiment,
|
showMs runExperiment,
|
||||||
show rulesBuilt,
|
show rulesBuilt,
|
||||||
show rulesChanged,
|
show rulesChanged,
|
||||||
show rulesVisited,
|
show rulesVisited,
|
||||||
@ -402,36 +431,32 @@ runBenchmarksFun dir allBenchmarks = do
|
|||||||
outputRow $ (map . map) (const '-') paddedHeaders
|
outputRow $ (map . map) (const '-') paddedHeaders
|
||||||
forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row
|
forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row
|
||||||
where
|
where
|
||||||
ghcideCmd dir =
|
ghcideArgs dir =
|
||||||
[ ghcide ?config,
|
[ "--lsp",
|
||||||
"--lsp",
|
|
||||||
"--test",
|
"--test",
|
||||||
"--cwd",
|
"--cwd",
|
||||||
dir,
|
dir
|
||||||
"+RTS"
|
|
||||||
]
|
]
|
||||||
cmd name dir =
|
allArgs name dir =
|
||||||
unwords $
|
ghcideArgs dir
|
||||||
ghcideCmd dir
|
++ concat
|
||||||
++ case otMemoryProfiling ?config of
|
[ [ "+RTS"
|
||||||
Just dir -> ["-l", "-ol" ++ (dir </> map (\c -> if c == ' ' then '-' else c) name <.> "eventlog")]
|
, "-l"
|
||||||
Nothing -> []
|
, "-ol" ++ (dir </> map (\c -> if c == ' ' then '-' else c) name <.> "eventlog")
|
||||||
++ [ "-RTS" ]
|
, "-RTS"
|
||||||
|
]
|
||||||
|
| Just dir <- [otMemoryProfiling ?config]
|
||||||
|
]
|
||||||
++ ghcideOptions ?config
|
++ ghcideOptions ?config
|
||||||
++ concat
|
++ concat
|
||||||
[ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config]
|
[ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config]
|
||||||
]
|
]
|
||||||
++ ["--verbose" | verbose ?config]
|
|
||||||
++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]]
|
++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]]
|
||||||
lspTestCaps =
|
lspTestCaps =
|
||||||
fullCaps {_window = Just $ WindowClientCapabilities (Just True) Nothing Nothing }
|
fullCaps {_window = Just $ WindowClientCapabilities (Just True) Nothing Nothing }
|
||||||
conf =
|
|
||||||
defaultConfig
|
showMs :: Seconds -> String
|
||||||
{ logStdErr = verbose ?config,
|
showMs = printf "%.2f"
|
||||||
logMessages = verbose ?config,
|
|
||||||
logColor = False,
|
|
||||||
messageTimeout = timeoutLsp ?config
|
|
||||||
}
|
|
||||||
|
|
||||||
data BenchRun = BenchRun
|
data BenchRun = BenchRun
|
||||||
{ startup :: !Seconds,
|
{ startup :: !Seconds,
|
||||||
@ -483,7 +508,7 @@ waitForBuildQueue = do
|
|||||||
_ -> return 0
|
_ -> return 0
|
||||||
|
|
||||||
runBench ::
|
runBench ::
|
||||||
(?config :: Config) =>
|
HasConfig =>
|
||||||
(Session BenchRun -> IO BenchRun) ->
|
(Session BenchRun -> IO BenchRun) ->
|
||||||
Bench ->
|
Bench ->
|
||||||
IO BenchRun
|
IO BenchRun
|
||||||
@ -688,3 +713,42 @@ searchSymbol doc@TextDocumentIdentifier{_uri} fileContents pos = do
|
|||||||
checkCompletions pos =
|
checkCompletions pos =
|
||||||
not . null <$> getCompletions doc 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
|
@ -3,10 +3,12 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Experiments.Types (module Experiments.Types ) where
|
module Experiments.Types (module Experiments.Types ) where
|
||||||
|
|
||||||
|
import Control.DeepSeq
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Binary (Binary)
|
||||||
|
import Data.Hashable (Hashable)
|
||||||
|
import Data.Maybe (fromMaybe)
|
||||||
import Data.Version
|
import Data.Version
|
||||||
import Development.Shake.Classes
|
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
import Numeric.Natural
|
import Numeric.Natural
|
||||||
|
|
||||||
@ -27,7 +29,8 @@ data Config = Config
|
|||||||
repetitions :: Maybe Natural,
|
repetitions :: Maybe Natural,
|
||||||
ghcide :: FilePath,
|
ghcide :: FilePath,
|
||||||
timeoutLsp :: Int,
|
timeoutLsp :: Int,
|
||||||
example :: Example
|
example :: Example,
|
||||||
|
lspConfig :: Bool
|
||||||
}
|
}
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
@ -64,11 +67,13 @@ exampleToOptions :: Example -> [String] -> [String]
|
|||||||
exampleToOptions Example{exampleDetails = Right ExamplePackage{..}, ..} extraArgs =
|
exampleToOptions Example{exampleDetails = Right ExamplePackage{..}, ..} extraArgs =
|
||||||
["--example-package-name", packageName
|
["--example-package-name", packageName
|
||||||
,"--example-package-version", showVersion packageVersion
|
,"--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 =
|
exampleToOptions Example{exampleDetails = Left examplePath, ..} extraArgs =
|
||||||
["--example-path", examplePath
|
["--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
48
ghcide-bench/test/Main.hs
Normal 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
5
ghcide/.gitignore
vendored
@ -7,11 +7,6 @@ cabal.project.local
|
|||||||
/.tasty-rerun-log
|
/.tasty-rerun-log
|
||||||
.vscode
|
.vscode
|
||||||
/.hlint-*
|
/.hlint-*
|
||||||
bench/example/*
|
|
||||||
# don't ignore the example file, we need it!
|
|
||||||
!bench/example/HLS
|
|
||||||
bench-results/
|
|
||||||
bench-temp/
|
|
||||||
.shake/
|
.shake/
|
||||||
ghcide
|
ghcide
|
||||||
ghcide-bench
|
ghcide-bench
|
||||||
|
@ -1,4 +0,0 @@
|
|||||||
ghcide
|
|
||||||
ghcide-bench
|
|
||||||
ghcide-preprocessor
|
|
||||||
*.benchmark-gcStats
|
|
@ -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
|
|
@ -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
|
|
||||||
]
|
|
@ -1,4 +1,4 @@
|
|||||||
cabal-version: 2.4
|
cabal-version: 3.0
|
||||||
build-type: Simple
|
build-type: Simple
|
||||||
category: Development
|
category: Development
|
||||||
name: ghcide
|
name: ghcide
|
||||||
@ -267,45 +267,6 @@ executable ghcide-test-preprocessor
|
|||||||
if !flag(test-exe)
|
if !flag(test-exe)
|
||||||
buildable: False
|
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
|
flag executable
|
||||||
description: Build the ghcide executable
|
description: Build the ghcide executable
|
||||||
default: True
|
default: True
|
||||||
@ -389,8 +350,6 @@ test-suite ghcide-tests
|
|||||||
aeson,
|
aeson,
|
||||||
async,
|
async,
|
||||||
base,
|
base,
|
||||||
binary,
|
|
||||||
bytestring,
|
|
||||||
containers,
|
containers,
|
||||||
data-default,
|
data-default,
|
||||||
directory,
|
directory,
|
||||||
@ -407,7 +366,6 @@ test-suite ghcide-tests
|
|||||||
--------------------------------------------------------------
|
--------------------------------------------------------------
|
||||||
ghcide,
|
ghcide,
|
||||||
ghc-typelits-knownnat,
|
ghc-typelits-knownnat,
|
||||||
haddock-library,
|
|
||||||
lsp,
|
lsp,
|
||||||
lsp-types,
|
lsp-types,
|
||||||
hls-plugin-api,
|
hls-plugin-api,
|
||||||
@ -416,20 +374,13 @@ test-suite ghcide-tests
|
|||||||
lsp-test ^>= 0.14,
|
lsp-test ^>= 0.14,
|
||||||
monoid-subclasses,
|
monoid-subclasses,
|
||||||
network-uri,
|
network-uri,
|
||||||
optparse-applicative,
|
|
||||||
parallel,
|
|
||||||
process,
|
|
||||||
QuickCheck,
|
QuickCheck,
|
||||||
quickcheck-instances,
|
|
||||||
random,
|
random,
|
||||||
regex-tdfa ^>= 1.3.1,
|
regex-tdfa ^>= 1.3.1,
|
||||||
safe,
|
|
||||||
safe-exceptions,
|
|
||||||
shake,
|
shake,
|
||||||
sqlite-simple,
|
sqlite-simple,
|
||||||
stm,
|
stm,
|
||||||
stm-containers,
|
stm-containers,
|
||||||
hls-graph,
|
|
||||||
tasty,
|
tasty,
|
||||||
tasty-expected-failure,
|
tasty-expected-failure,
|
||||||
tasty-hunit >= 0.10,
|
tasty-hunit >= 0.10,
|
||||||
@ -438,7 +389,6 @@ test-suite ghcide-tests
|
|||||||
text,
|
text,
|
||||||
text-rope,
|
text-rope,
|
||||||
unordered-containers,
|
unordered-containers,
|
||||||
vector,
|
|
||||||
if (impl(ghc >= 8.6) && impl(ghc < 9.2))
|
if (impl(ghc >= 8.6) && impl(ghc < 9.2))
|
||||||
build-depends:
|
build-depends:
|
||||||
record-dot-preprocessor,
|
record-dot-preprocessor,
|
||||||
@ -450,8 +400,6 @@ test-suite ghcide-tests
|
|||||||
Development.IDE.Test
|
Development.IDE.Test
|
||||||
Development.IDE.Test.Diagnostic
|
Development.IDE.Test.Diagnostic
|
||||||
Development.IDE.Test.Runfiles
|
Development.IDE.Test.Runfiles
|
||||||
Experiments
|
|
||||||
Experiments.Types
|
|
||||||
FuzzySearch
|
FuzzySearch
|
||||||
Progress
|
Progress
|
||||||
HieDbRetry
|
HieDbRetry
|
||||||
@ -470,59 +418,3 @@ test-suite ghcide-tests
|
|||||||
TupleSections
|
TupleSections
|
||||||
TypeApplications
|
TypeApplications
|
||||||
ViewPatterns
|
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
|
|
||||||
|
@ -65,7 +65,6 @@ import Development.IDE.Test.Runfiles
|
|||||||
import qualified Development.IDE.Types.Diagnostics as Diagnostics
|
import qualified Development.IDE.Types.Diagnostics as Diagnostics
|
||||||
import Development.IDE.Types.Location
|
import Development.IDE.Types.Location
|
||||||
import Development.Shake (getDirectoryFilesIO)
|
import Development.Shake (getDirectoryFilesIO)
|
||||||
import qualified Experiments as Bench
|
|
||||||
import Ide.Plugin.Config
|
import Ide.Plugin.Config
|
||||||
import Language.LSP.Test
|
import Language.LSP.Test
|
||||||
import Language.LSP.Types hiding
|
import Language.LSP.Types hiding
|
||||||
@ -221,7 +220,6 @@ main = do
|
|||||||
, cradleTests
|
, cradleTests
|
||||||
, dependentFileTest
|
, dependentFileTest
|
||||||
, nonLspCommandLine
|
, nonLspCommandLine
|
||||||
, benchmarkTests
|
|
||||||
, ifaceTests
|
, ifaceTests
|
||||||
, bootTests
|
, bootTests
|
||||||
, rootUriTests
|
, rootUriTests
|
||||||
@ -6311,25 +6309,6 @@ nonLspCommandLine = testGroup "ghcide command line"
|
|||||||
ec @?= ExitSuccess
|
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
|
-- | checks if we use InitializeParams.rootUri for loading session
|
||||||
rootUriTests :: TestTree
|
rootUriTests :: TestTree
|
||||||
rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do
|
rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do
|
||||||
|
@ -29,11 +29,6 @@ module Development.IDE.Test
|
|||||||
, getStoredKeys
|
, getStoredKeys
|
||||||
, waitForCustomMessage
|
, waitForCustomMessage
|
||||||
, waitForGC
|
, waitForGC
|
||||||
, getBuildKeysBuilt
|
|
||||||
, getBuildKeysVisited
|
|
||||||
, getBuildKeysChanged
|
|
||||||
, getBuildEdgesCount
|
|
||||||
, getRebuildsCount
|
|
||||||
, configureCheckProject
|
, configureCheckProject
|
||||||
, isReferenceReady
|
, isReferenceReady
|
||||||
, referenceReady) where
|
, referenceReady) where
|
||||||
@ -214,21 +209,6 @@ waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResul
|
|||||||
waitForAction key TextDocumentIdentifier{_uri} =
|
waitForAction key TextDocumentIdentifier{_uri} =
|
||||||
callTestPlugin (WaitForIdeRule key _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 -> Session FilePath
|
||||||
getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri)
|
getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri)
|
||||||
|
|
||||||
|
@ -1,4 +1,4 @@
|
|||||||
cabal-version: 2.4
|
cabal-version: 3.0
|
||||||
category: Development
|
category: Development
|
||||||
name: haskell-language-server
|
name: haskell-language-server
|
||||||
version: 1.7.0.0
|
version: 1.7.0.0
|
||||||
@ -233,12 +233,6 @@ flag dynamic
|
|||||||
default: True
|
default: True
|
||||||
manual: 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
|
common class
|
||||||
if flag(class)
|
if flag(class)
|
||||||
build-depends: hls-class-plugin ^>= 1.0
|
build-depends: hls-class-plugin ^>= 1.0
|
||||||
@ -366,13 +360,12 @@ common brittany
|
|||||||
build-depends: hls-brittany-plugin ^>= 1.0
|
build-depends: hls-brittany-plugin ^>= 1.0
|
||||||
cpp-options: -Dhls_brittany
|
cpp-options: -Dhls_brittany
|
||||||
|
|
||||||
executable haskell-language-server
|
library plugins
|
||||||
import: common-deps
|
import: common-deps
|
||||||
-- configuration
|
-- configuration
|
||||||
, warnings
|
, warnings
|
||||||
, pedantic
|
, pedantic
|
||||||
-- plugins
|
-- plugins
|
||||||
, example-plugins
|
|
||||||
, callHierarchy
|
, callHierarchy
|
||||||
, changeTypeSignature
|
, changeTypeSignature
|
||||||
, class
|
, class
|
||||||
@ -398,10 +391,20 @@ executable haskell-language-server
|
|||||||
, ormolu
|
, ormolu
|
||||||
, stylishHaskell
|
, stylishHaskell
|
||||||
, brittany
|
, 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
|
main-is: Main.hs
|
||||||
hs-source-dirs: exe
|
hs-source-dirs: exe
|
||||||
other-modules: Plugins
|
|
||||||
|
|
||||||
ghc-options:
|
ghc-options:
|
||||||
-threaded
|
-threaded
|
||||||
@ -438,6 +441,7 @@ executable haskell-language-server
|
|||||||
, ghcide
|
, ghcide
|
||||||
, hashable
|
, hashable
|
||||||
, haskell-language-server
|
, haskell-language-server
|
||||||
|
, haskell-language-server:plugins
|
||||||
, lsp
|
, lsp
|
||||||
, hie-bios
|
, hie-bios
|
||||||
, hiedb
|
, hiedb
|
||||||
@ -579,3 +583,47 @@ test-suite wrapper-test
|
|||||||
|
|
||||||
hs-source-dirs: test/wrapper
|
hs-source-dirs: test/wrapper
|
||||||
main-is: Main.hs
|
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
|
||||||
|
@ -704,7 +704,7 @@ type CommandFunction ideState a
|
|||||||
|
|
||||||
newtype PluginId = PluginId T.Text
|
newtype PluginId = PluginId T.Text
|
||||||
deriving (Show, Read, Eq, Ord)
|
deriving (Show, Read, Eq, Ord)
|
||||||
deriving newtype Hashable
|
deriving newtype (FromJSON, Hashable)
|
||||||
|
|
||||||
instance IsString PluginId where
|
instance IsString PluginId where
|
||||||
fromString = PluginId . T.pack
|
fromString = PluginId . T.pack
|
||||||
|
@ -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
|
|
||||||
|
|
||||||
-- ---------------------------------------------------------------------
|
|
@ -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
|
|
||||||
|
|
||||||
-- ---------------------------------------------------------------------
|
|
@ -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
|
|
@ -17,6 +17,7 @@ library
|
|||||||
build-depends:
|
build-depends:
|
||||||
aeson,
|
aeson,
|
||||||
base == 4.*,
|
base == 4.*,
|
||||||
|
bytestring,
|
||||||
Chart,
|
Chart,
|
||||||
Chart-diagrams,
|
Chart-diagrams,
|
||||||
diagrams-contrib,
|
diagrams-contrib,
|
||||||
|
@ -26,20 +26,22 @@
|
|||||||
├── binaries
|
├── binaries
|
||||||
│ └── <git-reference>
|
│ └── <git-reference>
|
||||||
│ ├── ghc.path - path to ghc used to build the executable
|
│ ├── 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
|
│ └── commitid - Git commit id for this reference
|
||||||
├─ <example>
|
├─ <example>
|
||||||
│ ├── results.csv - aggregated results for all the versions
|
│ ├── results.csv - aggregated results for all the versions and configurations
|
||||||
│ └── <git-reference>
|
│ ├── <experiment>.svg - graph of bytes over elapsed time, for all the versions and configurations
|
||||||
│ ├── <experiment>.gcStats.log - RTS -s output
|
| └── <git-reference>
|
||||||
│ ├── <experiment>.csv - stats for the experiment
|
│ └── <configuration>
|
||||||
│ ├── <experiment>.svg - Graph of bytes over elapsed time
|
│ ├── <experiment>.gcStats.log - RTS -s output
|
||||||
│ ├── <experiment>.diff.svg - idem, including the previous version
|
│ ├── <experiment>.csv - stats for the experiment
|
||||||
│ ├── <experiment>.heap.svg - Heap profile
|
│ ├── <experiment>.svg - Graph of bytes over elapsed time
|
||||||
│ ├── <experiment>.log - bench stdout
|
│ ├── <experiment>.diff.svg - idem, including the previous version
|
||||||
│ └── results.csv - results of all the experiments for the example
|
│ ├── <experiment>.heap.svg - Heap profile
|
||||||
├── results.csv - aggregated results of all the experiments and versions
|
│ ├── <experiment>.log - bench stdout
|
||||||
└── <experiment>.svg - graph of bytes over elapsed time, for all the included versions
|
│ └── 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
|
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`.
|
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 #-}
|
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
|
||||||
module Development.Benchmark.Rules
|
module Development.Benchmark.Rules
|
||||||
(
|
(
|
||||||
buildRules, MkBuildRules(..),
|
buildRules, MkBuildRules(..), OutputFolder, ProjectRoot,
|
||||||
benchRules, MkBenchRules(..), BenchProject(..), ProfilingMode(..),
|
benchRules, MkBenchRules(..), BenchProject(..), ProfilingMode(..),
|
||||||
csvRules,
|
csvRules,
|
||||||
svgRules,
|
svgRules,
|
||||||
@ -60,6 +62,7 @@ module Development.Benchmark.Rules
|
|||||||
GetVersions(..),
|
GetVersions(..),
|
||||||
GetCommitId(..),
|
GetCommitId(..),
|
||||||
GetBuildSystem(..),
|
GetBuildSystem(..),
|
||||||
|
GetConfigurations(..), Configuration(..),
|
||||||
BuildSystem(..), findGhcForBuildSystem,
|
BuildSystem(..), findGhcForBuildSystem,
|
||||||
Escaped(..), Unescaped(..), escapeExperiment, unescapeExperiment,
|
Escaped(..), Unescaped(..), escapeExperiment, unescapeExperiment,
|
||||||
GitCommit
|
GitCommit
|
||||||
@ -76,6 +79,7 @@ import Data.Aeson (FromJSON (..),
|
|||||||
(.!=), (.:?), (.=))
|
(.!=), (.:?), (.=))
|
||||||
import Data.Aeson.Lens (AsJSON (_JSON),
|
import Data.Aeson.Lens (AsJSON (_JSON),
|
||||||
_Object, _String)
|
_Object, _String)
|
||||||
|
import Data.ByteString.Lazy (ByteString)
|
||||||
import Data.Char (isDigit)
|
import Data.Char (isDigit)
|
||||||
import Data.List (find, isInfixOf,
|
import Data.List (find, isInfixOf,
|
||||||
stripPrefix,
|
stripPrefix,
|
||||||
@ -94,6 +98,7 @@ import GHC.Generics (Generic)
|
|||||||
import GHC.Stack (HasCallStack)
|
import GHC.Stack (HasCallStack)
|
||||||
import qualified Graphics.Rendering.Chart.Backend.Diagrams as E
|
import qualified Graphics.Rendering.Chart.Backend.Diagrams as E
|
||||||
import qualified Graphics.Rendering.Chart.Easy as E
|
import qualified Graphics.Rendering.Chart.Easy as E
|
||||||
|
import Numeric.Natural
|
||||||
import System.Directory (createDirectoryIfMissing,
|
import System.Directory (createDirectoryIfMissing,
|
||||||
findExecutable,
|
findExecutable,
|
||||||
renameFile)
|
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 GetBuildSystem = GetBuildSystem () deriving newtype (Binary, Eq, Hashable, NFData, Show)
|
||||||
newtype GetExample = GetExample String 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 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 GetExperiments = [Unescaped String]
|
||||||
type instance RuleResult GetVersions = [GitCommit]
|
type instance RuleResult GetVersions = [GitCommit]
|
||||||
@ -124,6 +130,10 @@ type RuleResultForExample e =
|
|||||||
, RuleResult GetExamples ~ [e]
|
, RuleResult GetExamples ~ [e]
|
||||||
, IsExample 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
|
-- | Knowledge needed to run an example
|
||||||
class (Binary e, Eq e, Hashable e, NFData e, Show e, Typeable e) => IsExample e where
|
class (Binary e, Eq e, Hashable e, NFData e, Show e, Typeable e) => IsExample e where
|
||||||
getExampleName :: e -> String
|
getExampleName :: e -> String
|
||||||
@ -134,6 +144,7 @@ allTargetsForExample :: IsExample e => ProfilingMode -> FilePath -> e -> Action
|
|||||||
allTargetsForExample prof baseFolder ex = do
|
allTargetsForExample prof baseFolder ex = do
|
||||||
experiments <- askOracle $ GetExperiments ()
|
experiments <- askOracle $ GetExperiments ()
|
||||||
versions <- askOracle $ GetVersions ()
|
versions <- askOracle $ GetVersions ()
|
||||||
|
configurations <- askOracle $ GetConfigurations ()
|
||||||
let buildFolder = baseFolder </> profilingPath prof
|
let buildFolder = baseFolder </> profilingPath prof
|
||||||
return $
|
return $
|
||||||
[buildFolder </> getExampleName ex </> "results.csv"]
|
[buildFolder </> getExampleName ex </> "results.csv"]
|
||||||
@ -143,9 +154,12 @@ allTargetsForExample prof baseFolder ex = do
|
|||||||
++ [ buildFolder </>
|
++ [ buildFolder </>
|
||||||
getExampleName ex </>
|
getExampleName ex </>
|
||||||
T.unpack (humanName ver) </>
|
T.unpack (humanName ver) </>
|
||||||
escaped (escapeExperiment e) <.> mode
|
confName </>
|
||||||
|
escaped (escapeExperiment e) <.>
|
||||||
|
mode
|
||||||
| e <- experiments,
|
| e <- experiments,
|
||||||
ver <- versions,
|
ver <- versions,
|
||||||
|
Configuration{confName} <- configurations,
|
||||||
mode <- ["svg", "diff.svg"] ++ ["heap.svg" | prof /= NoProfiling]
|
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
|
phony (prefix <> "all-binaries") $ need =<< allBinaries buildFolder executableName
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
type OutputFolder = FilePath
|
type OutputFolder = FilePath
|
||||||
|
type ProjectRoot = FilePath
|
||||||
|
|
||||||
data MkBuildRules buildSystem = MkBuildRules
|
data MkBuildRules buildSystem = MkBuildRules
|
||||||
{ -- | Return the path to the GHC executable to use for the project found in the cwd
|
{ -- | 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
|
, executableName :: String
|
||||||
-- | An action that captures the source dependencies, used for the HEAD build
|
-- | An action that captures the source dependencies, used for the HEAD build
|
||||||
, projectDepends :: Action ()
|
, 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
|
, buildProject :: buildSystem
|
||||||
-> [CmdOption]
|
-> ProjectRoot
|
||||||
-> OutputFolder
|
-> OutputFolder
|
||||||
-> Action ()
|
-> Action ()
|
||||||
}
|
}
|
||||||
@ -217,7 +232,7 @@ buildRules build MkBuildRules{..} = do
|
|||||||
projectDepends
|
projectDepends
|
||||||
liftIO $ createDirectoryIfMissing True $ dropFileName out
|
liftIO $ createDirectoryIfMissing True $ dropFileName out
|
||||||
buildSystem <- askOracle $ GetBuildSystem ()
|
buildSystem <- askOracle $ GetBuildSystem ()
|
||||||
buildProject buildSystem [Cwd "."] (takeDirectory out)
|
buildProject buildSystem "." (takeDirectory out)
|
||||||
ghcLoc <- liftIO $ findGhc buildSystem "."
|
ghcLoc <- liftIO $ findGhc buildSystem "."
|
||||||
writeFile' ghcpath ghcLoc
|
writeFile' ghcpath ghcLoc
|
||||||
|
|
||||||
@ -232,7 +247,7 @@ buildRules build MkBuildRules{..} = do
|
|||||||
buildSystem <- askOracle $ GetBuildSystem ()
|
buildSystem <- askOracle $ GetBuildSystem ()
|
||||||
flip actionFinally (cmd_ ("git worktree remove bench-temp-" <> ver <> " --force" :: String)) $ do
|
flip actionFinally (cmd_ ("git worktree remove bench-temp-" <> ver <> " --force" :: String)) $ do
|
||||||
ghcLoc <- liftIO $ findGhc buildSystem ver
|
ghcLoc <- liftIO $ findGhc buildSystem ver
|
||||||
buildProject buildSystem [Cwd $ "bench-temp-" <> ver] (".." </> takeDirectory out)
|
buildProject buildSystem ("bench-temp-" <> ver) (".." </> takeDirectory out)
|
||||||
writeFile' ghcPath ghcLoc
|
writeFile' ghcPath ghcLoc
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
@ -246,14 +261,17 @@ data MkBenchRules buildSystem example = forall setup. MkBenchRules
|
|||||||
, warmupProject :: buildSystem -> FilePath -> [CmdOption] -> example -> Action ()
|
, warmupProject :: buildSystem -> FilePath -> [CmdOption] -> example -> Action ()
|
||||||
-- | Name of the executable to benchmark. Should match the one used to 'MkBuildRules'
|
-- | Name of the executable to benchmark. Should match the one used to 'MkBuildRules'
|
||||||
, executableName :: String
|
, executableName :: String
|
||||||
|
-- | Number of concurrent benchmarks to run
|
||||||
|
, parallelism :: Natural
|
||||||
}
|
}
|
||||||
|
|
||||||
data BenchProject example = BenchProject
|
data BenchProject example = BenchProject
|
||||||
{ outcsv :: FilePath -- ^ where to save the CSV output
|
{ outcsv :: FilePath -- ^ where to save the CSV output
|
||||||
, exePath :: FilePath -- ^ where to find the executable for benchmarking
|
, exePath :: FilePath -- ^ where to find the executable for benchmarking
|
||||||
, exeExtraArgs :: [String] -- ^ extra args for the executable
|
, exeExtraArgs :: [String] -- ^ extra args for the executable
|
||||||
, example :: example -- ^ example to benchmark
|
, example :: example -- ^ example to benchmark
|
||||||
, experiment :: Escaped String -- ^ experiment to run
|
, experiment :: Escaped String -- ^ experiment to run
|
||||||
|
, configuration :: ByteString -- ^ configuration to use
|
||||||
}
|
}
|
||||||
|
|
||||||
data ProfilingMode = NoProfiling | CheapHeapProfiling Seconds
|
data ProfilingMode = NoProfiling | CheapHeapProfiling Seconds
|
||||||
@ -272,7 +290,7 @@ profilingPath (CheapHeapProfiling i) = "profiled-" <> show i
|
|||||||
benchRules :: RuleResultForExample example => FilePattern -> MkBenchRules BuildSystem example -> Rules ()
|
benchRules :: RuleResultForExample example => FilePattern -> MkBenchRules BuildSystem example -> Rules ()
|
||||||
benchRules build MkBenchRules{..} = do
|
benchRules build MkBenchRules{..} = do
|
||||||
|
|
||||||
benchResource <- newResource "ghcide-bench" 1
|
benchResource <- newResource "ghcide-bench" (fromIntegral parallelism)
|
||||||
-- warmup an example
|
-- warmup an example
|
||||||
build -/- "binaries/*/*.warmup" %> \out -> do
|
build -/- "binaries/*/*.warmup" %> \out -> do
|
||||||
let [_, _, ver, exampleName] = splitDirectories (dropExtension out)
|
let [_, _, ver, exampleName] = splitDirectories (dropExtension out)
|
||||||
@ -295,33 +313,38 @@ benchRules build MkBenchRules{..} = do
|
|||||||
example
|
example
|
||||||
-- run an experiment
|
-- run an experiment
|
||||||
priority 0 $
|
priority 0 $
|
||||||
[ build -/- "*/*/*/*.csv",
|
[ build -/- "*/*/*/*/*.csv",
|
||||||
build -/- "*/*/*/*.gcStats.log",
|
build -/- "*/*/*/*/*.gcStats.log",
|
||||||
build -/- "*/*/*/*.output.log",
|
build -/- "*/*/*/*/*.output.log",
|
||||||
build -/- "*/*/*/*.eventlog",
|
build -/- "*/*/*/*/*.eventlog",
|
||||||
build -/- "*/*/*/*.hp"
|
build -/- "*/*/*/*/*.hp"
|
||||||
] &%> \[outcsv, outGc, outLog, outEventlog, outHp] -> do
|
] &%> \[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
|
prof = fromMaybe (error $ "Not a valid profiling mode: " <> flavour) $ profilingP flavour
|
||||||
example <- fromMaybe (error $ "Unknown example " <> exampleName)
|
example <- fromMaybe (error $ "Unknown example " <> exampleName)
|
||||||
<$> askOracle (GetExample exampleName)
|
<$> askOracle (GetExample exampleName)
|
||||||
buildSystem <- askOracle $ GetBuildSystem ()
|
buildSystem <- askOracle $ GetBuildSystem ()
|
||||||
|
configurations <- askOracle $ GetConfigurations ()
|
||||||
setupRes <- setupProject
|
setupRes <- setupProject
|
||||||
liftIO $ createDirectoryIfMissing True $ dropFileName outcsv
|
liftIO $ createDirectoryIfMissing True $ dropFileName outcsv
|
||||||
let exePath = build </> "binaries" </> ver </> executableName
|
let exePath = build </> "binaries" </> ver </> executableName
|
||||||
exeExtraArgs =
|
exeExtraArgs =
|
||||||
[ "+RTS"
|
[ "+RTS"
|
||||||
, "-l"
|
, "-l"
|
||||||
|
, "-ol" <> outEventlog
|
||||||
, "-S" <> outGc]
|
, "-S" <> outGc]
|
||||||
++ concat
|
++ concat
|
||||||
[[ "-h"
|
[[ "-h"
|
||||||
, "-i" <> show i
|
, "-i" <> show i
|
||||||
|
, "-po" <> outHp
|
||||||
, "-qg"]
|
, "-qg"]
|
||||||
| CheapHeapProfiling i <- [prof]]
|
| CheapHeapProfiling i <- [prof]]
|
||||||
++ ["-RTS"]
|
++ ["-RTS"]
|
||||||
ghcPath = build </> "binaries" </> ver </> "ghc.path"
|
ghcPath = build </> "binaries" </> ver </> "ghc.path"
|
||||||
warmupPath = build </> "binaries" </> ver </> exampleName <.> "warmup"
|
warmupPath = build </> "binaries" </> ver </> exampleName <.> "warmup"
|
||||||
experiment = Escaped $ dropExtension exp
|
experiment = Escaped $ dropExtension exp
|
||||||
|
Just Configuration{..} = find (\Configuration{confName} -> confName == conf) configurations
|
||||||
|
configuration = confValue
|
||||||
need [exePath, ghcPath, warmupPath]
|
need [exePath, ghcPath, warmupPath]
|
||||||
ghcPath <- readFile' ghcPath
|
ghcPath <- readFile' ghcPath
|
||||||
withResource benchResource 1 $ do
|
withResource benchResource 1 $ do
|
||||||
@ -333,10 +356,9 @@ benchRules build MkBenchRules{..} = do
|
|||||||
AddPath [takeDirectory ghcPath, "."] []
|
AddPath [takeDirectory ghcPath, "."] []
|
||||||
]
|
]
|
||||||
BenchProject {..}
|
BenchProject {..}
|
||||||
liftIO $ renameFile "ghcide.eventlog" outEventlog
|
|
||||||
liftIO $ case prof of
|
liftIO $ case prof of
|
||||||
CheapHeapProfiling{} -> renameFile "ghcide.hp" outHp
|
NoProfiling -> writeFile outHp dummyHp
|
||||||
NoProfiling -> writeFile outHp dummyHp
|
_ -> return ()
|
||||||
|
|
||||||
-- extend csv output with allocation data
|
-- extend csv output with allocation data
|
||||||
csvContents <- liftIO $ lines <$> readFile outcsv
|
csvContents <- liftIO $ lines <$> readFile outcsv
|
||||||
@ -370,7 +392,7 @@ parseMaxResidencyAndAllocations input =
|
|||||||
csvRules :: forall example . RuleResultForExample example => FilePattern -> Rules ()
|
csvRules :: forall example . RuleResultForExample example => FilePattern -> Rules ()
|
||||||
csvRules build = do
|
csvRules build = do
|
||||||
-- build results for every experiment*example
|
-- build results for every experiment*example
|
||||||
build -/- "*/*/*/results.csv" %> \out -> do
|
build -/- "*/*/*/*/results.csv" %> \out -> do
|
||||||
experiments <- askOracle $ GetExperiments ()
|
experiments <- askOracle $ GetExperiments ()
|
||||||
|
|
||||||
let allResultFiles = [takeDirectory out </> escaped (escapeExperiment e) <.> "csv" | e <- experiments]
|
let allResultFiles = [takeDirectory out </> escaped (escapeExperiment e) <.> "csv" | e <- experiments]
|
||||||
@ -380,6 +402,20 @@ csvRules build = do
|
|||||||
results = map tail allResults
|
results = map tail allResults
|
||||||
writeFileChanged out $ unlines $ header : concat results
|
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
|
-- aggregate all experiments for an example
|
||||||
build -/- "*/*/results.csv" %> \out -> do
|
build -/- "*/*/results.csv" %> \out -> do
|
||||||
versions <- map (T.unpack . humanName) <$> askOracle (GetVersions ())
|
versions <- map (T.unpack . humanName) <$> askOracle (GetVersions ())
|
||||||
@ -416,44 +452,60 @@ svgRules build = do
|
|||||||
void $ addOracle $ \(GetParent name) -> findPrev name <$> askOracle (GetVersions ())
|
void $ addOracle $ \(GetParent name) -> findPrev name <$> askOracle (GetVersions ())
|
||||||
-- chart GC stats for an experiment on a given revision
|
-- chart GC stats for an experiment on a given revision
|
||||||
priority 1 $
|
priority 1 $
|
||||||
build -/- "*/*/*/*.svg" %> \out -> do
|
build -/- "*/*/*/*/*.svg" %> \out -> do
|
||||||
let [_, _, _example, ver, _exp] = splitDirectories out
|
let [_, _, _example, ver, conf, _exp] = splitDirectories out
|
||||||
runLog <- loadRunLog (Escaped $ replaceExtension out "csv") ver
|
runLog <- loadRunLog (Escaped $ replaceExtension out "csv") ver conf
|
||||||
let diagram = Diagram Live [runLog] title
|
let diagram = Diagram Live [runLog] title
|
||||||
title = ver <> " live bytes over time"
|
title = ver <> " live bytes over time"
|
||||||
plotDiagram True diagram out
|
plotDiagram True diagram out
|
||||||
|
|
||||||
-- chart of GC stats for an experiment on this and the previous revision
|
-- chart of GC stats for an experiment on this and the previous revision
|
||||||
priority 2 $
|
priority 2 $
|
||||||
build -/- "*/*/*/*.diff.svg" %> \out -> do
|
build -/- "*/*/*/*/*.diff.svg" %> \out -> do
|
||||||
let [b, flav, example, ver, exp_] = splitDirectories out
|
let [b, flav, example, ver, conf, exp_] = splitDirectories out
|
||||||
exp = Escaped $ dropExtension2 exp_
|
exp = Escaped $ dropExtension2 exp_
|
||||||
prev <- fmap T.unpack $ askOracle $ GetParent $ T.pack ver
|
prev <- fmap T.unpack $ askOracle $ GetParent $ T.pack ver
|
||||||
|
|
||||||
runLog <- loadRunLog (Escaped $ replaceExtension (dropExtension out) "csv") ver
|
runLog <- loadRunLog (Escaped $ replaceExtension (dropExtension out) "csv") ver conf
|
||||||
runLogPrev <- loadRunLog (Escaped $ joinPath [b,flav, example, prev, replaceExtension (dropExtension exp_) "csv"]) prev
|
runLogPrev <- loadRunLog (Escaped $ joinPath [b,flav, example, prev, conf, replaceExtension (dropExtension exp_) "csv"]) prev conf
|
||||||
|
|
||||||
let diagram = Diagram Live [runLog, runLogPrev] title
|
let diagram = Diagram Live [runLog, runLogPrev] title
|
||||||
title = show (unescapeExperiment exp) <> " - live bytes over time compared"
|
title = show (unescapeExperiment exp) <> " - live bytes over time compared"
|
||||||
plotDiagram True diagram out
|
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
|
-- aggregated chart of GC stats for all the revisions
|
||||||
build -/- "*/*/*.svg" %> \out -> do
|
build -/- "*/*/*.svg" %> \out -> do
|
||||||
let exp = Escaped $ dropExtension $ takeFileName out
|
let exp = Escaped $ dropExtension $ takeFileName out
|
||||||
versions <- askOracle $ GetVersions ()
|
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)
|
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"
|
title = show (unescapeExperiment exp) <> " - live bytes over time"
|
||||||
plotDiagram False diagram out
|
plotDiagram False diagram out
|
||||||
|
|
||||||
heapProfileRules :: FilePattern -> Rules ()
|
heapProfileRules :: FilePattern -> Rules ()
|
||||||
heapProfileRules build = do
|
heapProfileRules build = do
|
||||||
priority 3 $
|
priority 3 $
|
||||||
build -/- "*/*/*/*.heap.svg" %> \out -> do
|
build -/- "*/*/*/*/*.heap.svg" %> \out -> do
|
||||||
let hpFile = dropExtension2 out <.> "hp"
|
let hpFile = dropExtension2 out <.> "hp"
|
||||||
need [hpFile]
|
need [hpFile]
|
||||||
cmd_ ("hp2pretty" :: String) [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
|
-- | A file path containing the output of -S for a given run
|
||||||
data RunLog = RunLog
|
data RunLog = RunLog
|
||||||
{ runVersion :: !String,
|
{ runVersion :: !String,
|
||||||
runFrames :: ![Frame],
|
runConfiguration :: !String,
|
||||||
runSuccess :: !Bool,
|
runFrames :: ![Frame],
|
||||||
runFirstReponse :: !(Maybe Seconds)
|
runSuccess :: !Bool,
|
||||||
|
runFirstReponse :: !(Maybe Seconds)
|
||||||
}
|
}
|
||||||
|
|
||||||
loadRunLog :: HasCallStack => Escaped FilePath -> String -> Action RunLog
|
loadRunLog :: HasCallStack => Escaped FilePath -> String -> String -> Action RunLog
|
||||||
loadRunLog (Escaped csv_fp) ver = do
|
loadRunLog (Escaped csv_fp) ver conf = do
|
||||||
let log_fp = replaceExtension csv_fp "gcStats.log"
|
let log_fp = replaceExtension csv_fp "gcStats.log"
|
||||||
log <- readFileLines log_fp
|
log <- readFileLines log_fp
|
||||||
csv <- readFileLines csv_fp
|
csv <- readFileLines csv_fp
|
||||||
@ -591,7 +644,7 @@ loadRunLog (Escaped csv_fp) ver = do
|
|||||||
, Just s <- readMaybe (T.unpack s)
|
, Just s <- readMaybe (T.unpack s)
|
||||||
-> (s,timeForFirstResponse)
|
-> (s,timeForFirstResponse)
|
||||||
_ -> error $ "Cannot parse: " <> csv_fp
|
_ -> 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)
|
~(c:_) <- E.liftCState $ S.gets (E.view E.colors)
|
||||||
E.plot $ do
|
E.plot $ do
|
||||||
lplot <- E.line
|
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)
|
[ [ (totElapsed f, extract f)
|
||||||
| f <- runFrames rl
|
| f <- runFrames rl
|
||||||
]
|
]
|
||||||
|
@ -1,7 +1,7 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
{-# LANGUAGE ExistentialQuantification #-}
|
{-# LANGUAGE ExistentialQuantification #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Plugins where
|
module HlsPlugins where
|
||||||
|
|
||||||
import Development.IDE.Types.Logger (Pretty (pretty), Recorder,
|
import Development.IDE.Types.Logger (Pretty (pretty), Recorder,
|
||||||
WithPriority, cmapWithPrio)
|
WithPriority, cmapWithPrio)
|
||||||
@ -11,9 +11,6 @@ import Ide.Types (IdePlugins)
|
|||||||
-- fixed plugins
|
-- fixed plugins
|
||||||
import Development.IDE (IdeState)
|
import Development.IDE (IdeState)
|
||||||
import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde
|
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
|
-- haskell-language-server optional plugins
|
||||||
#if hls_qualifyImportedNames
|
#if hls_qualifyImportedNames
|
||||||
@ -130,15 +127,12 @@ instance Pretty Log where
|
|||||||
-- These can be freely added or removed to tailor the available
|
-- These can be freely added or removed to tailor the available
|
||||||
-- features of the server.
|
-- features of the server.
|
||||||
|
|
||||||
idePlugins :: Recorder (WithPriority Log) -> Bool -> IdePlugins IdeState
|
idePlugins :: Recorder (WithPriority Log) -> IdePlugins IdeState
|
||||||
idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
|
idePlugins recorder = pluginDescToIdePlugins allPlugins
|
||||||
where
|
where
|
||||||
pluginRecorder :: forall log. (Pretty log) => Recorder (WithPriority log)
|
pluginRecorder :: forall log. (Pretty log) => Recorder (WithPriority log)
|
||||||
pluginRecorder = cmapWithPrio Log recorder
|
pluginRecorder = cmapWithPrio Log recorder
|
||||||
allPlugins = if includeExamples
|
allPlugins =
|
||||||
then basePlugins ++ examplePlugins
|
|
||||||
else basePlugins
|
|
||||||
basePlugins =
|
|
||||||
#if hls_pragmas
|
#if hls_pragmas
|
||||||
Pragmas.descriptor "pragmas" :
|
Pragmas.descriptor "pragmas" :
|
||||||
#endif
|
#endif
|
||||||
@ -215,9 +209,4 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
|
|||||||
#if explicitFixity
|
#if explicitFixity
|
||||||
++ [ExplicitFixity.descriptor pluginRecorder]
|
++ [ExplicitFixity.descriptor pluginRecorder]
|
||||||
#endif
|
#endif
|
||||||
examplePlugins =
|
|
||||||
[Example.descriptor pluginRecorder "eg"
|
|
||||||
,Example2.descriptor pluginRecorder "eg2"
|
|
||||||
,ExampleCabal.descriptor pluginRecorder "ec"
|
|
||||||
]
|
|
||||||
|
|
@ -10,23 +10,8 @@ import Test.Hls.Command
|
|||||||
-- ---------------------------------------------------------------------
|
-- ---------------------------------------------------------------------
|
||||||
|
|
||||||
tests :: TestTree
|
tests :: TestTree
|
||||||
tests = testGroup "diagnostics providers" [
|
tests = testGroup "diagnostics providers" [ warningTests ]
|
||||||
basicTests
|
|
||||||
, 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 :: TestTree
|
||||||
warningTests = testGroup "Warnings are warnings" [
|
warningTests = testGroup "Warnings are warnings" [
|
||||||
|
Loading…
Reference in New Issue
Block a user