diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index f49c619ec1..362d565283 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 @@ -262,6 +263,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 9a56467f3f..fea61c34f6 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -3,12 +3,14 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.Cabal (descriptor, haskellInteractionDescriptor, Log (..)) where import Control.Concurrent.Strict import Control.DeepSeq -import Control.Lens ((^.)) +import Control.Lens (_Just, (^.), + (^?)) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) @@ -55,6 +57,7 @@ import Ide.Plugin.Cabal.Completion.Types (ParseCabalCommon 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.Diagnostics as Diagnostics import qualified Ide.Plugin.Cabal.FieldSuggest as FieldSuggest import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest @@ -135,6 +138,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 @@ -376,6 +381,36 @@ cabalAddCodeAction state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) 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 + -- | Handler for hover messages. -- -- Provides a Handler for displaying message on hover. 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..9f17ccce26 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Dependencies.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.Cabal.Dependencies (dependencyVersionHints, collectPackageDependencyVersions, dependencyVersionLens) where + +import Data.Array ((!)) +import Data.ByteString (ByteString) +import Data.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, filterUniqMap, + getUnitInfoMap, + nonDetEltsUniqMap, + unitPackageNameString, + unitPackageVersion) +import qualified Distribution.Fields as Syntax +import qualified Distribution.Parsec.Position as Syntax +import qualified Ide.Plugin.Cabal.Completion.Types as Types +import Language.LSP.Protocol.Types (CodeLens (..), Command (..), + InlayHint (..), Range (..), + type (|?) (..)) +import Text.Regex.TDFA (Regex, makeRegex, + matchAllText) + +dependencyVersionLens :: [Syntax.Field Syntax.Position] -> HscEnv -> [CodeLens] +dependencyVersionLens cabalFields = (>>= foo) . groupBy (\(Syntax.Position line1 _, _, _) (Syntax.Position line2 _, _, _) -> line1 == line2) . collectPackageDependencyVersions cabalFields + where + foo :: [(Syntax.Position, T.Text, Version)] -> [CodeLens] + foo [] = [] + foo [single] = [mkCodeLens False single] + foo multi = mkCodeLens True <$> multi + + mkCodeLens :: Bool -> (Syntax.Position, T.Text, Version) -> CodeLens + mkCodeLens includePkgName (pos, pkgName, dependencyVersion) = + let cPos = Types.cabalPositionToLSPPosition pos + dependencyText = + if includePkgName + then pkgName <> " (" <> printVersion dependencyVersion <> ")" + else printVersion dependencyVersion + command = Command dependencyText mempty Nothing + in CodeLens + { _range = Range cPos cPos + , _command = Just command + , _data_ = Nothing } + +dependencyVersionHints :: [Syntax.Field Syntax.Position] -> HscEnv -> [InlayHint] +dependencyVersionHints cabalFields = fmap mkHint . collectPackageDependencyVersions cabalFields + where + mkHint :: (Syntax.Position, T.Text, Version) -> InlayHint + mkHint (pos, _, dependencyVersion) = + InlayHint { _position = Types.cabalPositionToLSPPosition pos + , _label = InL $ " (" <> printVersion dependencyVersion <> ")" + , _kind = Nothing + , _textEdits = Nothing + , _tooltip = Nothing + , _paddingLeft = Nothing + , _paddingRight = Nothing + , _data_ = Nothing + } + +collectPackageDependencyVersions :: [Syntax.Field Syntax.Position] -> HscEnv -> [(Syntax.Position, T.Text, Version)] +collectPackageDependencyVersions cabalFields hscEnv = cabalFields >>= collectPackageVersions + where + lookupPackageVersion pkgName = Maybe.listToMaybe $ nonDetEltsUniqMap $ fmap unitPackageVersion $ filterUniqMap ((==) (T.unpack pkgName) . unitPackageNameString) $ getUnitInfoMap hscEnv + + collectPackageVersions :: Syntax.Field Syntax.Position -> [(Syntax.Position, T.Text, Version)] + collectPackageVersions (Syntax.Field (Syntax.Name _ "build-depends") pos) = concatMap fieldLinePackageVersions pos + collectPackageVersions (Syntax.Section _ _ fields) = concatMap collectPackageVersions fields + collectPackageVersions _ = [] + + fieldLinePackageVersions :: Syntax.FieldLine Syntax.Position -> [(Syntax.Position, T.Text, Version)] + 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 + version <- Maybe.maybeToList $ lookupPackageVersion pkgName + pure (Syntax.Position (Syntax.positionRow pos) (Syntax.positionCol pos + pkgIndex + pkgOffset), pkgName, version) + in versions + +printVersion :: Version -> T.Text +printVersion v = T.intercalate "." (fmap (T.pack . show) $ versionBranch v) diff --git a/plugins/hls-cabal-plugin/test/CabalAdd.hs b/plugins/hls-cabal-plugin/test/CabalAdd.hs index 6517c811fe..12ae6cb3ef 100644 --- a/plugins/hls-cabal-plugin/test/CabalAdd.hs +++ b/plugins/hls-cabal-plugin/test/CabalAdd.hs @@ -175,7 +175,6 @@ cabalAddTests = , _data_ = Nothing } - generatePackageYAMLTestSession :: FilePath -> Session () generatePackageYAMLTestSession haskellFile = do hsdoc <- openDoc haskellFile "haskell" diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs index fcb85a081e..1e5bd16295 100644 --- a/plugins/hls-cabal-plugin/test/Main.hs +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -9,7 +9,7 @@ module Main ( import CabalAdd (cabalAddTests) import Completer (completerTests) import Context (contextTests) -import Control.Lens ((^.)) +import Control.Lens ((^.), preview, _Just, view) import Control.Lens.Fold ((^?)) import Control.Monad (guard) import qualified Data.ByteString as BS @@ -39,6 +39,7 @@ main = do , codeActionTests , gotoDefinitionTests , hoverTests + , codeLensTests ] -- ------------------------------------------------------------------------ @@ -259,3 +260,27 @@ hoverOnDependencyTests = testGroup "Hover Dependency" h <- getHover doc pos liftIO $ assertBool ("Found hover `" <> show h <> "`") $ Maybe.isNothing h closeDoc doc + +-- ---------------------------------------------------------------------------- +-- 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