Merge branch 'master' into dependabot/github_actions/haskell-actions/setup-2.11.0

Author: crtschin

bench/config.yaml

@@ -95,16 +95,22 @@ experiments:
     - "edit"
     - "hover"
     - "semanticTokens"
+    - "semanticTokens after typing burst"
     - "hover after edit"
+    - "hover after typing burst"
     # - "hover after cradle edit"
     - "getDefinition"
     - "getDefinition after edit"
+    - "getDefinition after typing burst"
     - "completions"
     - "completions after edit"
+    - "completions after typing burst"
     - "code actions"
     - "code actions after edit"
+    - "code actions after typing burst"
     - "code actions after cradle edit"
     - "documentSymbols after edit"
+    - "documentSymbols after typing burst"
     - "hole fit suggestions"
     - "eval execute single-line code lens"
     - "eval execute multi-line code lens"

ghcide-bench/README.md

@@ -47,6 +47,8 @@ Currently the following experiments are defined:
 - *code actions*: makes an edit that breaks typechecking and asks for code actions
 - *hole fit suggestions*: measures the performance of hole fits
 - *X after edit*: combines the *edit* and X experiments
+- *X after typing burst*: makes five hygienic edits with a 250 ms delay between
+  edits, then waits for the X response
 - *X after cradle edit*: combines the X experiments with an edit to the `hie.yaml` file
 
 One can define additional experiments easily, for e.g. formatting, code lenses, renames, etc.

ghcide-bench/src/Experiments.hs

@@ -83,6 +83,12 @@ headerEdit =
         , _text = "-- header comment \n"
         }
 
