Merge remote-tracking branch 'upstream/master' into alex/4057-2

haskell · Sep 10, 2024 · be2adaf · be2adaf
2 parents 972d993 + f628754
commit be2adaf
Show file tree

Hide file tree

Showing 12 changed files with 185 additions and 44 deletions.
diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/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

diff --git a/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs b/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs
@@ -65,7 +65,7 @@ provider recorder _ _ _ (FormatRange _) _ _ _ = do
   throwError $ PluginInvalidParams "You cannot format a text-range using cabal-fmt."
 provider recorder plId ideState _ FormatText contents nfp opts = do
   let cabalFmtArgs = [ "--indent", show tabularSize]
-  cabalFmtExePath <- fmap T.unpack $ liftIO $ runAction "cabal-gild" ideState $ usePropertyAction #path plId properties
+  cabalFmtExePath <- fmap T.unpack $ liftIO $ runAction "cabal-fmt" ideState $ usePropertyAction #path plId properties
   x <- liftIO $ findExecutable cabalFmtExePath
   case x of
     Just _ -> do
@@ -86,7 +86,7 @@ provider recorder plId ideState _ FormatText contents nfp opts = do
           pure $ InL fmtDiff
     Nothing -> do
       log Error $ LogFormatterBinNotFound cabalFmtExePath
-      throwError (PluginInternalError "No installation of cabal-gild could be found. Please install it globally, or provide the full path to the executable")
+      throwError (PluginInternalError "No installation of cabal-fmt could be found. Please install it globally, or provide the full path to the executable")
   where
     fp = fromNormalizedFilePath nfp
     tabularSize = opts ^. L.tabSize

diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs
@@ -8,50 +8,64 @@ module Ide.Plugin.Cabal (descriptor, haskellInteractionDescriptor, Log (..)) whe
 
 import           Control.Concurrent.Strict
 import           Control.DeepSeq
