Show package descriptions in Cabal plugin

docs/contributing/contributing.md

@@ -81,6 +81,14 @@ Running just the wrapper tests
 $ cabal test wrapper-test
 ```
 
+Running just the tests for a specific plugin
+
+```bash
+$ cabal test hls-<plugin-name>-plugin-tests
+# E.g.
+$ cabal test hls-refactor-plugin-tests
+```
+
 Running a subset of tests
 
 Tasty supports providing
@@ -92,11 +100,10 @@ $ cabal test func-test --test-option "-p hlint"
 ```
 
 The above recompiles everything every time you use a different test option though.
-
-An alternative, which only recompiles when tests (or dependencies) change:
+An alternative, which only recompiles when tests (or dependencies) change is to pass the `TASTY_PATTERN` environment variable:
 
 ```bash
-$ cabal run haskell-language-server:func-test -- -p "hlint enables"
+$ TASTY_PATTERN='hlint' cabal test func-test
 ```
 
 ## Using HLS on HLS code

haskell-language-server.cabal

@@ -237,6 +237,7 @@ library hls-cabal-plugin
     buildable: False
   exposed-modules:
     Ide.Plugin.Cabal
+    Ide.Plugin.Cabal.CabalInfoParser
     Ide.Plugin.Cabal.Diagnostics
     Ide.Plugin.Cabal.Completion.CabalFields
     Ide.Plugin.Cabal.Completion.Completer.FilePath
@@ -273,6 +274,7 @@ library hls-cabal-plugin
     , lens
     , lsp                   ^>=2.7
     , lsp-types             ^>=2.3
+    , megaparsec
     , regex-tdfa            ^>=1.3.1
     , text
     , text-rope
@@ -296,6 +298,7 @@ test-suite hls-cabal-plugin-tests
   main-is:          Main.hs
   other-modules:
     CabalAdd
+    CabalInfoParser
     Completer
     Context
     Definition
@@ -305,6 +308,7 @@ test-suite hls-cabal-plugin-tests
     , base
     , bytestring
     , Cabal-syntax          >= 3.7
+    , containers
     , extra
     , filepath
     , ghcide

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

@@ -12,12 +12,15 @@
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class                     (lift)
-import           Control.Monad.Trans.Maybe                     (runMaybeT)
+import           Control.Monad.Trans.Maybe                     (MaybeT (..),
+                                                                hoistMaybe,
+                                                                runMaybeT)
 import qualified Data.ByteString                               as BS
 import           Data.Hashable
 import           Data.HashMap.Strict                           (HashMap)
 import qualified Data.HashMap.Strict                           as HashMap
 import qualified Data.List.NonEmpty                            as NE
+import qualified Data.Map.Strict                               as Map
 import qualified Data.Maybe                                    as Maybe
 import qualified Data.Text                                     as T
 import qualified Data.Text.Encoding                            as Encoding
@@ -64,8 +67,13 @@
 import           Text.Regex.TDFA
 
 
+import           Data.Either.Extra                             (eitherToMaybe)
 import qualified Data.Text                                     ()
+import           Development.IDE.Spans.Common                  (spanDocToMarkdownForTest)
 import qualified Ide.Plugin.Cabal.CabalAdd                     as CabalAdd
+import           Ide.Plugin.Cabal.CabalInfoParser              (parseCabalInfo)
+import           System.Exit                                   (ExitCode (ExitSuccess))
+import           System.Process                                (readProcessWithExitCode)
 
 data Log
   = LogModificationTime NormalizedFilePath FileVersion
@@ -349,22 +357,37 @@
 -- 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 $ useE ParseCabalFields nfp
-  case CabalFields.findTextWord cursor cabalFields of
-    Nothing ->
-      pure $ InR Null
-    Just cursorText -> do
-      gpd <- runActionE "cabal.GPD" ide $ useE ParseCabalFile nfp
-      let depsNames = map dependencyName $ allBuildDepends $ flattenPackageDescription gpd
-      case filterVersion cursorText of
-        Nothing -> pure $ InR Null
-        Just txt ->
-          if txt `elem` depsNames
-          then pure $ foundHover (Nothing, [txt <> "\n", documentationText txt])
-          else pure $ InR Null
+hover ide _ msgParam = getHoverMessage >>= showHoverMessage
   where
