Document LANGUAGE extensions in hover and completion

docs/features.md

@@ -64,6 +64,12 @@ Provided by: `hls-explicit-fixity-plugin`
 
 Provides fixity information.
 
+### Language pragma documentation
+
+Provided by: `hls-pragmas-plugin`
+
+Shows documentation for language extensions on hover.
+
 ## Signature help
 
 Provided by: `hls-signature-help-plugin`
@@ -125,6 +131,8 @@ Provided by: `hls-pragmas-plugin`
 
 Completions for language pragmas.
 
+Language extension completion items include documentation.
+
 ### `case`/`\case` pattern completion
 
 Provided by: `hls-case-split-plugin`

ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs

@@ -8,6 +8,9 @@ module Development.IDE.Plugin.HLS.GhcIde
   , Log(..)
   ) where
 
+import           Control.Monad.IO.Class              (liftIO)
+import qualified Data.Text                            as T
+import qualified Data.Text.Utf16.Rope.Mixed           as Rope
 import           Development.IDE
 import qualified Development.IDE.LSP.HoverDefinition as Hover
 import qualified Development.IDE.LSP.Notifications   as Notifications
@@ -66,5 +69,22 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc)
 -- ---------------------------------------------------------------------
 
 hover' :: Recorder (WithPriority Hover.Log) -> PluginMethodHandler IdeState Method_TextDocumentHover
-hover' recorder ideState _ HoverParams{..} =
-    Hover.hover recorder ideState TextDocumentPositionParams{..}
+hover' recorder ideState _ HoverParams
+    { _textDocument = TextDocumentIdentifier uri
+    , _position = position
+    } = do
+    contents <- liftIO $ runAction "GhcIde.hover" ideState $ getUriContents $ toNormalizedUri uri
+    if isLanguagePragmaLine position (Rope.toText <$> contents)
+      then pure $ InR Null
+      else Hover.hover recorder ideState $ TextDocumentPositionParams
+        (TextDocumentIdentifier uri) position
+
+isLanguagePragmaLine :: Position -> Maybe T.Text -> Bool
+isLanguagePragmaLine (Position line _) contents =
+  maybe False (T.isPrefixOf "{-# LANGUAGE " . T.stripStart) $ do
+    source <- contents
+    atMay (T.lines source) (fromIntegral line)
+  where
+    atMay xs index = case drop index xs of
+      x : _ -> Just x
+      []    -> Nothing

haskell-language-server.cabal

@@ -927,6 +927,7 @@ library hls-pragmas-plugin
     , lens
     , lsp
     , text
+    , text-rope
     , containers
 
 test-suite hls-pragmas-plugin-tests

plugins/hls-pragmas-plugin/test/Main.hs

@@ -22,6 +22,9 @@ pragmasSuggestPlugin = mkPluginTestDescriptor' suggestPragmaDescriptor "pragmas"
 pragmasCompletionPlugin :: PluginTestDescriptor ()
 pragmasCompletionPlugin = mkPluginTestDescriptor' completionDescriptor "pragmas"
 
+pragmasHoverPlugin :: PluginTestDescriptor ()
+pragmasHoverPlugin = mkPluginTestDescriptor' hoverDescriptor "pragmas"
+
 pragmasDisableWarningPlugin :: PluginTestDescriptor ()
 pragmasDisableWarningPlugin = mkPluginTestDescriptor' suggestDisableWarningDescriptor "pragmas"
 
@@ -31,6 +34,11 @@ tests =
   [ codeActionTests
   , codeActionTests'
   , completionTests
+  , completionDocumentationTest
+  , hoverDocumentationTest
+  , hoverStatusAndImplicationsTest
+  , hoverSelectsExtensionTest
+  , hoverIgnoresNonPragmaTest
   , completionSnippetTests
   , dontSuggestCompletionTests
   ]
@@ -139,6 +147,88 @@ completionTests =
   , completionTest "completes GHC2021 extensions" "Completion.hs" "ghc" "GHC2021" Nothing Nothing Nothing (0, 13, 0, 31, 0, 16)
   ]
 
