diff --git a/ghcide/bench/config.yaml b/ghcide/bench/config.yaml index 8977f57106..c3142f60c3 100644 --- a/ghcide/bench/config.yaml +++ b/ghcide/bench/config.yaml @@ -48,6 +48,7 @@ experiments: - "code actions after edit" - "code actions after cradle edit" - "documentSymbols after edit" + - "hole fit suggestions" # An ordered list of versions to analyze versions: diff --git a/ghcide/bench/lib/Experiments.hs b/ghcide/bench/lib/Experiments.hs index 955df3e5d5..70f764c484 100644 --- a/ghcide/bench/lib/Experiments.hs +++ b/ghcide/bench/lib/Experiments.hs @@ -31,6 +31,7 @@ import Data.Maybe 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 Experiments.Types @@ -169,6 +170,36 @@ experiments = sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ List [ FileEvent (filePathToUri "hie.yaml") FcChanged ] 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} + bottom = Position maxBound 0 + t = T.unlines + ["" + ,"holef :: [Int] -> [Int]" + ,"holef = _" + ,"" + ,"holeg :: [()] -> [()]" + ,"holeg = _" + ] + changeDoc doc [edit] + ) + (\docs -> do + forM_ docs $ \DocumentPositions{..} -> + changeDoc doc [charEdit stringLiteralP] + void waitForDiagnostics + waitForProgressDone + flip allM docs $ \DocumentPositions{..} -> do + bottom <- pred . length . T.lines <$> documentContents doc + diags <- getCurrentDiagnostics doc + case requireDiagnostic diags (DsError, (bottom, 8), "Found hole", Nothing) of + Nothing -> pure True + Just _err -> pure False ) ] diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 0d4f4b259d..eb6adabe55 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -370,6 +370,7 @@ test-suite ghcide-tests main-is: Main.hs other-modules: Development.IDE.Test + Development.IDE.Test.Diagnostic Development.IDE.Test.Runfiles Experiments Experiments.Types @@ -403,17 +404,20 @@ executable ghcide-bench extra, filepath, ghcide, + lens, lsp-test, + lsp-types, optparse-applicative, process, safe-exceptions, hls-graph, shake, text - hs-source-dirs: bench/lib bench/exe + 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.Diagnostic Experiments Experiments.Types default-extensions: diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 40f3ddab5f..44358d5a5f 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -5137,6 +5137,7 @@ benchmarkTests = 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) ] diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index 90e9b7ba31..e58de86a38 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -33,6 +33,7 @@ import Data.Maybe (fromJust) import qualified Data.Text as T import Development.IDE.Plugin.Test (TestRequest (..), WaitForIdeRuleResult) +import Development.IDE.Test.Diagnostic import Language.LSP.Test hiding (message) import qualified Language.LSP.Test as LspTest import Language.LSP.Types @@ -41,31 +42,14 @@ import System.Directory (canonicalizePath) import System.Time.Extra import Test.Tasty.HUnit --- | (0-based line number, 0-based column number) -type Cursor = (Int, Int) - -cursorPosition :: Cursor -> Position -cursorPosition (line, col) = Position line col - -requireDiagnostic :: HasCallStack => List Diagnostic -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) -> Assertion -requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) = do - unless (any match actuals) $ - assertFailure $ - "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 +requireDiagnosticM + :: (Foldable f, Show (f Diagnostic), HasCallStack) + => f Diagnostic + -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) + -> Assertion +requireDiagnosticM actuals expected = case requireDiagnostic actuals expected of + Nothing -> pure () + Just err -> assertFailure err -- |wait for @timeout@ seconds and report an assertion failure -- if any diagnostic messages arrive in that period @@ -154,7 +138,7 @@ expectDiagnosticsWithTags' next expected = go expected <> " got " <> show actual Just expected -> do - liftIO $ mapM_ (requireDiagnostic actual) expected + liftIO $ mapM_ (requireDiagnosticM actual) expected liftIO $ unless (length expected == length actual) $ assertFailure $ @@ -182,14 +166,6 @@ canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePat diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics) diagnostic = LspTest.message STextDocumentPublishDiagnostics -standardizeQuotes :: T.Text -> T.Text -standardizeQuotes msg = let - repl '‘' = '\'' - repl '’' = '\'' - repl '`' = '\'' - repl c = c - in T.map repl msg - waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) waitForAction key TextDocumentIdentifier{_uri} = do let cm = SCustomMethod "test" diff --git a/ghcide/test/src/Development/IDE/Test/Diagnostic.hs b/ghcide/test/src/Development/IDE/Test/Diagnostic.hs new file mode 100644 index 0000000000..2a1b812f7e --- /dev/null +++ b/ghcide/test/src/Development/IDE/Test/Diagnostic.hs @@ -0,0 +1,47 @@ +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 = (Int, Int) + +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