Documentation for build-depends on hover

ghcide/src/Development/IDE/LSP/HoverDefinition.hs

@@ -7,6 +7,7 @@ module Development.IDE.LSP.HoverDefinition
     ( Log(..)
     -- * For haskell-language-server
     , hover
+    , foundHover
     , gotoDefinition
     , gotoTypeDefinition
     , documentHighlight

plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs

@@ -52,6 +52,13 @@
 import qualified Language.LSP.Protocol.Message               as LSP
 import           Language.LSP.Protocol.Types
 import qualified Language.LSP.VFS                            as VFS
+import Distribution.PackageDescription.Configuration (flattenPackageDescription)
+import Distribution.Package (Dependency())
+import Distribution.PackageDescription (depPkgName, unPackageName, allBuildDepends)
+import Development.IDE.LSP.HoverDefinition (foundHover)
+import           Text.Regex.TDFA
+import Debug.Trace
+
 
 data Log
   = LogModificationTime NormalizedFilePath FileVersion
@@ -98,6 +105,7 @@
           , mkPluginHandler LSP.SMethod_TextDocumentDocumentSymbol moduleOutline
           , mkPluginHandler LSP.SMethod_TextDocumentCodeAction $ fieldSuggestCodeAction recorder
           , mkPluginHandler LSP.SMethod_TextDocumentDefinition gotoDefinition
+          , mkPluginHandler LSP.SMethod_TextDocumentHover hover
           ]
     , pluginNotificationHandlers =
         mconcat
@@ -309,6 +317,50 @@
       isSectionArgName name (Syntax.Section _ sectionArgName _) = name == CabalFields.onelineSectionArgs sectionArgName
       isSectionArgName _ _ = False
 
+-- | CodeActions for hover messages.
+--
+-- Provides a CodeAction for displaying message on hover.
+-- If found that the filtered hover message is a dependency,
+-- adds a Documentation link.
+hover :: PluginMethodHandler IdeState LSP.Method_TextDocumentHover
+hover ide _ msgParam = do
+      nfp <- getNormalizedFilePathE uri
+      (cabalFields, _) <- runActionE "cabal.cabal-hover" ide $ useWithStaleE ParseCabalFields nfp
+      let mCursorText = CabalFields.findTextWord cursor cabalFields
+      case mCursorText of
+        Nothing ->
+          pure $ InR Null
+        Just cursorText -> do
+          (gpd, _) <- runActionE "cabal.GPD" ide $ useWithStaleE ParseCabalFile nfp
+          let depsNames = map dependencyName $ allBuildDepends $ flattenPackageDescription gpd
+              mText = filterVersion cursorText
+          case mText of
+            Nothing -> pure $ foundHover (Nothing, [cursorText])
+            Just txt ->
+              if txt `elem` depsNames
+                then pure $ foundHover (Nothing, [txt <> "\n", documentationText txt])
+                else pure $ foundHover (Nothing, [txt])
+  where
+      cursor = Types.lspPositionToCabalPosition (msgParam ^. JL.position)
+      uri = msgParam ^. JL.textDocument . JL.uri
+
+      dependencyName :: Dependency -> T.Text
+      dependencyName dep = T.pack $ unPackageName $ depPkgName dep
+
+      filterVersion :: T.Text -> Maybe T.Text
+      filterVersion msg = getMatch (msg =~ regex)
+        where
+          regex :: T.Text
+          regex = "([a-zA-Z0-9-]*[a-zA-Z0-9]).*"
+
+          getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> Maybe T.Text
+          getMatch (_, _, _, []) = Nothing
+          getMatch (_, _, _, [dependency]) = Just dependency
+          getMatch (_, _, _, _) = Nothing -- impossible case
+
+      documentationText :: T.Text -> T.Text
+      documentationText package = "[Documentation](https://hackage.haskell.org/package/" <> package <> ")"
+
 -- ----------------------------------------------------------------
 -- Cabal file of Interest rules and global variable
 -- ----------------------------------------------------------------

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

