Skip to content

Commit 46eaf58

Browse files
pepeiborrapepeiborra
authored
Add benchmarks for hole fits (#2027)
* Add benchmarks for hole fits * check that the hole fit diagnostics exist * waitForDiagnostics * skip experiment test for hole fit suggestions
1 parent 45fdb25 commit 46eaf58

File tree

6 files changed

+95
-35
lines changed

6 files changed

+95
-35
lines changed

‎ghcide/bench/config.yaml

+1
Original file line numberDiff line numberDiff line change
@@ -48,6 +48,7 @@ experiments:
4848
- "code actions after edit"
4949
- "code actions after cradle edit"
5050
- "documentSymbols after edit"
51+
- "hole fit suggestions"
5152

5253
# An ordered list of versions to analyze
5354
versions:

‎ghcide/bench/lib/Experiments.hs

+31
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,7 @@ import Data.Maybe
3131
import qualified Data.Text as T
3232
import Data.Version
3333
import Development.IDE.Plugin.Test
34+
import Development.IDE.Test.Diagnostic
3435
import Development.Shake (CmdOption (Cwd, FileStdout),
3536
cmd_)
3637
import Experiments.Types
@@ -169,6 +170,36 @@ experiments =
169170
sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
170171
List [ FileEvent (filePathToUri "hie.yaml") FcChanged ]
171172
flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP)
173+
),
174+
---------------------------------------------------------------------------------------
175+
benchWithSetup
176+
"hole fit suggestions"
177+
( mapM_ $ \DocumentPositions{..} -> do
178+
let edit :: TextDocumentContentChangeEvent =TextDocumentContentChangeEvent
179+
{ _range = Just Range {_start = bottom, _end = bottom}
180+
, _rangeLength = Nothing, _text = t}
181+
bottom = Position maxBound 0
182+
t = T.unlines
183+
[""
184+
,"holef :: [Int] -> [Int]"
185+
,"holef = _"
186+
,""
187+
,"holeg :: [()] -> [()]"
188+
,"holeg = _"
189+
]
190+
changeDoc doc [edit]
191+
)
192+
(\docs -> do
193+
forM_ docs $ \DocumentPositions{..} ->
194+
changeDoc doc [charEdit stringLiteralP]
195+
void waitForDiagnostics
196+
waitForProgressDone
197+
flip allM docs $ \DocumentPositions{..} -> do
198+
bottom <- pred . length . T.lines <$> documentContents doc
199+
diags <- getCurrentDiagnostics doc
200+
case requireDiagnostic diags (DsError, (bottom, 8), "Found hole", Nothing) of
201+
Nothing -> pure True
202+
Just _err -> pure False
172203
)
173204
]
174205

‎ghcide/ghcide.cabal

+5-1
Original file line numberDiff line numberDiff line change
@@ -370,6 +370,7 @@ test-suite ghcide-tests
370370
main-is: Main.hs
371371
other-modules:
372372
Development.IDE.Test
373+
Development.IDE.Test.Diagnostic
373374
Development.IDE.Test.Runfiles
374375
Experiments
375376
Experiments.Types
@@ -403,17 +404,20 @@ executable ghcide-bench
403404
extra,
404405
filepath,
405406
ghcide,
407+
lens,
406408
lsp-test,
409+
lsp-types,
407410
optparse-applicative,
408411
process,
409412
safe-exceptions,
410413
hls-graph,
411414
shake,
412415
text
413-
hs-source-dirs: bench/lib bench/exe
416+
hs-source-dirs: bench/lib bench/exe test/src
414417
ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts
415418
main-is: Main.hs
416419
other-modules:
420+
Development.IDE.Test.Diagnostic
417421
Experiments
418422
Experiments.Types
419423
default-extensions:

‎ghcide/test/exe/Main.hs

+1
Original file line numberDiff line numberDiff line change
@@ -5137,6 +5137,7 @@ benchmarkTests =
51375137
assertBool "did not successfully complete 5 repetitions" $ Bench.success res
51385138
| e <- Bench.experiments
51395139
, Bench.name e /= "edit" -- the edit experiment does not ever fail
5140+
, Bench.name e /= "hole fit suggestions" -- is too slow!
51405141
-- the cradle experiments are way too slow
51415142
, not ("cradle" `isInfixOf` Bench.name e)
51425143
]

‎ghcide/test/src/Development/IDE/Test.hs

+10-34
Original file line numberDiff line numberDiff line change
@@ -33,6 +33,7 @@ import Data.Maybe (fromJust)
3333
import qualified Data.Text as T
3434
import Development.IDE.Plugin.Test (TestRequest (..),
3535
WaitForIdeRuleResult)
36+
import Development.IDE.Test.Diagnostic
3637
import Language.LSP.Test hiding (message)
3738
import qualified Language.LSP.Test as LspTest
3839
import Language.LSP.Types
@@ -41,31 +42,14 @@ import System.Directory (canonicalizePath)
4142
import System.Time.Extra
4243
import Test.Tasty.HUnit
4344