+completionDocumentationTest :: TestTree
+completionDocumentationTest = testCase "documents language extension completions" $ runSessionWithServer def pragmasCompletionPlugin testDataDir $ do
+  doc <- openDoc "Completion.hs" "haskell"
+  _ <- waitForDiagnostics
+  compls <- getCompletions doc (Position 0 24)
+  item <- getCompletionByLabel "OverloadedStrings" compls
+  liftIO $ case item ^. L.documentation of
+    Just (InR (MarkupContent MarkupKind_Markdown contents)) -> do
+      assertBool "documentation names the extension" ("OverloadedStrings" `T.isInfixOf` contents)
+      assertBool "documentation describes the extension" ("Desugar string literals via `IsString` class." `T.isInfixOf` contents)
+      assertBool "documentation links to the extension page" ("overloaded_strings.html#extension-OverloadedStrings" `T.isInfixOf` contents)
+      assertBool "documentation includes the GHC version" ("Since GHC 6.8.1" `T.isInfixOf` contents)
+      assertBool "documentation uses a table" ("| Field | Value |" `T.isInfixOf` contents)
+    _ -> assertFailure "Expected Markdown documentation for OverloadedStrings"
+
+  bangDoc <- openDoc "TargetedLinks.hs" "haskell"
+  _ <- waitForDiagnostics
+  bangCompletions <- getCompletions bangDoc (Position 0 18)
+  bangPatterns <- getCompletionByLabel "BangPatterns" bangCompletions
+  liftIO $ case bangPatterns ^. L.documentation of
+    Just (InR (MarkupContent MarkupKind_Markdown contents)) -> do
+      assertBool "documentation links to the shared strictness page" ("strict.html#extension-BangPatterns" `T.isInfixOf` contents)
+      assertBool "documentation includes the GHC version" ("Since GHC 6.8.1" `T.isInfixOf` contents)
+      assertBool "documentation includes language editions" ("Included in GHC2024, GHC2021" `T.isInfixOf` contents)
+      assertBool "documentation labels the status" ("| Status | Included in GHC2024, GHC2021 |" `T.isInfixOf` contents)
+    _ -> assertFailure "Expected Markdown documentation for BangPatterns"
+
+hoverDocumentationTest :: TestTree
+hoverDocumentationTest = testCase "documents language extensions on hover" $ runSessionWithServer def pragmasHoverPlugin testDataDir $ do
+  doc <- openDoc "Completion.hs" "haskell"
+  _ <- waitForDiagnostics
+  hover <- getHover doc (Position 0 20)
+  liftIO $ case hover of
+    Just (Hover (InL (MarkupContent MarkupKind_Markdown contents)) _) -> do
+      assertBool "hover names the extension" ("OverloadedStrings" `T.isInfixOf` contents)
+      assertBool "hover describes the extension" ("Desugar string literals via `IsString` class." `T.isInfixOf` contents)
+      assertBool "hover links to the extension page" ("overloaded_strings.html#extension-OverloadedStrings" `T.isInfixOf` contents)
+      assertBool "hover includes the GHC version" ("Since GHC 6.8.1" `T.isInfixOf` contents)
+      assertBool "hover uses a table" ("| Field | Value |" `T.isInfixOf` contents)
+    _ -> assertFailure "Expected Markdown documentation for OverloadedStrings"
+
+hoverStatusAndImplicationsTest :: TestTree
+hoverStatusAndImplicationsTest = testCase "documents extension status and linked implications" $ runSessionWithServer def pragmasHoverPlugin testDataDir $ do
+  doc <- openDoc "Hover.hs" "haskell"
+  _ <- waitForDiagnostics
+  hover <- getHover doc (Position 1 20)
+  liftIO $ case hover of
+    Just (Hover (InL (MarkupContent MarkupKind_Markdown contents)) _) -> do
+      assertBool "hover shows deprecated status" ("| Status | Deprecated |" `T.isInfixOf` contents)
+      assertBool "hover links implied extensions" ("[OverlappingInstances](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/instances.html#extension-OverlappingInstances)" `T.isInfixOf` contents)
+    _ -> assertFailure "Expected Markdown documentation for IncoherentInstances"
+  negatedHover <- getHover doc (Position 2 20)
+  liftIO $ case negatedHover of
+    Just (Hover (InL (MarkupContent MarkupKind_Markdown contents)) _) ->
+      assertBool "negated extensions do not imply enabled extensions" (not $ "| Implies |" `T.isInfixOf` contents)
+    _ -> assertFailure "Expected Markdown documentation for NoIncoherentInstances"
+  nondecreasingHover <- getHover doc (Position 3 20)
+  liftIO $ case nondecreasingHover of
+    Just (Hover (InL (MarkupContent MarkupKind_Markdown contents)) _) ->
+      assertBool "extensions beginning with No are not treated as negated" (not $ "Disable the" `T.isInfixOf` contents)
+    _ -> assertFailure "Expected Markdown documentation for NondecreasingIndentation"
+
+hoverSelectsExtensionTest :: TestTree
+hoverSelectsExtensionTest = testCase "selects the language extension under the cursor" $ runSessionWithServer def pragmasHoverPlugin testDataDir $ do
+  doc <- openDoc "Hover.hs" "haskell"
+  _ <- waitForDiagnostics
+  hover <- getHover doc (Position 0 33)
+  liftIO $ case hover of
+    Just (Hover (InL (MarkupContent MarkupKind_Markdown contents)) _) ->
+      assertBool "hover documents the selected extension" ("OverloadedStrings" `T.isInfixOf` contents)
+    _ -> assertFailure "Expected Markdown documentation for OverloadedStrings"
+
+hoverIgnoresNonPragmaTest :: TestTree
+hoverIgnoresNonPragmaTest = testCase "does not document ordinary Haskell code on hover" $ runSessionWithServer def pragmasHoverPlugin testDataDir $ do
+  doc <- openDoc "Completion.hs" "haskell"
+  _ <- waitForDiagnostics
+  hover <- getHover doc (Position 3 1)
+  liftIO $ case hover of
+    Nothing -> pure ()
+    Just (Hover (InL (MarkupContent _ contents)) _) -> contents @?= ""
+    _ -> assertFailure "Expected no documentation for ordinary Haskell code"
+
 completionSnippetTests :: TestTree
 completionSnippetTests =
   testGroup "expand snippet to pragma" $