+    -- Return the tooltip content for a hovered name...
+    getHoverMessage = runMaybeT $ do
+      nfp <- lift $ getNormalizedFilePathE uri
+      cabalFields <- lift $ runActionE "cabal.cabal-hover" ide $ useE ParseCabalFields nfp
+      -- ... at the cursor position...
+      cursorText <- hoistMaybe $ CabalFields.findTextWord cursor cabalFields
+      -- ... without any version information...
+      packageName <- hoistMaybe $ filterVersion cursorText
+      -- ... and only if it's a listed depdendency.
+      gpd <- lift $ runActionE "cabal.GPD" ide $ useE ParseCabalFile nfp
+      let depsNames = map dependencyName $ allBuildDepends $ flattenPackageDescription gpd
+      guard $ packageName `elem` depsNames
+
+      rawCabalInfo <- MaybeT $ liftIO $ execCabalInfo packageName
+
+      let cabalInfo = eitherToMaybe $ parseCabalInfo rawCabalInfo
+      liftIO $ print cabalInfo
+
+      case getDescription rawCabalInfo packageName of
+        Nothing ->
+          pure [packageName <> "\n", "Description not available\n", documentationText packageName]
+        Just description -> do
+          let descriptionMarkdown = T.pack $ spanDocToMarkdownForTest $ T.unpack description
+          pure [packageName <> "\n", descriptionMarkdown <> "\n", documentationText packageName]
+
+    showHoverMessage = \case
+      Nothing -> pure $ InR Null
+      Just message -> pure $ foundHover (Nothing, message)
+
     cursor = Types.lspPositionToCabalPosition (msgParam ^. JL.position)
     uri = msgParam ^. JL.textDocument . JL.uri
 
@@ -389,9 +412,23 @@
         getMatch (_, _, _, [dependency]) = Just dependency
         getMatch (_, _, _, _)            = Nothing -- impossible case
 
+    execCabalInfo :: T.Text -> IO (Maybe T.Text)
+    execCabalInfo package = do
+      (exitCode, stdout, _stderr) <- readProcessWithExitCode "cabal" ["info", T.unpack package] ""
+      if exitCode == System.Exit.ExitSuccess then
+        pure $ Just $ T.pack stdout
+      else
+        pure Nothing
+
     documentationText :: T.Text -> T.Text
     documentationText package = "[Documentation](https://hackage.haskell.org/package/" <> package <> ")"
 
+    getDescription :: T.Text -> T.Text -> Maybe T.Text
+    getDescription rawCabalInfo packageName = do
+      cabalInfo <- eitherToMaybe $ parseCabalInfo rawCabalInfo
+      pkInfo <- cabalInfo Map.!? packageName
+      T.unlines <$> pkInfo Map.!? "Description"
+
 
 -- ----------------------------------------------------------------
 -- Cabal file of Interest rules and global variable

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