+typingBurstEditCount :: Int
+typingBurstEditCount = 5
+
+typingBurstDelay :: Seconds
+typingBurstDelay = 0.25
+
 data DocumentPositions = DocumentPositions {
     -- | A position that can be used to generate non null goto-def and completion responses
     identifierP    :: Maybe Position,
@@ -100,6 +106,14 @@ allWithIdentifierPos f docs = case applicableDocs of
   where
     applicableDocs = filter (isJust . identifierP) docs
 
+applyTypingBurst :: [DocumentPositions] -> Session ()
+applyTypingBurst docs =
+    forM_ [1..typingBurstEditCount] $ \n -> do
+        forM_ docs $ \DocumentPositions{..} ->
+            changeDoc doc [charEdit stringLiteralP]
+        when (n < typingBurstEditCount) $
+            liftIO $ sleep typingBurstDelay
+
 experiments :: HasConfig => [Bench]
 experiments =
     [
@@ -115,6 +129,15 @@ experiments =
                 Nothing -> return False
         return $ and r,
       ---------------------------------------------------------------------------------------
+      bench "semanticTokens after typing burst" $ \docs -> do
+        applyTypingBurst docs
+        r <- forM docs $ \DocumentPositions{..} -> do
+            tks <- getSemanticTokens doc
+            case tks ^? LSP._L of
+                Just _  -> return True
+                Nothing -> return False
+        return $ and r,
+      ---------------------------------------------------------------------------------------
       bench "hover" $ allWithIdentifierPos $ \DocumentPositions{..} ->
         isJust <$> getHover doc (fromJust identifierP),
       ---------------------------------------------------------------------------------------
@@ -124,6 +147,11 @@ experiments =
         flip allWithIdentifierPos docs $ \DocumentPositions{..} ->
           isJust <$> getHover doc (fromJust identifierP),
       ---------------------------------------------------------------------------------------
+      bench "hover after typing burst" $ \docs -> do
+        applyTypingBurst docs
+        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->
+          isJust <$> getHover doc (fromJust identifierP),
+      ---------------------------------------------------------------------------------------
       bench
         "hover after cradle edit"
         (\docs -> do
@@ -158,10 +186,15 @@ experiments =
         hasDefinitions <$> getDefinitions doc (fromJust identifierP),
       ---------------------------------------------------------------------------------------
       bench "getDefinition after edit" $ \docs -> do
-          forM_ docs $ \DocumentPositions{..} ->
-            changeDoc doc [charEdit stringLiteralP]
-          flip allWithIdentifierPos docs $ \DocumentPositions{..} ->
-            hasDefinitions <$> getDefinitions doc (fromJust identifierP),
+        forM_ docs $ \DocumentPositions{..} ->
+          changeDoc doc [charEdit stringLiteralP]
+        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->
+          hasDefinitions <$> getDefinitions doc (fromJust identifierP),
+      ---------------------------------------------------------------------------------------
+      bench "getDefinition after typing burst" $ \docs -> do
+        applyTypingBurst docs
+        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->
+          hasDefinitions <$> getDefinitions doc (fromJust identifierP),
       ---------------------------------------------------------------------------------------
       bench "documentSymbols" $ allM $ \DocumentPositions{..} -> do
         fmap (either (not . null) (not . null)) . getDocumentSymbols $ doc,
@@ -172,6 +205,11 @@ experiments =
         flip allM docs $ \DocumentPositions{..} ->
           either (not . null) (not . null) <$> getDocumentSymbols doc,
       ---------------------------------------------------------------------------------------
+      bench "documentSymbols after typing burst" $ \docs -> do
+        applyTypingBurst docs
+        flip allM docs $ \DocumentPositions{..} ->
+          either (not . null) (not . null) <$> getDocumentSymbols doc,
+      ---------------------------------------------------------------------------------------
       bench "completions" $ \docs -> do
         flip allWithIdentifierPos docs $ \DocumentPositions{..} ->
           not . null <$> getCompletions doc (fromJust identifierP),
@@ -182,6 +220,11 @@ experiments =
         flip allWithIdentifierPos docs $ \DocumentPositions{..} ->
           not . null <$> getCompletions doc (fromJust identifierP),
       ---------------------------------------------------------------------------------------
+      bench "completions after typing burst" $ \docs -> do
+        applyTypingBurst docs
+        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->
+          not . null <$> getCompletions doc (fromJust identifierP),
+      ---------------------------------------------------------------------------------------
       bench
         "code actions"
         ( \docs -> do
@@ -206,6 +249,17 @@ experiments =
                 getCodeActions doc (Range p p))
         ),
       ---------------------------------------------------------------------------------------
+      bench
+        "code actions after typing burst"
+        ( \docs -> do
+            unless (any (isJust . identifierP) docs) $
+                error "None of the example modules is suitable for this experiment"
+            applyTypingBurst docs
+            not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do
+              forM identifierP $ \p ->
+                getCodeActions doc (Range p p))
+        ),
+      ---------------------------------------------------------------------------------------
       bench
         "code actions after cradle edit"
         ( \docs -> do
@@ -383,7 +437,7 @@ configP =
 
       packageP = ExamplePackage
             <$> strOption (long "example-package-name" <> value "Cabal")
-            <*> option versionP (long "example-package-version" <> value (makeVersion [3,6,0,0]))
+            <*> option versionP (long "example-package-version" <> value (makeVersion [3,16,1,0]))
       pathOrScriptP = ExamplePath   <$> strOption (long "example-path")
                   <|> ExampleScript <$> strOption (long "example-script") <*> many (strOption (long "example-script-args" <> help "arguments for the example generation script"))
 

ghcide-bench/test/Main.hs

@@ -36,6 +36,8 @@ benchmarkTests =
         | e <- Bench.experiments
         , Bench.name e /= "edit" -- the edit experiment does not ever fail
         , Bench.name e /= "hole fit suggestions" -- is too slow!
+        , not ("semanticTokens" `isInfixOf` Bench.name e) -- ghcide does not load the semantic-tokens plugin
+        , not ("code actions" `isInfixOf` Bench.name e) -- ghcide does not load the code-action plugin
         -- the cradle experiments are way too slow
         , not ("cradle" `isInfixOf` Bench.name e)
     ]

ghcide-test/exe/FindDefinitionAndHoverTests.hs

@@ -18,6 +18,7 @@ import           Control.Lens               ((^.))
 import           Development.IDE.Test       (expectDiagnostics,
                                              standardizeQuotes)
 import           Hover
+import           Ide.Types                  (Config (..), OptLinkTo (..))
 import           Test.Hls
 import           Test.Hls.FileSystem        (copyDir)
 import           Text.Regex.TDFA            ((=~))
@@ -104,7 +105,9 @@ tests = let
           , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _", Just "GHC-88464")])
           ]]
     , testGroup "type-definition" typeDefinitionTests
