diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index e4c20504e4..3211d98b5c 100644 --- 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-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 8973f4401d..fdde678845 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -8,50 +8,62 @@ 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.Class -import Control.Monad.Trans.Maybe (runMaybeT) -import qualified Data.ByteString as BS +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 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.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.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 +130,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 +315,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 @@ -328,6 +340,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/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs index 98017fa9c1..499d4aa569 100644 --- 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 new file mode 100644 index 0000000000..ddc4a6107a --- /dev/null +++ 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 index 3419159603..751aa6f28e 100644 --- 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 index 17693c70a8..938964fc50 100644 --- 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 index 3419159603..751aa6f28e 100644 --- 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 index 17693c70a8..938964fc50 100644 --- 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 index 3419159603..751aa6f28e 100644 --- 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 index 17693c70a8..938964fc50 100644 --- 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",