44-
-- | (0-based line number, 0-based column number)
45-
type Cursor = (Int, Int)
46-
47-
cursorPosition :: Cursor -> Position
48-
cursorPosition (line, col) = Position line col
49-
50-
requireDiagnostic :: HasCallStack => List Diagnostic -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) -> Assertion
51-
requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) = do
52-
unless (any match actuals) $
53-
assertFailure $
54-
"Could not find " <> show expected <>
55-
" in " <> show actuals
56-
where
57-
match :: Diagnostic -> Bool
58-
match d =
59-
Just severity == _severity d
60-
&& cursorPosition cursor == d ^. range . start
61-
&& standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf`
62-
standardizeQuotes (T.toLower $ d ^. message)
63-
&& hasTag expectedTag (d ^. tags)
64-
65-
hasTag :: Maybe DiagnosticTag -> Maybe (List DiagnosticTag) -> Bool
66-
hasTag Nothing _ = True
67-
hasTag (Just _) Nothing = False
68-
hasTag (Just actualTag) (Just (List tags)) = actualTag `elem` tags
45+
requireDiagnosticM
46+
:: (Foldable f, Show (f Diagnostic), HasCallStack)
47+
=> f Diagnostic
48+
-> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)
49+
-> Assertion
50+
requireDiagnosticM actuals expected = case requireDiagnostic actuals expected of
51+
Nothing -> pure ()
52+
Just err -> assertFailure err
6953

7054
-- |wait for @timeout@ seconds and report an assertion failure
7155
-- if any diagnostic messages arrive in that period
@@ -154,7 +138,7 @@ expectDiagnosticsWithTags' next expected = go expected
154138
<> " got "
155139
<> show actual
156140
Just expected -> do
157-
liftIO $ mapM_ (requireDiagnostic actual) expected
141+
liftIO $ mapM_ (requireDiagnosticM actual) expected
158142
liftIO $
159143
unless (length expected == length actual) $
160144
assertFailure $
@@ -182,14 +166,6 @@ canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePat
182166
diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics)
183167
diagnostic = LspTest.message STextDocumentPublishDiagnostics
184168

185-
standardizeQuotes :: T.Text -> T.Text
186-
standardizeQuotes msg = let
187-
repl '‘' = '\''
188-
repl '’' = '\''
189-
repl '`' = '\''
190-
repl c = c
191-
in T.map repl msg
192-
193169
waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
194170
waitForAction key TextDocumentIdentifier{_uri} = do
195171
let cm = SCustomMethod "test"

‎ghcide/test/src/Development/IDE/Test/Diagnostic.hs

+47
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,47 @@
1+
module Development.IDE.Test.Diagnostic where
2+
3+
import Control.Lens ((^.))
4+
import qualified Data.Text as T
5+
import GHC.Stack (HasCallStack)
6+
import Language.LSP.Types
7+
import Language.LSP.Types.Lens as Lsp
8+
9+
-- | (0-based line number, 0-based column number)
10+
type Cursor = (Int, Int)
11+
12+
cursorPosition :: Cursor -> Position
13+
cursorPosition (line, col) = Position line col
14+
15+
type ErrorMsg = String
16+
17+
requireDiagnostic
18+
:: (Foldable f, Show (f Diagnostic), HasCallStack)
19+
=> f Diagnostic
20+
-> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)
21+
-> Maybe ErrorMsg
22+
requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag)
23+
| any match actuals = Nothing
24+
| otherwise = Just $
25+
"Could not find " <> show expected <>
26+
" in " <> show actuals
27+
where
28+
match :: Diagnostic -> Bool
29+
match d =
30+
Just severity == _severity d
31+
&& cursorPosition cursor == d ^. range . start
32+
&& standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf`
33+
standardizeQuotes (T.toLower $ d ^. message)
34+
&& hasTag expectedTag (d ^. tags)
35+
36+
hasTag :: Maybe DiagnosticTag -> Maybe (List DiagnosticTag) -> Bool
37+
hasTag Nothing _ = True
38+
hasTag (Just _) Nothing = False
39+
hasTag (Just actualTag) (Just (List tags)) = actualTag `elem` tags
40+
41+
standardizeQuotes :: T.Text -> T.Text
42+
standardizeQuotes msg = let
43+
repl '‘' = '\''
44+
repl '’' = '\''
45+
repl '`' = '\''
46+
repl c = c
47+
in T.map repl msg

0 commit comments

Comments
 (0)