diff --git a/ghcide-bench.cabal b/ghcide-bench.cabal --- a/ghcide-bench.cabal +++ b/ghcide-bench.cabal @@ -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, diff --git a/src/Experiments.hs b/src/Experiments.hs --- a/src/Experiments.hs +++ b/src/Experiments.hs @@ -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 diff --git a/src/Experiments/Types.hs b/src/Experiments/Types.hs --- a/src/Experiments/Types.hs +++ b/src/Experiments/Types.hs @@ -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 ] ++