ghcide-bench 2.0.0.1 → 2.1.0.0
raw patch · 3 files changed
+145/−79 lines, 3 filesdep +row-typesdep ~lsp-test
Dependencies added: row-types
Dependency ranges changed: lsp-test
Files
- ghcide-bench.cabal +3/−2
- src/Experiments.hs +114/−72
- src/Experiments/Types.hs +28/−5
ghcide-bench.cabal view
@@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide-bench-version: 2.0.0.1+version: 2.1.0.0 license: Apache-2.0 license-file: LICENSE author: The Haskell IDE team@@ -89,6 +89,7 @@ safe-exceptions, shake, text,+ row-types default-extensions: BangPatterns DeriveFunctor@@ -118,7 +119,7 @@ base, extra, ghcide-bench,- lsp-test ^>= 0.14,+ lsp-test ^>= 0.15.0.1, tasty, tasty-hunit >= 0.10, tasty-rerun,
src/Experiments.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-}@@ -23,54 +25,66 @@ , runBench , exampleToOptions ) where-import Control.Applicative.Combinators (skipManyTill)-import Control.Concurrent.Async (withAsync)-import Control.Exception.Safe (IOException, handleAny, try)-import Control.Monad.Extra (allM, forM, forM_, forever,- unless, void, when, whenJust,- (&&^))-import Control.Monad.Fail (MonadFail)+import Control.Applicative.Combinators (skipManyTill)+import Control.Concurrent.Async (withAsync)+import Control.Exception.Safe (IOException, handleAny,+ try)+import Control.Lens ((^.))+import Control.Lens.Extras (is)+import Control.Monad.Extra (allM, forM, forM_, forever,+ unless, void, when,+ whenJust, (&&^))+import Control.Monad.Fail (MonadFail) import Control.Monad.IO.Class-import Data.Aeson (Value (Null),- eitherDecodeStrict', toJSON)-import qualified Data.Aeson as A-import qualified Data.ByteString as BS-import Data.Either (fromRight)+import Data.Aeson (Value (Null),+ eitherDecodeStrict',+ toJSON)+import qualified Data.Aeson as A+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import Data.Either (fromRight) import Data.List import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T+import Data.Proxy+import Data.Row hiding (switch)+import Data.Text (Text)+import qualified Data.Text as T import Data.Version import Development.IDE.Plugin.Test import Development.IDE.Test.Diagnostic-import Development.Shake (CmdOption (Cwd, FileStdout),- cmd_)+import Development.Shake (CmdOption (Cwd, FileStdout),+ cmd_) import Experiments.Types+import Language.LSP.Protocol.Capabilities+import qualified Language.LSP.Protocol.Lens as L+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types hiding (Null,+ SemanticTokenAbsolute (..))+import qualified Language.LSP.Protocol.Types as LSP import Language.LSP.Test-import Language.LSP.Types hiding- (SemanticTokenAbsolute (length, line),- SemanticTokenRelative (length),- SemanticTokensEdit (_start))-import Language.LSP.Types.Capabilities import Numeric.Natural import Options.Applicative import System.Directory-import System.Environment.Blank (getEnv)-import System.FilePath ((<.>), (</>))+import System.Environment.Blank (getEnv)+import System.FilePath ((<.>), (</>)) import System.IO import System.Process import System.Time.Extra-import Text.ParserCombinators.ReadP (readP_to_S)+import Text.ParserCombinators.ReadP (readP_to_S) import Text.Printf charEdit :: Position -> TextDocumentContentChangeEvent charEdit p =- TextDocumentContentChangeEvent- { _range = Just (Range p p),- _rangeLength = Nothing,- _text = "a"- }+ TextDocumentContentChangeEvent $ InL $ #range .== Range p 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,@@ -104,6 +118,16 @@ 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]@@ -111,13 +135,13 @@ isJust <$> getHover doc (fromJust identifierP), --------------------------------------------------------------------------------------- bench "getDefinition" $ allWithIdentifierPos $ \DocumentPositions{..} ->- either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP),+ hasDefinitions <$> getDefinitions doc (fromJust identifierP), --------------------------------------------------------------------------------------- bench "getDefinition after edit" $ \docs -> do forM_ docs $ \DocumentPositions{..} -> changeDoc doc [charEdit stringLiteralP] flip allWithIdentifierPos docs $ \DocumentPositions{..} ->- either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP),+ hasDefinitions <$> getDefinitions doc (fromJust identifierP), --------------------------------------------------------------------------------------- bench "documentSymbols" $ allM $ \DocumentPositions{..} -> do fmap (either (not . null) (not . null)) . getDocumentSymbols $ doc,@@ -183,8 +207,8 @@ ( \docs -> do hieYamlUri <- getDocUri "hie.yaml" liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n"- sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $- List [ FileEvent hieYamlUri FcChanged ]+ sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $+ [ FileEvent hieYamlUri FileChangeType_Changed ] waitForProgressStart waitForProgressStart waitForProgressStart -- the Session logic restarts a second time@@ -199,17 +223,17 @@ (\docs -> do hieYamlUri <- getDocUri "hie.yaml" liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n"- sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $- List [ FileEvent hieYamlUri FcChanged ]+ sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $+ [ FileEvent hieYamlUri FileChangeType_Changed ] flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP) ), --------------------------------------------------------------------------------------- benchWithSetup "hole fit suggestions" ( mapM_ $ \DocumentPositions{..} -> do- let edit :: TextDocumentContentChangeEvent =TextDocumentContentChangeEvent- { _range = Just Range {_start = bottom, _end = bottom}- , _rangeLength = Nothing, _text = t}+ let edit =TextDocumentContentChangeEvent $ InL $ #range .== Range bottom bottom+ .+ #rangeLength .== Nothing+ .+ #text .== t bottom = Position maxBound 0 t = T.unlines [""@@ -229,12 +253,15 @@ flip allM docs $ \DocumentPositions{..} -> do bottom <- pred . length . T.lines <$> documentContents doc diags <- getCurrentDiagnostics doc- case requireDiagnostic diags (DsError, (fromIntegral bottom, 8), "Found hole", Nothing) of+ case requireDiagnostic diags (DiagnosticSeverity_Error, (fromIntegral bottom, 8), "Found hole", Nothing) of Nothing -> pure True Just _err -> pure False ) ]-+ where hasDefinitions (InL (Definition (InL _))) = True+ hasDefinitions (InL (Definition (InR ls))) = not $ null ls+ hasDefinitions (InR (InL ds)) = not $ null ds+ hasDefinitions (InR (InR LSP.Null)) = False --------------------------------------------------------------------------------------------- examplesPath :: FilePath@@ -265,23 +292,26 @@ <*> 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@@ -481,7 +511,7 @@ waitForProgressStart :: Session () waitForProgressStart = void $ do skipManyTill anyMessage $ satisfy $ \case- FromServerMess SWindowWorkDoneProgressCreate _ -> True+ FromServerMess SMethod_WindowWorkDoneProgressCreate _ -> True _ -> False -- | Wait for all progress to be done@@ -491,7 +521,7 @@ where loop = do ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case- FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just ()+ FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | is _workDoneProgressEnd v -> Just () _ -> Nothing done <- null <$> getIncompleteProgressSessions unless done loop@@ -499,13 +529,13 @@ -- | Wait for the build queue to be empty waitForBuildQueue :: Session Seconds waitForBuildQueue = do- let m = SCustomMethod "test"+ let m = SMethod_CustomMethod (Proxy @"test") waitId <- sendRequest m (toJSON WaitForShakeQueue) (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId case resp of- ResponseMessage{_result=Right Null} -> return td+ TResponseMessage{_result=Right Null} -> return td -- assume a ghcide binary lacking the WaitForShakeQueue method- _ -> return 0+ _ -> return 0 runBench :: HasConfig =>@@ -570,13 +600,25 @@ 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"@@ -622,8 +664,9 @@ 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 @@ -636,11 +679,10 @@ -- Setup the special positions used by the experiments lastLine <- fromIntegral . length . T.lines <$> documentContents doc- changeDoc doc [TextDocumentContentChangeEvent- { _range = Just (Range (Position lastLine 0) (Position lastLine 0))- , _rangeLength = Nothing- , _text = T.unlines [ "_hygienic = \"hygienic\"" ]- }]+ changeDoc doc [TextDocumentContentChangeEvent $ InL+ $ #range .== Range (Position lastLine 0) (Position lastLine 0)+ .+ #rangeLength .== Nothing+ .+ #text .== T.unlines [ "_hygienic = \"hygienic\"" ]] let -- Points to a string in the target file, -- convenient for hygienic edits@@ -649,19 +691,19 @@ -- Find an identifier defined in another file in this project symbols <- getDocumentSymbols doc let endOfImports = case symbols of- Left symbols | Just x <- findEndOfImports symbols -> x+ Right symbols | Just x <- findEndOfImports symbols -> x _ -> error $ "symbols: " <> show symbols contents <- documentContents doc identifierP <- searchSymbol doc contents endOfImports return $ DocumentPositions{..} findEndOfImports :: [DocumentSymbol] -> Maybe Position-findEndOfImports (DocumentSymbol{_kind = SkModule, _name = "imports", _range} : _) =+findEndOfImports (DocumentSymbol{_kind = SymbolKind_Module, _name = "imports", _range} : _) = Just $ Position (succ $ _line $ _end _range) 4-findEndOfImports [DocumentSymbol{_kind = SkFile, _children = Just (List cc)}] =+findEndOfImports [DocumentSymbol{_kind = SymbolKind_File, _children = Just (cc)}] = findEndOfImports cc findEndOfImports (DocumentSymbol{_range} : _) =- Just $ _start _range+ Just $ _range ^. L.start findEndOfImports _ = Nothing --------------------------------------------------------------------------------------------@@ -678,11 +720,11 @@ searchSymbol doc@TextDocumentIdentifier{_uri} fileContents pos = do -- this search is expensive, so we cache the result on disk let cachedPath = fromJust (uriToFilePath _uri) <.> "identifierPosition"- cachedRes <- liftIO $ try @_ @IOException $ read <$> readFile cachedPath+ cachedRes <- liftIO $ try @_ @IOException $ A.decode . BSL.fromStrict <$> BS.readFile cachedPath case cachedRes of Left _ -> do result <- loop pos- liftIO $ writeFile cachedPath $ show result+ liftIO $ BS.writeFile cachedPath $ BSL.toStrict $ A.encode result return result Right res -> return res@@ -708,8 +750,8 @@ checkDefinitions pos = do defs <- getDefinitions doc pos case defs of- (InL [Location uri _]) -> return $ uri /= _uri- _ -> return False+ (InL (Definition (InR [Location uri _]))) -> return $ uri /= _uri+ _ -> return False checkCompletions pos = not . null <$> getCompletions doc pos @@ -736,9 +778,9 @@ -- Copy&paste from ghcide/test/Development.IDE.Test tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b) tryCallTestPlugin cmd = do- let cm = SCustomMethod "test"+ let cm = SMethod_CustomMethod (Proxy @"test") waitId <- sendRequest cm (A.toJSON cmd)- ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId+ TResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId return $ case _result of Left e -> Left e Right json -> case A.fromJSON json of
src/Experiments/Types.hs view
@@ -40,12 +40,20 @@ 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 -- ^ directory where the package is located+ | ExampleHackage ExamplePackage -- ^ package from hackage+ | ExampleScript FilePath -- ^ location of the script we are running+ [String] -- ^ extra arguments for the script+ deriving (Eq, Generic, Show)+ deriving anyclass (Binary, Hashable, NFData)+ instance FromJSON Example where parseJSON = withObject "example" $ \x -> do exampleName <- x .: "name"@@ -55,24 +63,39 @@ 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 ] ++