plugins/hls-pragmas-plugin/test/testdata/Hover.hs

@@ -0,0 +1,6 @@
+{-# LANGUAGE TypeApplications, OverloadedStrings #-}
+{-# LANGUAGE IncoherentInstances #-}
+{-# LANGUAGE NoIncoherentInstances #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+
+module Hover where

plugins/hls-pragmas-plugin/test/testdata/TargetedLinks.hs

@@ -0,0 +1 @@
+{-# LANGUAGE BangP #-}

src/HlsPlugins.hs

@@ -159,6 +159,7 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins
 #if hls_pragmas
       Pragmas.suggestPragmaDescriptor  "pragmas-suggest" :
       Pragmas.completionDescriptor  "pragmas-completion" :
+      Pragmas.hoverDescriptor  "pragmas-hover" :
       Pragmas.suggestDisableWarningDescriptor  "pragmas-disable" :
 #endif
 #if hls_fourmolu

test/testdata/schema/ghc910/default-config.golden.json

@@ -120,6 +120,9 @@
         "pragmas-disable": {
             "globalOn": true
         },
+        "pragmas-hover": {
+            "globalOn": true
+        },
         "pragmas-suggest": {
             "globalOn": true
         },

test/testdata/schema/ghc910/vscode-extension-schema.golden.json

@@ -273,6 +273,12 @@
         "scope": "resource",
         "type": "boolean"
     },
+    "haskell.plugin.pragmas-hover.globalOn": {
+        "default": true,
+        "description": "Enables pragmas-hover plugin",
+        "scope": "resource",
+        "type": "boolean"
+    },
     "haskell.plugin.pragmas-suggest.globalOn": {
         "default": true,
         "description": "Enables pragmas-suggest plugin",

test/testdata/schema/ghc912/default-config.golden.json

@@ -127,6 +127,9 @@
         "pragmas-disable": {
             "globalOn": true
         },
+        "pragmas-hover": {
+            "globalOn": true
+        },
         "pragmas-suggest": {
             "globalOn": true
         },

test/testdata/schema/ghc912/vscode-extension-schema.golden.json

@@ -291,6 +291,12 @@
         "scope": "resource",
         "type": "boolean"
     },
+    "haskell.plugin.pragmas-hover.globalOn": {
+        "default": true,
+        "description": "Enables pragmas-hover plugin",
+        "scope": "resource",
+        "type": "boolean"
+    },
     "haskell.plugin.pragmas-suggest.globalOn": {
         "default": true,
         "description": "Enables pragmas-suggest plugin",

test/testdata/schema/ghc914/default-config.golden.json

@@ -123,6 +123,9 @@
         "pragmas-disable": {
             "globalOn": true
         },
+        "pragmas-hover": {
+            "globalOn": true
+        },
         "pragmas-suggest": {
             "globalOn": true
         },

test/testdata/schema/ghc914/vscode-extension-schema.golden.json

@@ -279,6 +279,12 @@
         "scope": "resource",
         "type": "boolean"
     },
+    "haskell.plugin.pragmas-hover.globalOn": {
+        "default": true,
+        "description": "Enables pragmas-hover plugin",
+        "scope": "resource",
+        "type": "boolean"
+    },
     "haskell.plugin.pragmas-suggest.globalOn": {
         "default": true,
         "description": "Enables pragmas-suggest plugin",

test/testdata/schema/ghc96/default-config.golden.json

@@ -127,6 +127,9 @@
         "pragmas-disable": {
             "globalOn": true
         },
+        "pragmas-hover": {
+            "globalOn": true
+        },
         "pragmas-suggest": {
             "globalOn": true
         },

test/testdata/schema/ghc96/vscode-extension-schema.golden.json

@@ -291,6 +291,12 @@
         "scope": "resource",
         "type": "boolean"
     },
+    "haskell.plugin.pragmas-hover.globalOn": {
+        "default": true,
+        "description": "Enables pragmas-hover plugin",
+        "scope": "resource",
+        "type": "boolean"
+    },
     "haskell.plugin.pragmas-suggest.globalOn": {
         "default": true,
         "description": "Enables pragmas-suggest plugin",

test/testdata/schema/ghc98/default-config.golden.json

@@ -127,6 +127,9 @@
         "pragmas-disable": {
             "globalOn": true
         },
+        "pragmas-hover": {
+            "globalOn": true
+        },
         "pragmas-suggest": {
             "globalOn": true
         },

test/testdata/schema/ghc98/vscode-extension-schema.golden.json

@@ -291,6 +291,12 @@
         "scope": "resource",
         "type": "boolean"
     },
+    "haskell.plugin.pragmas-hover.globalOn": {
+        "default": true,
+        "description": "Enables pragmas-hover plugin",
+        "scope": "resource",
+        "type": "boolean"
+    },
     "haskell.plugin.pragmas-suggest.globalOn": {
         "default": true,
         "description": "Enables pragmas-suggest plugin",