@@ -0,0 +1,95 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | This module allows you to parse the output of @cabal info@.
+-- This is basically a placeholder implementation until cabal info provides
+-- machine readable output or Cabal provides an API for this.
+module Ide.Plugin.Cabal.CabalInfoParser (parseCabalInfo, cabalInfo) where
+
+import           Data.Map.Strict   (Map)
+import           Data.Text         (Text)
+import           Data.Void         (Void)
+import           Text.Megaparsec   (MonadParsec (..), Parsec, chunk, failure,
+                                    many, parse, single, (<|>))
+
+import           Control.Monad     (void, when)
+import           Data.Either.Extra (mapLeft)
+import qualified Data.Map.Strict   as Map
+import qualified Data.Text         as T
+
+type Parser = Parsec Void Text
+
+parseCabalInfo :: Text -> Either CabalInfoParserError (Map Text (Map Text [Text]))
+parseCabalInfo = mapLeft (T.pack . show) . parse cabalInfo ""
+
+type CabalInfoParserError = Text
+
+cabalInfo :: Parser (Map Text (Map Text [Text]))
+cabalInfo = do
+    entries <- many $ try cabalInfoEntry
+    eof
+
+    pure $ Map.fromList entries
+
+cabalInfoEntry :: Parser (Text, Map Text [Text])
+cabalInfoEntry = do
+    void $ single '*'
+    void spaces
+
+    name <- takeWhileP (Just "package name") (/= ' ')
+
+    void restOfLine
+
+    pairs <- many $ try field
+
+    void $ takeWhileP (Just "trailing whitespace") (`elem` (" \t\r\n" :: String))
+
+    pure (name, Map.fromList pairs)
+
+field :: Parser (Text, [Text])
+field = do
+    spacesBeforeKey <- spaces
+    -- We assume that all fields are indented ==> fail if that ain't so.
+    when (T.null spacesBeforeKey) $ failure Nothing mempty
+
+    key <- takeWhileP (Just "field name") (/= ':')
+    void $ single ':'
+    spacesAfterKey <- spaces
+    firstLine <- restOfLine
+
+    -- The first line of the field may be empty.
+    -- In this case, we have to look at the second line to determine
+    -- the indentation depth.
+    if T.null firstLine then do
+        spacesBeforeFirstLine <- spaces
+        firstLine' <- restOfLine
+        let indent = T.length spacesBeforeFirstLine
+        lines <- trailingIndentedLines indent
+        pure (key, firstLine' : lines)
+    -- If the first line is *not* empty, we can determine the indentation
+    -- depth by calculating how many characters came before it.
+    else do
+        let indent = T.length spacesBeforeKey + T.length key + 1 + T.length spacesAfterKey
+        lines <- trailingIndentedLines indent
+        pure (key, firstLine : lines)
+
+    where
+        trailingIndentedLines :: Int -> Parser [Text]
+        trailingIndentedLines indent = many $ try $ indentedLine indent
+
+indentedLine :: Int -> Parser Text
+indentedLine indent = do
+    void $ chunk $ T.replicate indent " "
+    restOfLine
+
+spaces :: Parser Text
+spaces = takeWhileP Nothing (== ' ')
+
+-- | Parse until next @\n@, return text before that.
+restOfLine :: Parser Text
+restOfLine = do
+    s <- takeWhileP (Just "rest of line") (/= '\n')
+    eolOrEof
+    pure s
+
+eolOrEof :: Parser ()
+eolOrEof = void (single '\n') <|> eof

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

@@ -0,0 +1,39 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module CabalInfoParser (cabalInfoParserUnitTests) where
+
+import           System.FilePath                  ((</>))
+import           Test.Hls                         (Assertion, TestTree,
+                                                   assertFailure, testCase,
+                                                   testGroup, (@=?), (@?))
+import           Utils                            (testDataDir)
+
+import qualified Data.Text.IO                     as TIO
+
+import           Data.Either                      (isRight)
+import           Ide.Plugin.Cabal.CabalInfoParser (parseCabalInfo)
+
+import           Data.Map.Strict                  (Map)
+import qualified Data.Map.Strict                  as Map
+import           Data.Text                        (Text)
+
+cabalInfoParserUnitTests :: TestTree
+cabalInfoParserUnitTests = testGroup "cabal info Parser Tests"
+    [ simpleParsingWorks
+    , simpleMultiEntryParsingWorks
+    ]
+    where
+        simpleParsingWorks =
+            testCase "Simple parsing works" $ testParserWithFile "text.cabal-info" $ \ci -> do
+                Map.keys ci @=? ["text"]
+
+        simpleMultiEntryParsingWorks =
+            testCase "Simple parsing works for multiple packages" $ testParserWithFile "containers-base.cabal-info" $ \ci -> do
+                Map.keys ci @=? ["base", "containers"]
+
+testParserWithFile :: FilePath -> (Map Text (Map Text [Text]) -> Assertion) -> Assertion
+testParserWithFile file f = do
+    res <- parseCabalInfo <$> TIO.readFile (testDataDir </> "cabal-info" </> file)
+    case res of
+        Left _   -> assertFailure "Failed to parse well-formed input"
+        Right ci -> f ci

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

@@ -7,6 +7,7 @@ module Main (
 ) where
 
 import           CabalAdd                        (cabalAddTests)
+import           CabalInfoParser                 (cabalInfoParserUnitTests)
 import           Completer                       (completerTests)
 import           Context                         (contextTests)
 import           Control.Lens                    ((^.))
@@ -51,6 +52,7 @@ unitTests =
         "Unit Tests"
         [ cabalParserUnitTests
         , codeActionUnitTests
+        , cabalInfoParserUnitTests
         ]
 
 cabalParserUnitTests :: TestTree