allow running benchmarks on examples generated via a script

Author: wz1000

ghcide-bench/src/Experiments.hs

@@ -79,6 +79,12 @@ charEdit p =
                                         .+ #rangeLength .== Nothing
                                         .+ #text .== "a"
 
+headerEdit :: TextDocumentContentChangeEvent
+headerEdit =
+    TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 0) (Position 0 0)
+                                        .+ #rangeLength .== Nothing
+                                        .+ #text .== "-- header comment \n"
+
 data DocumentPositions = DocumentPositions {
     -- | A position that can be used to generate non null goto-def and completion responses
     identifierP    :: Maybe Position,
@@ -112,6 +118,16 @@ experiments =
         waitForProgressDone
         return True,
       ---------------------------------------------------------------------------------------
+      bench "edit-header" $ \docs -> do
+        forM_ docs $ \DocumentPositions{..} -> do
+          changeDoc doc [headerEdit]
+          -- wait for a fresh build start
+          waitForProgressStart
+        -- wait for the build to be finished
+        output "edit: waitForProgressDone"
+        waitForProgressDone
+        return True,
+      ---------------------------------------------------------------------------------------
       bench "hover after edit" $ \docs -> do
         forM_ docs $ \DocumentPositions{..} ->
           changeDoc doc [charEdit stringLiteralP]
@@ -276,23 +292,26 @@ 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")
-    <*> ( Example "name"
-               <$> (Right <$> packageP)
+    <*> ( Example
+               <$> exampleName
+               <*> (ExampleHackage <$> packageP)
                <*> (some moduleOption <|> pure ["src/Distribution/Simple.hs"])
                <*> pure []
-         <|>
-          Example "name"
-                <$> (Left <$> pathP)
-                <*> some moduleOption
-                <*> pure [])
+      <|> Example
+               <$> exampleName
+               <*> pathOrScriptP
+               <*> some moduleOption
+               <*> pure [])
     <*> switch (long "lsp-config" <> help "Read an LSP config payload from standard input")
   where
       moduleOption = strOption (long "example-module" <> metavar "PATH")
+      exampleName = strOption (long "example-name" <> metavar "NAME")
 
       packageP = ExamplePackage
             <$> strOption (long "example-package-name" <> value "Cabal")
             <*> option versionP (long "example-package-version" <> value (makeVersion [3,6,0,0]))
-      pathP = strOption (long "example-path")
+      pathOrScriptP = ExamplePath   <$> strOption (long "example-path")
+                  <|> ExampleScript <$> strOption (long "example-script") <*> many (strOption (long "example-script-args" <> help "arguments for the example generation script"))
 
 versionP :: ReadM Version
 versionP = maybeReader $ extract . readP_to_S parseVersion
@@ -581,13 +600,25 @@ setup :: HasConfig => IO SetupResult
 setup = do
 --   when alreadyExists $ removeDirectoryRecursive examplesPath
   benchDir <- case exampleDetails(example ?config) of
-      Left examplePath -> do
+      ExamplePath examplePath -> do
           let hieYamlPath = examplePath </> "hie.yaml"
           alreadyExists <- doesFileExist hieYamlPath
           unless alreadyExists $
                 cmd_ (Cwd examplePath) (FileStdout hieYamlPath) ("gen-hie"::String)
           return examplePath
-      Right ExamplePackage{..} -> do
+      ExampleScript examplePath' scriptArgs -> do
+          let exampleDir = examplesPath </> exampleName (example ?config)
+          alreadySetup <- doesDirectoryExist exampleDir
+          unless alreadySetup $ do
+            createDirectoryIfMissing True exampleDir
+            examplePath <- makeAbsolute examplePath'
+            cmd_ (Cwd exampleDir) examplePath scriptArgs
+            let hieYamlPath = exampleDir </> "hie.yaml"
+            alreadyExists <- doesFileExist hieYamlPath
+            unless alreadyExists $
+                  cmd_ (Cwd exampleDir) (FileStdout hieYamlPath) ("gen-hie"::String)
+          return exampleDir
+      ExampleHackage ExamplePackage{..} -> do
         let path = examplesPath </> package
             package = packageName <> "-" <> showVersion packageVersion
             hieYamlPath = path </> "hie.yaml"
@@ -633,8 +664,9 @@ setup = do
   whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True
 
   let cleanUp = case exampleDetails(example ?config) of
-        Right _ -> removeDirectoryRecursive examplesPath
-        Left _  -> return ()
+        ExampleHackage _  -> removeDirectoryRecursive examplesPath
+        ExampleScript _ _ -> removeDirectoryRecursive examplesPath
+        ExamplePath _     -> return ()
 
       runBenchmarks = runBenchmarksFun benchDir
 

ghcide-bench/src/Experiments/Types.hs

@@ -40,12 +40,19 @@ data ExamplePackage = ExamplePackage {packageName :: !String, packageVersion ::
 
 data Example = Example
     { exampleName      :: !String
-    , exampleDetails   :: Either FilePath ExamplePackage
+    , exampleDetails   :: ExampleDetails
     , exampleModules   :: [FilePath]
     , exampleExtraArgs :: [String]}
   deriving (Eq, Generic, Show)
   deriving anyclass (Binary, Hashable, NFData)
 
+data ExampleDetails
+  = ExamplePath FilePath
+  | ExampleHackage ExamplePackage
+  | ExampleScript FilePath [String]
+  deriving (Eq, Generic, Show)
+  deriving anyclass (Binary, Hashable, NFData)
+
 instance FromJSON Example where
     parseJSON = withObject "example" $ \x -> do
         exampleName <- x .: "name"
@@ -55,24 +62,39 @@ instance FromJSON Example where
         path <- x .:? "path"
         case path of
             Just examplePath -> do
-                let exampleDetails = Left examplePath
+                script <- fromMaybe False <$> x.:? "script"
+                args <- fromMaybe [] <$> x .:? "script-args"
+                let exampleDetails
+                      | script = ExampleScript examplePath args
+                      | otherwise = ExamplePath examplePath
                 return Example{..}
             Nothing -> do
                 packageName <- x .: "package"
                 packageVersion <- x .: "version"
-                let exampleDetails = Right ExamplePackage{..}
+                let exampleDetails = ExampleHackage ExamplePackage{..}
                 return Example{..}
 
 exampleToOptions :: Example -> [String] -> [String]
-exampleToOptions Example{exampleDetails = Right ExamplePackage{..}, ..} extraArgs =
+exampleToOptions Example{exampleDetails = ExampleHackage ExamplePackage{..}, ..} extraArgs =
     ["--example-package-name", packageName
     ,"--example-package-version", showVersion packageVersion
+    ,"--example-name", exampleName
     ] ++
     ["--example-module=" <> m | m <- exampleModules
     ] ++
     ["--ghcide-options=" <> o | o <- exampleExtraArgs ++ extraArgs]
-exampleToOptions Example{exampleDetails = Left examplePath, ..} extraArgs =
+exampleToOptions Example{exampleDetails = ExamplePath examplePath, ..} extraArgs =
     ["--example-path", examplePath
+    ,"--example-name", exampleName
+    ] ++
+    ["--example-module=" <> m | m <- exampleModules
+    ] ++
+    ["--ghcide-options=" <> o | o <- exampleExtraArgs ++ extraArgs]
+exampleToOptions Example{exampleDetails = ExampleScript examplePath exampleArgs, ..} extraArgs =
+    ["--example-script", examplePath
+    ,"--example-name", exampleName
+    ] ++
+    ["--example-script-args=" <> o | o <- exampleArgs
     ] ++
     ["--example-module=" <> m | m <- exampleModules
     ] ++