Add benchmarks for hole fits

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:

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
         )
     ]
 

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:

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)
     ]

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"

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