-import           Control.Lens                                ((^.))
+import           Control.Lens                                  ((^.))
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
-import           Control.Monad.Trans.Maybe                   (runMaybeT)
-import qualified Data.ByteString                             as BS
+import           Control.Monad.Trans.Class                     (lift)
+import           Control.Monad.Trans.Maybe                     (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.Maybe                                  as Maybe
-import qualified Data.Text                                   as T
-import qualified Data.Text.Encoding                          as Encoding
-import qualified Data.Text.Utf16.Rope.Mixed                  as Rope
+import           Data.HashMap.Strict                           (HashMap)
+import qualified Data.HashMap.Strict                           as HashMap
+import qualified Data.List.NonEmpty                            as NE
+import qualified Data.Maybe                                    as Maybe
+import qualified Data.Text                                     as T
+import qualified Data.Text.Encoding                            as Encoding
+import           Data.Text.Utf16.Rope.Mixed                    as Rope
 import           Data.Typeable
-import           Development.IDE                             as D
-import           Development.IDE.Core.Shake                  (restartShakeSession)
-import qualified Development.IDE.Core.Shake                  as Shake
-import           Development.IDE.Graph                       (Key, alwaysRerun)
-import qualified Development.IDE.Plugin.Completions.Logic    as Ghcide
-import           Development.IDE.Types.Shake                 (toKey)
-import qualified Distribution.Fields                         as Syntax
-import qualified Distribution.Parsec.Position                as Syntax
+import           Development.IDE                               as D
+import           Development.IDE.Core.FileStore                (getVersionedTextDoc)
+import           Development.IDE.Core.PluginUtils
+import           Development.IDE.Core.Shake                    (restartShakeSession)
+import qualified Development.IDE.Core.Shake                    as Shake
+import           Development.IDE.Graph                         (Key,
+                                                                alwaysRerun)
+import           Development.IDE.LSP.HoverDefinition           (foundHover)
+import qualified Development.IDE.Plugin.Completions.Logic      as Ghcide
+import           Development.IDE.Types.Shake                   (toKey)
+import qualified Distribution.Fields                           as Syntax
+import           Distribution.Package                          (Dependency)
+import           Distribution.PackageDescription               (allBuildDepends,
+                                                                depPkgName,
+                                                                unPackageName)
+import           Distribution.PackageDescription.Configuration (flattenPackageDescription)
+import qualified Distribution.Parsec.Position                  as Syntax
 import           GHC.Generics
-import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes
-import qualified Ide.Plugin.Cabal.Completion.Completions     as Completions
-import           Ide.Plugin.Cabal.Completion.Types           (ParseCabalCommonSections (ParseCabalCommonSections),
-                                                              ParseCabalFields (..),
-                                                              ParseCabalFile (..))
-import qualified Ide.Plugin.Cabal.Completion.Types           as Types
-import           Ide.Plugin.Cabal.Definition                 (gotoDefinition)
-import qualified Ide.Plugin.Cabal.Diagnostics                as Diagnostics
-import qualified Ide.Plugin.Cabal.FieldSuggest               as FieldSuggest
-import qualified Ide.Plugin.Cabal.LicenseSuggest             as LicenseSuggest
-import           Ide.Plugin.Cabal.Orphans                    ()
+import           Ide.Plugin.Cabal.Completion.CabalFields       as CabalFields
+import qualified Ide.Plugin.Cabal.Completion.Completer.Types   as CompleterTypes
+import qualified Ide.Plugin.Cabal.Completion.Completions       as Completions
+import           Ide.Plugin.Cabal.Completion.Types             (ParseCabalCommonSections (ParseCabalCommonSections),
+                                                                ParseCabalFields (..),
+                                                                ParseCabalFile (..))
+import qualified Ide.Plugin.Cabal.Completion.Types             as Types
+import           Ide.Plugin.Cabal.Definition                   (gotoDefinition)
+import qualified Ide.Plugin.Cabal.Diagnostics                  as Diagnostics
+import qualified Ide.Plugin.Cabal.FieldSuggest                 as FieldSuggest
+import qualified Ide.Plugin.Cabal.LicenseSuggest               as LicenseSuggest
+import           Ide.Plugin.Cabal.Orphans                      ()
 import           Ide.Plugin.Cabal.Outline
-import qualified Ide.Plugin.Cabal.Parse                      as Parse
+import qualified Ide.Plugin.Cabal.Parse                        as Parse
+import           Ide.Plugin.Error
 import           Ide.Types
-import qualified Language.LSP.Protocol.Lens                  as JL
-import qualified Language.LSP.Protocol.Message               as LSP
+import qualified Language.LSP.Protocol.Lens                    as JL
+import qualified Language.LSP.Protocol.Message                 as LSP
 import           Language.LSP.Protocol.Types
-import qualified Language.LSP.VFS                            as VFS
+import qualified Language.LSP.VFS                              as VFS
+import           Text.Regex.TDFA
 
-import qualified Data.Text                                   ()
-import qualified Ide.Plugin.Cabal.CabalAdd                   as CabalAdd
+
+import qualified Data.Text                                     ()
+import qualified Ide.Plugin.Cabal.CabalAdd                     as CabalAdd
 
 data Log
   = LogModificationTime NormalizedFilePath FileVersion
@@ -118,6 +132,7 @@ descriptor recorder plId =
           , mkPluginHandler LSP.SMethod_TextDocumentDocumentSymbol moduleOutline
           , mkPluginHandler LSP.SMethod_TextDocumentCodeAction $ fieldSuggestCodeAction recorder
           , mkPluginHandler LSP.SMethod_TextDocumentDefinition gotoDefinition
+          , mkPluginHandler LSP.SMethod_TextDocumentHover hover
           ]
     , pluginNotificationHandlers =
         mconcat
