diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 096cf04a31..6a470f5ba4 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -242,6 +242,7 @@ library hls-cabal-plugin exposed-modules: Ide.Plugin.Cabal Ide.Plugin.Cabal.Diagnostics + Ide.Plugin.Cabal.Dependencies Ide.Plugin.Cabal.Completion.CabalFields Ide.Plugin.Cabal.Completion.Completer.FilePath Ide.Plugin.Cabal.Completion.Completer.Module @@ -267,6 +268,7 @@ library hls-cabal-plugin build-depends: + , array , bytestring , Cabal-syntax >= 3.7 , containers diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 7a2c53ee25..ebb1922c91 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -4,58 +4,53 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.Cabal (descriptor, haskellInteractionDescriptor, Log (..)) where -import Control.Lens ((^.)) +import Control.Lens (_Just, (^.), (^?)) import Control.Monad.Extra import Control.Monad.IO.Class -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Maybe (runMaybeT) -import Data.HashMap.Strict (HashMap) -import qualified Data.List as List -import qualified Data.Maybe as Maybe -import qualified Data.Text () -import qualified Data.Text as T -import Development.IDE as D -import Development.IDE.Core.FileStore (getVersionedTextDoc) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe (runMaybeT) +import Data.HashMap.Strict (HashMap) +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import qualified Data.Text () +import qualified Data.Text as T +import Development.IDE as D +import Development.IDE.Core.FileStore (getVersionedTextDoc) import Development.IDE.Core.PluginUtils -import Development.IDE.Core.Shake (restartShakeSession) -import Development.IDE.Graph (Key) -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 qualified Ide.Plugin.Cabal.CabalAdd.CodeAction as CabalAdd -import qualified Ide.Plugin.Cabal.CabalAdd.Command as CabalAdd -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.FieldSuggest as FieldSuggest -import qualified Ide.Plugin.Cabal.Files as CabalAdd -import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest -import qualified Ide.Plugin.Cabal.OfInterest as OfInterest -import Ide.Plugin.Cabal.Orphans () +import Development.IDE.Core.Shake (restartShakeSession) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Graph (Key) +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 qualified Ide.Plugin.Cabal.CabalAdd.CodeAction as CabalAdd +import qualified Ide.Plugin.Cabal.CabalAdd.Command as CabalAdd +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.Dependencies as Dependencies +import qualified Ide.Plugin.Cabal.FieldSuggest as FieldSuggest +import qualified Ide.Plugin.Cabal.Files as CabalAdd +import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest +import qualified Ide.Plugin.Cabal.OfInterest as OfInterest +import Ide.Plugin.Cabal.Orphans () import Ide.Plugin.Cabal.Outline -import qualified Ide.Plugin.Cabal.Rules as Rules +import qualified Ide.Plugin.Cabal.Rules as Rules 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 Text.Regex.TDFA +import qualified Language.LSP.VFS as VFS data Log = LogModificationTime NormalizedFilePath FileVersion @@ -127,6 +122,8 @@ descriptor recorder plId = , mkPluginHandler LSP.SMethod_TextDocumentCodeAction $ fieldSuggestCodeAction recorder , mkPluginHandler LSP.SMethod_TextDocumentDefinition gotoDefinition , mkPluginHandler LSP.SMethod_TextDocumentHover hover + , mkPluginHandler LSP.SMethod_TextDocumentInlayHint hints + , mkPluginHandler LSP.SMethod_TextDocumentCodeLens lens ] , pluginNotificationHandlers = mconcat @@ -269,6 +266,36 @@ cabalAddDependencyCodeAction _ state plId (CodeActionParams _ _ (TextDocumentIde gpd pure $ InL $ fmap InR actions +lens :: PluginMethodHandler IdeState LSP.Method_TextDocumentCodeLens +lens state _plId clp = do + packageDependenciesLens <- + fmap (Maybe.fromMaybe mempty) $ + whenMaybe (not $ inlayHintCapabilityAvailable state) $ do + let uri = clp ^. JL.textDocument . JL.uri + nfp <- getNormalizedFilePathE uri + cabalFields <- runActionE "cabal.cabal-code-lens" state $ useE ParseCabalFields nfp + (hscEnv -> hsc) <- runActionE "cabal.cabal-code-lens" state $ useE GhcSession nfp + pure $ Dependencies.dependencyVersionLens cabalFields hsc + + pure $ InL packageDependenciesLens + +hints :: PluginMethodHandler IdeState LSP.Method_TextDocumentInlayHint +hints state _plId clp = do + packageDependenciesHints <- + fmap (Maybe.fromMaybe mempty) $ + whenMaybe (inlayHintCapabilityAvailable state) $ do + let uri = clp ^. JL.textDocument . JL.uri + nfp <- getNormalizedFilePathE uri + cabalFields <- runActionE "cabal.cabal-hints" state $ useE ParseCabalFields nfp + (hscEnv -> hsc) <- runActionE "cabal.cabal-hints" state $ useE GhcSession nfp + pure $ Dependencies.dependencyVersionHints cabalFields hsc + pure $ InL packageDependenciesHints + +inlayHintCapabilityAvailable :: IdeState -> Bool +inlayHintCapabilityAvailable state = + let clientCaps = Shake.clientCapabilities $ shakeExtras state + in Maybe.isJust $ clientCaps ^? JL.textDocument . _Just . JL.inlayHint . _Just + cabalAddModuleCodeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction cabalAddModuleCodeAction recorder state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics = diags}) = case List.find CabalAdd.isUnknownModuleDiagnostic diags of @@ -305,46 +332,12 @@ 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) + (hscEnv -> hsc) <- runActionE "cabal.cabal-hover" ide $ useE GhcSession nfp + pure $ Dependencies.dependencyHover cabalFields hsc cursor + where + cursor = 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 <> ")" - -- ---------------------------------------------------------------- -- Completion -- ---------------------------------------------------------------- diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Dependencies.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Dependencies.hs new file mode 100644 index 0000000000..6c400aea23 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Dependencies.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.Cabal.Dependencies (dependencyVersionHints, dependencyVersionLens, dependencyHover) where + +import Control.Lens (to, (^.)) +import Data.Array ((!)) +import Data.ByteString (ByteString) +import Data.List +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import qualified Data.Text.Encoding as Encoding +import Data.Version (Version (..)) +import Development.IDE.GHC.Compat (HscEnv, getUnitInfoMap, + unitPackageNameString, + unitPackageVersion) +#if MIN_VERSION_GLASGOW_HASKELL(9,8,0,0) +import Development.IDE.GHC.Compat (nonDetEltsUniqMap) +#endif +import Development.IDE.LSP.HoverDefinition (foundHover) +import qualified Distribution.Fields as Syntax +import qualified Distribution.Parsec.Position as Syntax +import qualified Ide.Plugin.Cabal.Completion.Types as Types +import qualified Language.LSP.Protocol.Lens as JL +import Language.LSP.Protocol.Types (CodeLens (..), + Command (..), Hover, + InlayHint (..), Null (..), + Position, Range (..), + positionInRange, + type (|?) (..)) +import Text.Regex.TDFA (Regex, makeRegex, + matchAllText) + +dependencyVersionLens :: [Syntax.Field Syntax.Position] -> HscEnv -> [CodeLens] +dependencyVersionLens cabalFields = Maybe.catMaybes . (>>= foo) . groupBy (\a b-> (a ^. to range . JL.start . JL.line) == (b ^. to range . JL.start . JL.line)) . collectPackageDependencyVersions cabalFields + where + foo :: [DependencyInfo] -> [Maybe CodeLens] + foo [] = [] + foo [single] = [mkCodeLens False single] + foo multi = mkCodeLens True <$> multi + + mkCodeLens :: Bool -> DependencyInfo -> Maybe CodeLens + mkCodeLens includePkgName DependencyInfo{range, packageName, installedVersion = Just version} = + let dependencyText = + if includePkgName + then packageName <> " (" <> printVersion version <> ")" + else printVersion version + command = Command dependencyText mempty Nothing + in Just $ CodeLens + { _range = range + , _command = Just command + , _data_ = Nothing } + mkCodeLens _ _ = Nothing + +dependencyVersionHints :: [Syntax.Field Syntax.Position] -> HscEnv -> [InlayHint] +dependencyVersionHints cabalFields = Maybe.mapMaybe mkHint . collectPackageDependencyVersions cabalFields + where + mkHint :: DependencyInfo -> Maybe InlayHint + mkHint (DependencyInfo range _ (Just installedVersion)) = + Just $ + InlayHint { _position = range ^. JL.end + , _label = InL $ " (" <> printVersion installedVersion <> ")" + , _kind = Nothing + , _textEdits = Nothing + , _tooltip = Nothing + , _paddingLeft = Nothing + , _paddingRight = Nothing + , _data_ = Nothing + } + mkHint _ = Nothing + +dependencyHover :: [Syntax.Field Syntax.Position] -> HscEnv -> Position -> Hover |? Null +dependencyHover cabalFields hsc cursorPosition = + let hoveredDep = List.find (positionInRange cursorPosition . range) $ collectPackageDependencyVersions cabalFields hsc + in case hoveredDep of + Just (DependencyInfo {packageName, installedVersion}) -> + let showVersion f = maybe T.empty (f . printVersion) installedVersion + in foundHover (Nothing, [packageName <> showVersion (\v -> " (" <> v <> ")") <> "\n", documentationText (packageName <> showVersion ("-" <>))]) + Nothing -> InR Null + where + documentationText :: T.Text -> T.Text + documentationText package = "[Documentation](https://hackage.haskell.org/package/" <> package <> ")" + +collectPackageDependencyVersions :: [Syntax.Field Syntax.Position] -> HscEnv -> [DependencyInfo] +collectPackageDependencyVersions cabalFields hscEnv = cabalFields >>= collectPackageVersions + where +#if MIN_VERSION_GLASGOW_HASKELL(9,8,0,0) + unitInfoList = nonDetEltsUniqMap $ getUnitInfoMap hscEnv +#else + unitInfoList = getUnitInfoMap hscEnv +#endif + lookupPackageVersion pkgName = fmap unitPackageVersion $ find ((==) (T.unpack pkgName) . unitPackageNameString) unitInfoList + + collectPackageVersions :: Syntax.Field Syntax.Position -> [DependencyInfo] + collectPackageVersions (Syntax.Field (Syntax.Name _ "build-depends") pos) = concatMap fieldLinePackageVersions pos + collectPackageVersions (Syntax.Section _ _ fields) = concatMap collectPackageVersions fields + collectPackageVersions _ = [] + + fieldLinePackageVersions :: Syntax.FieldLine Syntax.Position -> [DependencyInfo] + fieldLinePackageVersions (Syntax.FieldLine pos line) = + let linePackageNameRegex :: Regex = makeRegex ("(^|,)[[:space:]]*([a-zA-Z-]+)" :: ByteString) + packageNames = (\x -> x ! 2) <$> matchAllText linePackageNameRegex (Encoding.decodeUtf8Lenient line) + versions = do + (pkgName, (pkgIndex, pkgOffset)) <- packageNames + let pkgPosStart = Types.cabalPositionToLSPPosition $ Syntax.Position (Syntax.positionRow pos) (Syntax.positionCol pos + pkgIndex) + pkgPosEnd = Types.cabalPositionToLSPPosition $ Syntax.Position (Syntax.positionRow pos) (Syntax.positionCol pos + pkgIndex + pkgOffset) + version = lookupPackageVersion pkgName + pure $ DependencyInfo (Range pkgPosStart pkgPosEnd) pkgName version + in versions + +data DependencyInfo = DependencyInfo + { range :: Range + , packageName :: T.Text + , installedVersion :: Maybe Version + } + +printVersion :: Version -> T.Text +printVersion v = T.intercalate "." (fmap (T.pack . show) $ versionBranch v) diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs index 43794e753d..46cbca4f61 100644 --- a/plugins/hls-cabal-plugin/test/Main.hs +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -12,7 +12,7 @@ import CabalAdd (cabalAddDependencyTests, cabalAddModuleTests) import Completer (completerTests) import Context (contextTests) -import Control.Lens ((^.)) +import Control.Lens (_Just, preview, view, (^.)) import Control.Lens.Fold ((^?)) import Control.Monad (guard) import qualified Data.ByteString as BS @@ -48,6 +48,7 @@ main = do , gotoDefinitionTests , hoverTests , reloadOnCabalChangeTests + , codeLensTests ] -- ------------------------------------------------------------------------ @@ -234,7 +235,7 @@ hoverTests = testGroup "Hover" 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 "base with separated version" "hover-deps.cabal" (Position 6 25) "[Documentation](https://hackage.haskell.org/package/base-4.19.2.0)" , 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)" @@ -325,3 +326,27 @@ saveDoc docId t = do let params = DidSaveTextDocumentParams docId Nothing sendNotification L.SMethod_TextDocumentDidSave params + +-- ---------------------------------------------------------------------------- +-- Code Lens Tests +-- ---------------------------------------------------------------------------- + +codeLensTests :: TestTree +codeLensTests = testGroup "Code Lens" + [ dependencyVersionLenses + , dependencyVersionInlayHints + ] + where + dependencyVersionLenses = + runCabalTestCaseSession "Code Lens Test" "dependencies" $ do + doc <- openDoc "deps-versions.cabal" "cabal" + lenses <- getCodeLenses doc + liftIO $ map (preview $ L.command . _Just . L.title) lenses @?= [Just "4.19.2.0", Just "text (2.1.1)", Just "transformers (0.6.1.0)"] + closeDoc doc + dependencyVersionInlayHints = + runCabalTestCaseSession "InlayHints tests" "dependencies" $ do + doc <- openDoc "deps-versions.cabal" "cabal" + let range = Range (Position 0 0) (Position 1000 1000) + hints <- getInlayHints doc range + liftIO $ map (view L.label) hints @?= [InL " (4.19.2.0)",InL " (2.1.1)",InL " (0.6.1.0)"] + closeDoc doc diff --git a/plugins/hls-cabal-plugin/test/testdata/dependencies/deps-versions.cabal b/plugins/hls-cabal-plugin/test/testdata/dependencies/deps-versions.cabal new file mode 100644 index 0000000000..16dd4b733d --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/dependencies/deps-versions.cabal @@ -0,0 +1,10 @@ +cabal-version: 3.0 +name: deps-versions +version: 0.1.0.0 + +library + exposed-modules: Module + build-depends: base ^>=4.14.3.0 + , text, transformers + hs-source-dirs: src + default-language: Haskell2010