@@ -38,6 +38,7 @@ main = do
             , outlineTests
             , codeActionTests
             , gotoDefinitionTests
+            , hoverTests
             ]
 
 -- ------------------------------------------------------------------------
@@ -282,3 +283,53 @@ gotoDefinitionTests = testGroup "Goto Definition"
                 doc <- openDoc "simple-with-common.cabal" "cabal"
                 empty <- getDefinitions doc cursorPos
                 liftIO $ empty @?= (InR $ InR LSP.Null)
+
+-- ----------------------------------------------------------------------------
+-- Hover Tests
+-- ----------------------------------------------------------------------------
+
+hoverTests :: TestTree
+hoverTests = testGroup "Hover"
+    [ hoverOnDependencyTests
+    ]
+
+hoverOnDependencyTests :: TestTree
+hoverOnDependencyTests = testGroup "Hover Dependency"
+    [ hoverContainsTest "base with separated version" "hover-deps.cabal" (Position 6 25) "[Documentation](https://hackage.haskell.org/package/base)"
+    , hoverContainsTest "aeson with not separated version " "hover-deps.cabal" (Position 7 25) "[Documentation](https://hackage.haskell.org/package/aeson)"
+    , hoverContainsTest "lens no version" "hover-deps.cabal" (Position 7 42) "[Documentation](https://hackage.haskell.org/package/lens)"
+
+    , hoverNotContainsTest "name has no documentation" "hover-deps.cabal" (Position 1 25) "[Documentation]"
+    , hoverNotContainsTest "exposed-modules has no documentation" "hover-deps.cabal" (Position 5 25) "[Documentation]"
+    , hoverNotContainsTest "hs-source-dirs has no documentation" "hover-deps.cabal" (Position 8 25) "[Documentation]"
+    ]
+    where
+        hoverContainsTest :: TestName -> FilePath -> Position -> T.Text -> TestTree
+        hoverContainsTest testName cabalFile pos containedText =
+            runCabalTestCaseSession testName "hover" $ do
+                doc <- openDoc cabalFile "cabal"
+                h <- getHover doc pos
+                case h of
+                    Nothing -> liftIO $ assertFailure "No hover"
+                    Just (Hover contents _) -> case contents of
+                        InL (MarkupContent _ txt) -> do
+                            liftIO
+                            $ assertBool ("Failed to find `" <> T.unpack containedText <> "` in hover message: " <> T.unpack txt)
+                            $ containedText `T.isInfixOf` txt
+                        _ -> liftIO $ assertFailure "Unexpected content type"
+                closeDoc doc
+
+        hoverNotContainsTest :: TestName -> FilePath -> Position -> T.Text -> TestTree
+        hoverNotContainsTest testName cabalFile pos containedText =
+            runCabalTestCaseSession testName "hover" $ do
+                doc <- openDoc cabalFile "cabal"
+                h <- getHover doc pos
+                case h of
+                    Nothing -> liftIO $ assertFailure "No hover"
+                    Just (Hover contents _) -> case contents of
+                        InL (MarkupContent _ txt) -> do
+                            liftIO
+                            $ assertBool ("Found `" <> T.unpack containedText <> "` in hover message: " <> T.unpack txt)
+                            $ not (containedText `T.isInfixOf` txt)
+                        _ -> liftIO $ assertFailure "Unexpected content type"
+                closeDoc doc

plugins/hls-cabal-plugin/test/testdata/hover/hover-deps.cabal

@@ -0,0 +1,10 @@
+cabal-version:      3.0
+name:               hover-deps
+version:            0.1.0.0
+
+library
+    exposed-modules:  Module
+    build-depends:    base ^>=4.14.3.0
+                    , aeson==1.0.0.0 , lens
+    hs-source-dirs:   src
+    default-language: Haskell2010