-    , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ]
+    , testGroup "hover-record-dot-syntax" recordDotSyntaxTests
+    , testGroup "source-and-doc-links" linkToTests
+    ]
 
   typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 sourceFilePath (pure tcData) "Saturated data con"
                         , tst (getTypeDefinitions, checkDefs) aL20 sourceFilePath (pure [ExpectNoDefinitions]) "Polymorphic variable"]
@@ -253,3 +256,63 @@ checkFileCompiles fp diag =
    testWithDummyPlugin ("hover: Does " ++ fp ++ " compile") (mkIdeTestFs [copyDir "hover"]) $ do
     _ <- openDoc fp "haskell"
     diag
+
+linkToTests :: [TestTree]
+linkToTests =
+  [ testGroup "LinkToHackage" linkToHackageTests
+  , testGroup "LinkToLocal" linkToLocalTests
+  ]
+  where
+    linkToHackageTests =
+      [ testGroup "doc link uses hackage URL"
+        [ testWithConfig "function" (hoverConfig (def { linkDocTo = LinkToHackage })) $
+            hoverCheck (Position 24 8) "GotoHover.hs"
+              [ ExpectHoverTextRegex (hackageUrlRegex "Documentation" "text" "v:pack") ]
+        , testWithConfig "type" (hoverConfig (def { linkDocTo = LinkToHackage })) $
+            hoverCheck (Position 8 11) "GotoHover.hs"
+              [ ExpectHoverTextRegex (hackageUrlRegex "Documentation" "text" "t:Text") ]
+        ]
+        , testGroup "source link uses hackage URL"
+        [ testWithConfig "function" (hoverConfig (def { linkSourceTo = LinkToHackage })) $
+          hoverCheck (Position 24 8) "GotoHover.hs"
+            [ ExpectHoverTextRegex (hackageUrlRegex "Source" "text" "pack") ]
+        , testWithConfig "type" (hoverConfig (def { linkSourceTo = LinkToHackage })) $
+          hoverCheck (Position 8 11) "GotoHover.hs"
+            [ ExpectHoverTextRegex (hackageUrlRegex "Source" "text" "Text") ]
+        ]
+      ]
+    linkToLocalTests =
+      [ testGroup "doc link does not use hackage URL"
+        [ testWithConfig "function" (hoverConfig (def { linkDocTo = LinkToLocal })) $
+            hoverCheck (Position 24 8) "GotoHover.hs"
+              [ ExpectHoverExcludeText [hackageUrlPrefix "Documentation"] ]
+        , testWithConfig "type" (hoverConfig (def { linkDocTo = LinkToLocal })) $
+            hoverCheck (Position 8 11) "GotoHover.hs"
+              [ ExpectHoverExcludeText [hackageUrlPrefix "Documentation"] ]
+        ]
+        , testGroup "source link does not use hackage URL"
+        [ testWithConfig "function" (hoverConfig (def { linkSourceTo = LinkToLocal })) $
+          hoverCheck (Position 24 8) "GotoHover.hs"
+            [ ExpectHoverExcludeText [hackageUrlPrefix "Source"] ]
+        , testWithConfig "type" (hoverConfig (def { linkSourceTo = LinkToLocal })) $
+          hoverCheck (Position 8 11) "GotoHover.hs"
+            [ ExpectHoverExcludeText [hackageUrlPrefix "Source"] ]
+        ]
+      ]
+    hackageUrlPrefix linkText = "\\[" <> linkText <> "\\]\\(https://hackage\\.haskell\\.org/package/"
+    hackageUrlRegex linkText pkg anchor
+      = hackageUrlPrefix linkText
+        <> pkg <> "-[0-9\\.]+/docs/[^#)]+\\.html#" <> anchor
+    hoverConfig lspConf = def
+        { testPluginDescriptor = dummyPlugin
+        , testDirLocation = Right (mkIdeTestFs [copyDir "hover"])
+        , testConfigCaps = lspTestCaps
+        , testShiftRoot = True
+        , testLspConfig = lspConf
+        }
+    hoverCheck pos fp expects = do
+        doc <- openDoc fp "haskell"
+        waitForProgressDone
+        _ <- waitForTypecheck doc
+        hover <- getHover doc pos
+        checkHover hover expects

