diff --git a/.github/workflows/bench.yml b/.github/workflows/bench.yml index 91dd562bc5..fc3d980e7e 100644 --- a/.github/workflows/bench.yml +++ b/.github/workflows/bench.yml @@ -108,7 +108,7 @@ jobs: matrix: ghc: ['8.10.4'] os: [ubuntu-latest] - example: ['Cabal-3.0.0.0', 'lsp-types-1.0.0.1'] + example: ['cabal', 'lsp-types'] steps: - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} diff --git a/ghcide/bench/config.yaml b/ghcide/bench/config.yaml index c3142f60c3..dab10de3d8 100644 --- a/ghcide/bench/config.yaml +++ b/ghcide/bench/config.yaml @@ -12,20 +12,25 @@ outputFolder: bench-results # or a local project (path) with a valid `hie.yaml` file examples: # Medium-sized project without TH - - name: Cabal + - name: cabal + package: Cabal version: 3.0.0.0 modules: - Distribution/Simple.hs - Distribution/Types/Module.hs + extra-args: [] # extra ghcide command line args # Small-sized project with TH - name: lsp-types + package: lsp-types version: 1.0.0.1 modules: - src/Language/LSP/VFS.hs - src/Language/LSP/Types/Lens.hs + extra-args: [] # extra ghcide command line args # Small but heavily multi-component example # Disabled as it is far to slow. hie-bios >0.7.2 should help - # - path: bench/example/HLS + # - name: HLS + # path: bench/example/HLS # modules: # - hls-plugin-api/src/Ide/Plugin/Config.hs # - ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs diff --git a/ghcide/bench/hist/Main.hs b/ghcide/bench/hist/Main.hs index 797836f4e1..4fabc04da5 100644 --- a/ghcide/bench/hist/Main.hs +++ b/ghcide/bench/hist/Main.hs @@ -50,8 +50,8 @@ import Data.Yaml (FromJSON (..), decodeFileThrow) import Development.Benchmark.Rules import Development.Shake import Development.Shake.Classes -import Experiments.Types (Example, exampleToOptions) -import qualified Experiments.Types as E +import Experiments.Types (Example (exampleName), + exampleToOptions) import GHC.Generics (Generic) import Numeric.Natural (Natural) import System.Console.GetOpt @@ -68,7 +68,7 @@ configOpt = Option [] ["config"] (ReqArg Right configPath) "config file" readConfigIO :: FilePath -> IO (Config BuildSystem) readConfigIO = decodeFileThrow -instance IsExample Example where getExampleName = E.getExampleName +instance IsExample Example where getExampleName = exampleName type instance RuleResult GetExample = Maybe Example type instance RuleResult GetExamples = [Example] @@ -170,11 +170,10 @@ benchGhcide samples buildSystem args BenchProject{..} = do "--samples=" <> show samples, "--csv=" <> outcsv, "--ghcide=" <> exePath, - "--ghcide-options=" <> unwords exeExtraArgs, "--select", unescaped (unescapeExperiment experiment) ] ++ - exampleToOptions example ++ + exampleToOptions example exeExtraArgs ++ [ "--stack" | Stack == buildSystem ] @@ -187,6 +186,6 @@ warmupGhcide buildSystem exePath args example = do "--ghcide=" <> exePath, "--select=hover" ] ++ - exampleToOptions example ++ + exampleToOptions example [] ++ [ "--stack" | Stack == buildSystem ] diff --git a/ghcide/bench/lib/Experiments.hs b/ghcide/bench/lib/Experiments.hs index 562e870a61..59cbf7e104 100644 --- a/ghcide/bench/lib/Experiments.hs +++ b/ghcide/bench/lib/Experiments.hs @@ -239,16 +239,23 @@ configP = <*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count")) <*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide") <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response") - <*> ( GetPackage <$> strOption (long "example-package-name" <> value "Cabal") + <*> ( Example "name" + <$> (Right <$> packageP) <*> (some moduleOption <|> pure ["Distribution/Simple.hs"]) - <*> option versionP (long "example-package-version" <> value (makeVersion [3,4,0,0])) + <*> pure [] <|> - UsePackage <$> strOption (long "example-path") - <*> some moduleOption - ) + Example "name" + <$> (Left <$> pathP) + <*> some moduleOption + <*> pure []) where moduleOption = strOption (long "example-module" <> metavar "PATH") + packageP = ExamplePackage + <$> strOption (long "example-package-name" <> value "Cabal") + <*> option versionP (long "example-package-version" <> value (makeVersion [3,4,0,0])) + pathP = strOption (long "example-path") + versionP :: ReadM Version versionP = maybeReader $ extract . readP_to_S parseVersion where @@ -472,16 +479,16 @@ callCommandLogging cmd = do setup :: HasConfig => IO SetupResult setup = do -- when alreadyExists $ removeDirectoryRecursive examplesPath - benchDir <- case example ?config of - UsePackage{..} -> do + benchDir <- case exampleDetails(example ?config) of + Left examplePath -> do let hieYamlPath = examplePath "hie.yaml" alreadyExists <- doesFileExist hieYamlPath unless alreadyExists $ cmd_ (Cwd examplePath) (FileStdout hieYamlPath) ("gen-hie"::String) return examplePath - GetPackage{..} -> do + Right ExamplePackage{..} -> do let path = examplesPath package - package = exampleName <> "-" <> showVersion exampleVersion + package = packageName <> "-" <> showVersion packageVersion hieYamlPath = path "hie.yaml" alreadySetup <- doesDirectoryExist path unless alreadySetup $ @@ -524,9 +531,9 @@ setup = do whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True - let cleanUp = case example ?config of - GetPackage{} -> removeDirectoryRecursive examplesPath - UsePackage{} -> return () + let cleanUp = case exampleDetails(example ?config) of + Right _ -> removeDirectoryRecursive examplesPath + Left _ -> return () runBenchmarks = runBenchmarksFun benchDir diff --git a/ghcide/bench/lib/Experiments/Types.hs b/ghcide/bench/lib/Experiments/Types.hs index 2e3ede2f9b..633052efd6 100644 --- a/ghcide/bench/lib/Experiments/Types.hs +++ b/ghcide/bench/lib/Experiments/Types.hs @@ -4,11 +4,11 @@ module Experiments.Types (module Experiments.Types ) where import Data.Aeson +import Data.Maybe (fromMaybe) import Data.Version import Development.Shake.Classes import GHC.Generics import Numeric.Natural -import System.FilePath (isPathSeparator) data CabalStack = Cabal | Stack deriving (Eq, Show) @@ -31,40 +31,44 @@ data Config = Config } deriving (Eq, Show) -data Example - = GetPackage {exampleName :: !String, exampleModules :: [FilePath], exampleVersion :: Version} - | UsePackage {examplePath :: FilePath, exampleModules :: [FilePath]} +data ExamplePackage = ExamplePackage {packageName :: !String, packageVersion :: !Version} deriving (Eq, Generic, Show) deriving anyclass (Binary, Hashable, NFData) -getExampleName :: Example -> String -getExampleName UsePackage{examplePath} = map replaceSeparator examplePath - where - replaceSeparator x - | isPathSeparator x = '_' - | otherwise = x -getExampleName GetPackage{exampleName, exampleVersion} = - exampleName <> "-" <> showVersion exampleVersion +data Example = Example + { exampleName :: !String + , exampleDetails :: Either FilePath ExamplePackage + , exampleModules :: [FilePath] + , exampleExtraArgs :: [String]} + deriving (Eq, Generic, Show) + deriving anyclass (Binary, Hashable, NFData) instance FromJSON Example where parseJSON = withObject "example" $ \x -> do + exampleName <- x .: "name" exampleModules <- x .: "modules" + exampleExtraArgs <- fromMaybe [] <$> x .:? "extra-args" path <- x .:? "path" case path of - Just examplePath -> return UsePackage{..} + Just examplePath -> do + let exampleDetails = Left examplePath + return Example{..} Nothing -> do - exampleName <- x .: "name" - exampleVersion <- x .: "version" - return GetPackage {..} + packageName <- x .: "package" + packageVersion <- x .: "version" + let exampleDetails = Right ExamplePackage{..} + return Example{..} -exampleToOptions :: Example -> [String] -exampleToOptions GetPackage{..} = - ["--example-package-name", exampleName - ,"--example-package-version", showVersion exampleVersion +exampleToOptions :: Example -> [String] -> [String] +exampleToOptions Example{exampleDetails = Right ExamplePackage{..}, ..} extraArgs = + ["--example-package-name", packageName + ,"--example-package-version", showVersion packageVersion + ,"--ghcide-options", unwords $ exampleExtraArgs ++ extraArgs ] ++ ["--example-module=" <> m | m <- exampleModules] -exampleToOptions UsePackage{..} = +exampleToOptions Example{exampleDetails = Left examplePath, ..} extraArgs = ["--example-path", examplePath + ,"--ghcide-options", unwords $ exampleExtraArgs ++ extraArgs ] ++ ["--example-module=" <> m | m <- exampleModules]