@@ -302,7 +317,6 @@ fieldSuggestCodeAction recorder ide _ (CodeActionParams _ _ (TextDocumentIdentif
       let completionTexts = fmap (^. JL.label) completions
       pure $ FieldSuggest.fieldErrorAction uri fieldName completionTexts _range
 
-
 cabalAddCodeAction :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
 cabalAddCodeAction state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics=diags}) = do
   maxCompls <- fmap maxCompletions . liftIO $ runAction "cabal.cabal-add" state getClientConfigAction
@@ -317,7 +331,8 @@ cabalAddCodeAction state plId (CodeActionParams _ _ (TextDocumentIdentifier uri)
           case mbCabalFile of
             Nothing -> pure $ InL []
             Just cabalFilePath -> do
-              verTxtDocId <- lift $ pluginGetVersionedTextDoc $ TextDocumentIdentifier (filePathToUri cabalFilePath)
+              verTxtDocId <- runActionE "cabalAdd.getVersionedTextDoc" state $
+                lift $ getVersionedTextDoc $ TextDocumentIdentifier (filePathToUri cabalFilePath)
               mbGPD <- liftIO $ runAction "cabal.cabal-add" state $ useWithStale ParseCabalFile $ toNormalizedFilePath cabalFilePath
               case mbGPD of
                 Nothing -> pure $ InL []
@@ -328,6 +343,55 @@ cabalAddCodeAction state plId (CodeActionParams _ _ (TextDocumentIdentifier uri)
                                                                               gpd
                   pure $ InL $ fmap InR actions
 
+-- | Handler for hover messages.
+--
+-- Provides a Handler 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 $ 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
+  where
+    cursor = Types.lspPositionToCabalPosition (msgParam ^. JL.position)
+    uri = msgParam ^. JL.textDocument . JL.uri
+
+    dependencyName :: Dependency -> T.Text
+    dependencyName dep = T.pack $ unPackageName $ depPkgName dep
+
+    -- | Removes version requirements like
+    -- `==1.0.0.0`, `>= 2.1.1` that could be included in
+    -- hover message. Assumes that the dependency consists
+    -- of alphanums with dashes in between. Ends with an alphanum.
+    --
+    -- Examples:
+    -- >>> filterVersion "imp-deps>=2.1.1"
+    -- "imp-deps"
+    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 (_, _, _, [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

diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd.hs
@@ -31,10 +31,11 @@ import           Data.String                                   (IsString)
 import qualified Data.Text                                     as T
 import           Data.Text.Encoding                            (encodeUtf8)
 import qualified Data.Text.Encoding                            as T
+import           Data.Text.Utf16.Rope.Mixed                    as Rope
 import           Development.IDE                               (IdeState,
+                                                                getFileContents,
                                                                 useWithStale)
 import           Development.IDE.Core.Rules                    (runAction)
-import           Development.IDE.Core.RuleTypes                (GetFileContents (..))
 import           Distribution.Client.Add                       as Add
 import           Distribution.Compat.Prelude                   (Generic)
 import           Distribution.PackageDescription               (GenericPackageDescription,
@@ -235,12 +236,12 @@ getDependencyEdit :: MonadIO m => Recorder (WithPriority Log) -> (IdeState, Clie
 getDependencyEdit recorder env cabalFilePath buildTarget dependency = do
   let (state, caps, verTxtDocId) = env
   (mbCnfOrigContents, mbFields, mbPackDescr) <- liftIO $ runAction "cabal.cabal-add" state $ do
-        contents <- useWithStale GetFileContents $ toNormalizedFilePath cabalFilePath
+        contents <- getFileContents $ toNormalizedFilePath cabalFilePath
         inFields <- useWithStale ParseCabalFields $ toNormalizedFilePath cabalFilePath
         inPackDescr <- useWithStale ParseCabalFile $ toNormalizedFilePath cabalFilePath
-        let mbCnfOrigContents = case snd . fst <$> contents of
-                    Just (Just txt) -> Just $ encodeUtf8 txt
-                    _               -> Nothing
+        let mbCnfOrigContents = case contents of
+                    (Just txt) -> Just $ encodeUtf8 $ Rope.toText txt
+                    _          -> Nothing
         let mbFields = fst <$> inFields
         let mbPackDescr = fst <$> inPackDescr
         pure (mbCnfOrigContents, mbFields, mbPackDescr)

diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs
@@ -38,6 +38,7 @@ main = do
             , outlineTests
             , codeActionTests
             , gotoDefinitionTests
+            , hoverTests
             ]
 
 -- ------------------------------------------------------------------------
@@ -230,3 +231,46 @@ codeActionTests = testGroup "Code Actions"
         InR action@CodeAction{_title} <- codeActions
         guard (_title == "Replace with " <> license)
         pure action
+
+-- ----------------------------------------------------------------------------
+-- 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)"
+
+    , hoverIsNullTest "name has no documentation" "hover-deps.cabal" (Position 1 25)
+    , hoverIsNullTest "exposed-modules has no documentation" "hover-deps.cabal" (Position 5 25)
+    , hoverIsNullTest "hs-source-dirs has no documentation" "hover-deps.cabal" (Position 8 25)
+    ]
+    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
+
+        hoverIsNullTest :: TestName -> FilePath -> Position -> TestTree
+        hoverIsNullTest testName cabalFile pos =
+            runCabalTestCaseSession testName "hover" $ do
+                doc <- openDoc cabalFile "cabal"
+                h <- getHover doc pos
+                liftIO $ assertBool ("Found hover `" <> show h <> "`") $ Maybe.isNothing h
+                closeDoc doc
diff --git a/plugins/hls-cabal-plugin/test/testdata/hover/hover-deps.cabal b/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
diff --git a/test/testdata/schema/ghc94/default-config.golden.json b/test/testdata/schema/ghc94/default-config.golden.json
@@ -12,6 +12,7 @@
             "codeActionsOn": true,
             "completionOn": true,
             "diagnosticsOn": true,
+            "hoverOn": true,
             "symbolsOn": true
         },
         "cabal-fmt": {

diff --git a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json
@@ -35,6 +35,12 @@
         "scope": "resource",
         "type": "boolean"
     },
+    "haskell.plugin.cabal.hoverOn": {
+        "default": true,
+        "description": "Enables cabal hover",
+        "scope": "resource",
+        "type": "boolean"
+    },
     "haskell.plugin.cabal.symbolsOn": {
         "default": true,
         "description": "Enables cabal symbols",

diff --git a/test/testdata/schema/ghc96/default-config.golden.json b/test/testdata/schema/ghc96/default-config.golden.json
@@ -12,6 +12,7 @@
             "codeActionsOn": true,
             "completionOn": true,
             "diagnosticsOn": true,
+            "hoverOn": true,
             "symbolsOn": true
         },
         "cabal-fmt": {

diff --git a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json
@@ -35,6 +35,12 @@
         "scope": "resource",
         "type": "boolean"
     },
+    "haskell.plugin.cabal.hoverOn": {
+        "default": true,
+        "description": "Enables cabal hover",
+        "scope": "resource",
+        "type": "boolean"
+    },
     "haskell.plugin.cabal.symbolsOn": {
         "default": true,
         "description": "Enables cabal symbols",

diff --git a/test/testdata/schema/ghc98/default-config.golden.json b/test/testdata/schema/ghc98/default-config.golden.json
@@ -12,6 +12,7 @@
             "codeActionsOn": true,
             "completionOn": true,
             "diagnosticsOn": true,
+            "hoverOn": true,
             "symbolsOn": true
         },
         "cabal-fmt": {

diff --git a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json
@@ -35,6 +35,12 @@
         "scope": "resource",
         "type": "boolean"
     },
+    "haskell.plugin.cabal.hoverOn": {
+        "default": true,
+        "description": "Enables cabal hover",
+        "scope": "resource",
+        "type": "boolean"
+    },
     "haskell.plugin.cabal.symbolsOn": {
         "default": true,
         "description": "Enables cabal symbols",