ghcide/src/Development/IDE/Core/Rules.hs

@@ -584,8 +584,11 @@ getDocMapRule recorder =
       (tmrTypechecked -> tc, _) <- useWithStale_ TypeCheck file
       (hscEnv -> hsc, _)        <- useWithStale_ GhcSessionDeps file
       (HAR{refMap=rf}, _)       <- useWithStale_ GetHieAst file
-
-      dkMap <- liftIO $ mkDocMap hsc rf tc
+      cfg <- getClientConfigAction
+      dkMap <- liftIO $ mkDocMap hsc rf tc $ LinkTargets
+                { linkSource = linkSourceTo cfg
+                , linkDoc = linkDocTo cfg
+                }
       return ([],Just dkMap)
 
 -- | Persistent rule to ensure that hover doesn't block on startup

ghcide/src/Development/IDE/Core/Shake.hs

@@ -454,7 +454,9 @@ getIdeOptions = do
         Just env -> do
             config <- liftIO $ LSP.runLspT env HLS.getClientConfig
             return x{optCheckProject = pure $ checkProject config,
-                     optCheckParents = pure $ checkParents config
+                     optCheckParents = pure $ checkParents config,
+                     optLinkSourceTo = linkSourceTo config,
+                     optLinkDocTo = linkDocTo config
                 }
 
 getIdeOptionsIO :: ShakeExtras -> IO IdeOptions

ghcide/src/Development/IDE/GHC/Compat/Core.hs

@@ -334,6 +334,7 @@ module Development.IDE.GHC.Compat.Core (
 
     module GHC.Tc.Instance.Family,
     module GHC.Tc.Module,
+    module GHC.Tc.TyCl.Class,
     module GHC.Tc.Types,
     module GHC.Tc.Types.Evidence,
     module GHC.Tc.Utils.Env,
@@ -445,6 +446,7 @@ import           GHC.Rename.Splice
 import qualified GHC.Runtime.Interpreter     as GHCi
 import           GHC.Tc.Instance.Family
 import           GHC.Tc.Module
+import           GHC.Tc.TyCl.Class
 import           GHC.Tc.Types
 import           GHC.Tc.Types.Evidence       hiding ((<.>))
 import           GHC.Tc.Utils.Env

ghcide/src/Development/IDE/Plugin/Completions.hs

@@ -56,6 +56,8 @@ import           Development.IDE.Core.Rules               (usePropertyAction)
 
 import qualified Ide.Plugin.Config                        as Config
 
+import           Development.IDE.Types.Options            (LinkTargets (..),
+                                                           linkTargets)
 import qualified GHC.LanguageExtensions                   as LangExt
 
 data Log = LogShake Shake.Log deriving Show
@@ -136,7 +138,9 @@ resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} ur
           Nothing                                      -> (mempty, mempty)
     doc <- case lookupNameEnv dm name of
       Just doc -> pure $ spanDocToMarkdown doc
-      Nothing -> liftIO $ spanDocToMarkdown . fst <$> getDocumentationTryGhc (hscEnv sess) name
+      Nothing -> liftIO $ do
+        ltgts <- linkTargets <$> getIdeOptionsIO (shakeExtras ide)
+        spanDocToMarkdown . fst <$> getDocumentationTryGhc (hscEnv sess) ltgts name
     typ <- case lookupNameEnv km name of
       _ | not needType -> pure Nothing
       Just ty -> pure (safeTyThingType True ty)